summaryrefslogtreecommitdiffstats
path: root/Lib/test/test_pep247.py
blob: 7f104728565b9f8438bb000cbb1d5f52bb9158c8 (plain)
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
"""
Test suite to check compilance with PEP 247, the standard API
for hashing algorithms
"""

import hmac
import unittest
from hashlib import md5, sha1, sha224, sha256, sha384, sha512
from test import support

class Pep247Test(unittest.TestCase):

    def check_module(self, module, key=None):
        self.assertTrue(hasattr(module, 'digest_size'))
        self.assertTrue(module.digest_size is None or module.digest_size > 0)
        self.check_object(module.new, module.digest_size, key)

    def check_object(self, cls, digest_size, key):
        if key is not None:
            obj1 = cls(key)
            obj2 = cls(key, b'string')
            h1 = cls(key, b'string').digest()
            obj3 = cls(key)
            obj3.update(b'string')
            h2 = obj3.digest()
        else:
            obj1 = cls()
            obj2 = cls(b'string')
            h1 = cls(b'string').digest()
            obj3 = cls()
            obj3.update(b'string')
            h2 = obj3.digest()
        self.assertEqual(h1, h2)
        self.assertTrue(hasattr(obj1, 'digest_size'))

        if digest_size is not None:
            self.assertEqual(obj1.digest_size, digest_size)

        self.assertEqual(obj1.digest_size, len(h1))
        obj1.update(b'string')
        obj_copy = obj1.copy()
        self.assertEqual(obj1.digest(), obj_copy.digest())
        self.assertEqual(obj1.hexdigest(), obj_copy.hexdigest())

        digest, hexdigest = obj1.digest(), obj1.hexdigest()
        hd2 = ""
        for byte in digest:
            hd2 += '%02x' % byte
        self.assertEqual(hd2, hexdigest)

    def test_md5(self):
        self.check_object(md5, None, None)

    def test_sha(self):
        self.check_object(sha1, None, None)
        self.check_object(sha224, None, None)
        self.check_object(sha256, None, None)
        self.check_object(sha384, None, None)
        self.check_object(sha512, None, None)

    def test_hmac(self):
        self.check_module(hmac, key=b'abc')

def test_main():
    support.run_unittest(Pep247Test)

if __name__ == '__main__':
    test_main()
c Tcl is a high-level, general-purpose, interpreted, dynamic programming language. It was designed with the goal of being very simple but powerful.
summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.fossil-settings/crlf-glob2
-rw-r--r--.fossil-settings/encoding-glob4
-rw-r--r--.github/workflows/linux-build.yml5
-rw-r--r--.github/workflows/mac-build.yml11
-rw-r--r--.github/workflows/onefiledist.yml152
-rw-r--r--.github/workflows/win-build.yml9
-rw-r--r--.project2
-rw-r--r--.travis.yml84
-rw-r--r--ChangeLog8856
-rw-r--r--ChangeLog.19992634
-rw-r--r--ChangeLog.20002539
-rw-r--r--ChangeLog.20013629
-rw-r--r--ChangeLog.20024741
-rw-r--r--ChangeLog.20033349
-rw-r--r--ChangeLog.20044619
-rw-r--r--ChangeLog.20053822
-rw-r--r--ChangeLog.20075921
-rw-r--r--ChangeLog.20083796
-rw-r--r--README.md14
-rw-r--r--changes357
-rw-r--r--compat/dirent.h21
-rw-r--r--compat/dirent2.h53
-rw-r--r--compat/fake-rfc2553.c3
-rw-r--r--compat/float.h14
-rw-r--r--compat/memcmp.c64
-rw-r--r--compat/mkstemp.c11
-rw-r--r--compat/opendir.c110
-rw-r--r--compat/stdlib.h39
-rw-r--r--compat/string.h8
-rw-r--r--compat/strstr.c70
-rw-r--r--compat/strtol.c77
-rw-r--r--compat/strtoul.c214
-rw-r--r--compat/unistd.h76
-rw-r--r--compat/waitpid.c2
-rwxr-xr-xcompat/zlib/win32/zlib1.dllbin123904 -> 92160 bytes
-rw-r--r--compat/zlib/win64/libz.dll.abin53518 -> 13480 bytes
-rwxr-xr-xcompat/zlib/win64/zlib1.dllbin135168 -> 102400 bytes
-rw-r--r--doc/AddErrInfo.321
-rw-r--r--doc/Async.335
-rw-r--r--doc/BoolObj.341
-rw-r--r--doc/ByteArrObj.3202
-rw-r--r--doc/Cancel.38
-rw-r--r--doc/Class.338
-rw-r--r--doc/CrtAlias.353
-rw-r--r--doc/CrtChannel.321
-rw-r--r--doc/CrtInterp.36
-rw-r--r--doc/CrtMathFnc.34
-rw-r--r--doc/CrtObjCmd.339
-rw-r--r--doc/CrtTrace.343
-rw-r--r--doc/DString.319
-rw-r--r--doc/DictObj.367
-rw-r--r--doc/DoubleObj.312
-rw-r--r--doc/Encoding.3128
-rw-r--r--doc/Ensemble.325
-rw-r--r--doc/Eval.325
-rw-r--r--doc/Exit.33
-rw-r--r--doc/ExprLongObj.39
-rw-r--r--doc/FileSystem.3200
-rw-r--r--doc/FindExec.39
-rw-r--r--doc/GetIndex.339
-rw-r--r--doc/GetInt.320
-rw-r--r--doc/Hash.316
-rw-r--r--doc/Init.314
-rw-r--r--doc/InitStubs.36
-rw-r--r--doc/InitSubSyst.334
-rw-r--r--doc/IntObj.345
-rw-r--r--doc/Interp.3121
-rw-r--r--doc/LinkVar.3150
-rw-r--r--doc/ListObj.325
-rw-r--r--doc/Load.34
-rw-r--r--doc/Method.370
-rw-r--r--doc/NRE.338
-rw-r--r--doc/Namespace.312
-rw-r--r--doc/Notifier.349
-rw-r--r--doc/Number.3123
-rw-r--r--doc/Object.37
-rw-r--r--doc/ObjectType.322
-rw-r--r--doc/OpenFileChnl.360
-rw-r--r--doc/OpenTcp.323
-rw-r--r--doc/Panic.325
-rw-r--r--doc/ParseArgs.36
-rw-r--r--doc/ParseCmd.38
-rw-r--r--doc/PkgRequire.36
-rw-r--r--doc/RecEvalObj.38
-rw-r--r--doc/RegConfig.38
-rw-r--r--doc/RegExp.316
-rw-r--r--doc/SaveInterpState.385
-rw-r--r--doc/SaveResult.3120
-rw-r--r--doc/SetChanErr.315
-rw-r--r--doc/SetResult.348
-rw-r--r--doc/SetVar.321
-rw-r--r--doc/StaticLibrary.378
-rw-r--r--doc/StaticPkg.370
-rw-r--r--doc/StringObj.347
-rw-r--r--doc/SubstObj.37
-rw-r--r--doc/Tcl.n319
-rw-r--r--doc/TclZlib.327
-rw-r--r--doc/Tcl_Main.317
-rw-r--r--doc/Thread.314
-rw-r--r--doc/ToUpper.313
-rw-r--r--doc/TraceVar.339
-rw-r--r--doc/UniCharIsAlpha.310
-rw-r--r--doc/Utf.3172
-rw-r--r--doc/WrongNumArgs.36
-rw-r--r--doc/abstract.n77
-rw-r--r--doc/append.n12
-rw-r--r--doc/array.n62
-rw-r--r--doc/binary.n393
-rw-r--r--doc/callback.n88
-rw-r--r--doc/catch.n6
-rw-r--r--doc/cd.n6
-rw-r--r--doc/chan.n1146
-rw-r--r--doc/class.n2
-rw-r--r--doc/classvariable.n78
-rw-r--r--doc/clock.n45
-rw-r--r--doc/close.n25
-rw-r--r--doc/configurable.n333
-rw-r--r--doc/continue.n2
-rw-r--r--doc/cookiejar.n217
-rw-r--r--doc/copy.n2
-rw-r--r--doc/coroutine.n108
-rw-r--r--doc/dde.n6
-rw-r--r--doc/define.n605
-rw-r--r--doc/dict.n55
-rw-r--r--doc/encoding.n211
-rw-r--r--doc/eof.n4
-rw-r--r--doc/exec.n2
-rw-r--r--doc/exit.n4
-rw-r--r--doc/expr.n486
-rw-r--r--doc/fblocked.n4
-rw-r--r--doc/fconfigure.n20
-rw-r--r--doc/fcopy.n56
-rw-r--r--doc/file.n119
-rw-r--r--doc/fileevent.n4
-rw-r--r--doc/filename.n16
-rw-r--r--doc/flush.n4
-rw-r--r--doc/foreach.n4
-rw-r--r--doc/format.n29
-rw-r--r--doc/fpclassify.n83
-rw-r--r--doc/gets.n37
-rw-r--r--doc/global.n4
-rw-r--r--doc/history.n4
-rw-r--r--doc/http.n1170
-rw-r--r--doc/idna.n88
-rw-r--r--doc/incr.n9
-rw-r--r--doc/info.n696
-rw-r--r--doc/interp.n36
-rw-r--r--doc/join.n4
-rw-r--r--doc/lappend.n15
-rw-r--r--doc/lassign.n4
-rw-r--r--doc/ledit.n91
-rw-r--r--doc/library.n159
-rw-r--r--doc/lindex.n7
-rw-r--r--doc/link.n124
-rw-r--r--doc/linsert.n5
-rw-r--r--doc/list.n6
-rw-r--r--doc/llength.n9
-rw-r--r--doc/lmap.n5
-rw-r--r--doc/load.n11
-rw-r--r--doc/lpop.n97
-rw-r--r--doc/lrange.n9
-rw-r--r--doc/lremove.n57
-rw-r--r--doc/lrepeat.n9
-rw-r--r--doc/lreplace.n5
-rw-r--r--doc/lreverse.n5
-rw-r--r--doc/lsearch.n28
-rw-r--r--doc/lseq.n99
-rw-r--r--doc/lset.n5
-rw-r--r--doc/lsort.n7
-rw-r--r--doc/mathfunc.n79
-rw-r--r--doc/mathop.n69
-rw-r--r--doc/msgcat.n213
-rw-r--r--doc/my.n95
-rw-r--r--doc/namespace.n4
-rw-r--r--doc/next.n7
-rw-r--r--doc/object.n2
-rw-r--r--doc/open.n167
-rw-r--r--doc/package.n12
-rw-r--r--doc/packagens.n6
-rw-r--r--doc/pid.n5
-rw-r--r--doc/platform.n2
-rw-r--r--doc/platform_shell.n6
-rw-r--r--doc/prefix.n12
-rw-r--r--doc/process.n150
-rw-r--r--doc/puts.n10
-rw-r--r--doc/pwd.n4
-rw-r--r--doc/read.n73
-rw-r--r--doc/refchan.n28
-rw-r--r--doc/registry.n2
-rw-r--r--doc/regsub.n74
-rw-r--r--doc/rename.n4
-rw-r--r--doc/return.n2
-rw-r--r--doc/safe.n168
-rw-r--r--doc/self.n9
-rw-r--r--doc/set.n4
-rw-r--r--doc/singleton.n99
-rw-r--r--doc/socket.n23
-rw-r--r--doc/source.n12
-rw-r--r--doc/string.n57
-rw-r--r--doc/tclsh.117
-rw-r--r--doc/tcltest.n1
-rw-r--r--doc/tclvars.n2
-rw-r--r--doc/tell.n6
-rw-r--r--doc/timerate.n6
-rw-r--r--doc/trace.n5
-rw-r--r--doc/transchan.n13
-rw-r--r--doc/unknown.n4
-rw-r--r--doc/unload.n5
-rw-r--r--doc/update.n4
-rw-r--r--doc/uplevel.n4
-rw-r--r--doc/upvar.n2
-rw-r--r--doc/vwait.n71
-rw-r--r--doc/while.n4
-rw-r--r--doc/zipfs.3130
-rw-r--r--doc/zipfs.n293
-rw-r--r--generic/regc_color.c4
-rw-r--r--generic/regc_cvec.c2
-rw-r--r--generic/regc_lex.c12
-rw-r--r--generic/regc_locale.c92
-rw-r--r--generic/regc_nfa.c6
-rw-r--r--generic/regcomp.c69
-rw-r--r--generic/regcustom.h15
-rw-r--r--generic/rege_dfa.c4
-rw-r--r--generic/regerror.c2
-rw-r--r--generic/regex.h4
-rw-r--r--generic/regexec.c102
-rw-r--r--generic/regfree.c2
-rw-r--r--generic/regfronts.c2
-rw-r--r--generic/regguts.h35
-rw-r--r--generic/tcl.decls840
-rw-r--r--generic/tcl.h827
-rw-r--r--generic/tclAlloc.c84
-rwxr-xr-xgeneric/tclArithSeries.c1104
-rw-r--r--generic/tclAssembly.c178
-rw-r--r--generic/tclAsync.c216
-rw-r--r--generic/tclBasic.c2251
-rw-r--r--generic/tclBinary.c688
-rw-r--r--generic/tclCkalloc.c345
-rw-r--r--generic/tclClock.c184
-rw-r--r--generic/tclCmdAH.c936
-rw-r--r--generic/tclCmdIL.c1699
-rw-r--r--generic/tclCmdMZ.c1464
-rw-r--r--generic/tclCompCmds.c203
-rw-r--r--generic/tclCompCmdsGR.c369
-rw-r--r--generic/tclCompCmdsSZ.c417
-rw-r--r--generic/tclCompExpr.c149
-rw-r--r--generic/tclCompile.c682
-rw-r--r--generic/tclCompile.h317
-rw-r--r--generic/tclConfig.c27
-rw-r--r--generic/tclDate.c25
-rw-r--r--generic/tclDecls.h1924
-rw-r--r--generic/tclDictObj.c581
-rw-r--r--generic/tclDisassemble.c290
-rw-r--r--generic/tclEncoding.c1576
-rw-r--r--generic/tclEnsemble.c683
-rw-r--r--generic/tclEnv.c78
-rw-r--r--generic/tclEvent.c629
-rw-r--r--generic/tclExecute.c2751
-rw-r--r--generic/tclFCmd.c259
-rw-r--r--generic/tclFileName.c168
-rw-r--r--generic/tclFileSystem.h2
-rw-r--r--generic/tclGet.c34
-rw-r--r--generic/tclGetDate.y8
-rw-r--r--generic/tclHash.c190
-rw-r--r--generic/tclHistory.c17
-rw-r--r--generic/tclIO.c1105
-rw-r--r--generic/tclIO.h39
-rw-r--r--generic/tclIOCmd.c331
-rw-r--r--generic/tclIOGT.c111
-rw-r--r--generic/tclIORChan.c458
-rw-r--r--generic/tclIORTrans.c244
-rw-r--r--generic/tclIOSock.c104
-rw-r--r--generic/tclIOUtil.c2324
-rw-r--r--generic/tclIndexObj.c283
-rw-r--r--generic/tclInt.decls227
-rw-r--r--generic/tclInt.h1500
-rw-r--r--generic/tclIntDecls.h550
-rw-r--r--generic/tclIntPlatDecls.h43
-rw-r--r--generic/tclInterp.c396
-rw-r--r--generic/tclLink.c1304
-rw-r--r--generic/tclListObj.c3764
-rw-r--r--generic/tclLiteral.c112
-rw-r--r--generic/tclLoad.c941
-rw-r--r--generic/tclLoadNone.c50
-rw-r--r--generic/tclMain.c99
-rw-r--r--generic/tclNamesp.c519
-rw-r--r--generic/tclNotify.c340
-rw-r--r--generic/tclOO.c845
-rw-r--r--generic/tclOO.decls35
-rw-r--r--generic/tclOO.h22
-rw-r--r--generic/tclOOBasic.c232
-rw-r--r--generic/tclOOCall.c1201
-rw-r--r--generic/tclOODecls.h53
-rw-r--r--generic/tclOODefineCmds.c1453
-rw-r--r--generic/tclOOInfo.c525
-rw-r--r--generic/tclOOInt.h279
-rw-r--r--generic/tclOOIntDecls.h28
-rw-r--r--generic/tclOOMethod.c122
-rw-r--r--generic/tclOOScript.h493
-rw-r--r--generic/tclOOStubInit.c6
-rw-r--r--generic/tclOOStubLib.c9
-rw-r--r--generic/tclObj.c1565
-rw-r--r--generic/tclOptimize.c12
-rw-r--r--generic/tclPanic.c18
-rw-r--r--generic/tclParse.c258
-rw-r--r--generic/tclParse.h2
-rw-r--r--generic/tclPathObj.c814
-rw-r--r--generic/tclPipe.c104
-rw-r--r--generic/tclPkg.c589
-rw-r--r--generic/tclPkgConfig.c17
-rw-r--r--generic/tclPlatDecls.h49
-rw-r--r--generic/tclPort.h15
-rw-r--r--generic/tclPosixStr.c112
-rw-r--r--generic/tclPreserve.c23
-rw-r--r--generic/tclProc.c520
-rw-r--r--generic/tclProcess.c951
-rw-r--r--generic/tclRegexp.c92
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResolve.c8
-rw-r--r--generic/tclResult.c135
-rw-r--r--generic/tclScan.c101
-rw-r--r--generic/tclStrToD.c943
-rw-r--r--generic/tclStringObj.c2555
-rw-r--r--generic/tclStringRep.h86
-rw-r--r--generic/tclStubInit.c889
-rw-r--r--generic/tclStubLib.c56
-rw-r--r--generic/tclTest.c2403
-rw-r--r--generic/tclTestObj.c741
-rw-r--r--generic/tclTestProcBodyObj.c40
-rw-r--r--generic/tclThread.c57
-rw-r--r--generic/tclThreadAlloc.c166
-rw-r--r--generic/tclThreadJoin.c2
-rw-r--r--generic/tclThreadStorage.c22
-rw-r--r--generic/tclThreadTest.c105
-rw-r--r--generic/tclTimer.c78
-rw-r--r--generic/tclTomMath.decls166
-rw-r--r--generic/tclTomMath.h1166
-rw-r--r--generic/tclTomMathDecls.h564
-rw-r--r--generic/tclTomMathInterface.c136
-rw-r--r--generic/tclTomMathStubLib.c9
-rw-r--r--generic/tclTrace.c317
-rw-r--r--generic/tclUniData.c2
-rw-r--r--generic/tclUtf.c1022
-rw-r--r--generic/tclUtil.c1029
-rw-r--r--generic/tclVar.c1672
-rw-r--r--generic/tclZipfs.c6571
-rw-r--r--generic/tclZlib.c324
-rw-r--r--generic/tommath.h1
-rw-r--r--library/auto.tcl85
-rw-r--r--library/clock.tcl4
-rw-r--r--library/cookiejar/cookiejar.tcl746
-rw-r--r--library/cookiejar/idna.tcl292
-rw-r--r--library/cookiejar/pkgIndex.tcl3
-rw-r--r--library/cookiejar/public_suffix_list.dat.gzbin0 -> 70835 bytes
-rw-r--r--library/dde/pkgIndex.tcl6
-rw-r--r--library/encoding/ascii.enc2
-rw-r--r--library/encoding/big5.enc4
-rw-r--r--library/encoding/cp1250.enc4
-rw-r--r--library/encoding/cp1251.enc2
-rw-r--r--library/encoding/cp1252.enc4
-rw-r--r--library/encoding/cp1253.enc4
-rw-r--r--library/encoding/cp1254.enc4
-rw-r--r--library/encoding/cp1255.enc4
-rw-r--r--library/encoding/cp1257.enc4
-rw-r--r--library/encoding/cp1258.enc4
-rw-r--r--library/encoding/cp864.enc2
-rw-r--r--library/encoding/cp869.enc4
-rw-r--r--library/encoding/cp874.enc4
-rw-r--r--library/encoding/cp932.enc2
-rw-r--r--library/encoding/cp949.enc2
-rw-r--r--library/encoding/cp950.enc4
-rw-r--r--library/encoding/dingbats.enc4
-rw-r--r--library/encoding/ebcdic.enc1
-rw-r--r--library/encoding/euc-cn.enc4
-rw-r--r--library/encoding/euc-jp.enc4
-rw-r--r--library/encoding/euc-kr.enc4
-rw-r--r--library/encoding/gb1988.enc4
-rw-r--r--library/encoding/jis0201.enc4
-rw-r--r--library/encoding/macDingbats.enc4
-rw-r--r--library/encoding/macJapan.enc2
-rw-r--r--library/encoding/shiftjis.enc2
-rw-r--r--library/encoding/symbol.enc4
-rw-r--r--library/encoding/tis-620.enc2
-rw-r--r--library/foreachline.tcl25
-rw-r--r--library/history.tcl2
-rw-r--r--library/http/http.tcl2687
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--library/http1.0/http.tcl377
-rw-r--r--library/http1.0/pkgIndex.tcl11
-rw-r--r--library/init.tcl123
-rw-r--r--library/install.tcl247
-rw-r--r--library/manifest.txt20
-rw-r--r--library/msgcat/msgcat.tcl331
-rw-r--r--library/msgcat/pkgIndex.tcl4
-rw-r--r--library/msgs/ar.msg84
-rw-r--r--library/msgs/ar_jo.msg62
-rw-r--r--library/msgs/ar_lb.msg62
-rw-r--r--library/msgs/ar_sy.msg62
-rw-r--r--library/msgs/be.msg80
-rw-r--r--library/msgs/bg.msg56
-rw-r--r--library/msgs/bn.msg80
-rw-r--r--library/msgs/ca.msg4
-rw-r--r--library/msgs/cs.msg34
-rw-r--r--library/msgs/da.msg8
-rw-r--r--library/msgs/de.msg2
-rw-r--r--library/msgs/de_at.msg8
-rw-r--r--library/msgs/de_be.msg4
-rw-r--r--library/msgs/el.msg80
-rw-r--r--library/msgs/eo.msg10
-rw-r--r--library/msgs/es.msg8
-rw-r--r--library/msgs/et.msg16
-rw-r--r--library/msgs/fa.msg76
-rw-r--r--library/msgs/fa_in.msg80
-rw-r--r--library/msgs/fa_ir.msg8
-rw-r--r--library/msgs/fi.msg8
-rw-r--r--library/msgs/fo.msg18
-rw-r--r--library/msgs/fr.msg12
-rw-r--r--library/msgs/ga.msg50
-rw-r--r--library/msgs/gl.msg12
-rw-r--r--library/msgs/he.msg80
-rw-r--r--library/msgs/hi.msg64
-rw-r--r--library/msgs/hr.msg12
-rw-r--r--library/msgs/hu.msg34
-rw-r--r--library/msgs/is.msg44
-rw-r--r--library/msgs/it.msg10
-rw-r--r--library/msgs/ja.msg68
-rw-r--r--library/msgs/ko.msg86
-rw-r--r--library/msgs/ko_kr.msg4
-rw-r--r--library/msgs/kok.msg66
-rw-r--r--library/msgs/lt.msg20
-rw-r--r--library/msgs/lv.msg22
-rw-r--r--library/msgs/mk.msg80
-rw-r--r--library/msgs/mr.msg62
-rw-r--r--library/msgs/mt.msg8
-rw-r--r--library/msgs/nb.msg8
-rw-r--r--library/msgs/nn.msg4
-rw-r--r--library/msgs/pl.msg22
-rw-r--r--library/msgs/pt.msg8
-rw-r--r--library/msgs/ro.msg8
-rw-r--r--library/msgs/ru.msg80
-rw-r--r--library/msgs/sh.msg4
-rw-r--r--library/msgs/sk.msg26
-rw-r--r--library/msgs/sl.msg6
-rw-r--r--library/msgs/sq.msg16
-rw-r--r--library/msgs/sr.msg80
-rw-r--r--library/msgs/sv.msg12
-rw-r--r--library/msgs/ta.msg66
-rw-r--r--library/msgs/te.msg76
-rw-r--r--library/msgs/te_in.msg4
-rw-r--r--library/msgs/th.msg84
-rw-r--r--library/msgs/tr.msg24
-rw-r--r--library/msgs/uk.msg80
-rw-r--r--library/msgs/vi.msg38
-rw-r--r--library/msgs/zh.msg92
-rw-r--r--library/msgs/zh_cn.msg2
-rw-r--r--library/msgs/zh_hk.msg42
-rw-r--r--library/msgs/zh_sg.msg4
-rw-r--r--library/msgs/zh_tw.msg4
-rw-r--r--library/package.tcl25
-rw-r--r--library/parray.tcl4
-rw-r--r--library/readfile.tcl23
-rw-r--r--library/reg/pkgIndex.tcl9
-rw-r--r--library/registry/pkgIndex.tcl9
-rw-r--r--library/safe.tcl415
-rw-r--r--library/tclIndex139
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl59
-rw-r--r--library/tm.tcl6
-rw-r--r--library/word.tcl28
-rw-r--r--library/writefile.tcl37
-rw-r--r--libtommath/bn_deprecated.c4
-rw-r--r--libtommath/bn_mp_expt_u32.c2
-rw-r--r--libtommath/bn_mp_log_u32.c10
-rw-r--r--libtommath/bn_mp_radix_smap.c2
-rw-r--r--libtommath/bn_mp_root_u32.c4
-rw-r--r--libtommath/bn_mp_to_ubin.c3
-rw-r--r--libtommath/demo/shared.c42
-rw-r--r--libtommath/demo/shared.h21
-rw-r--r--libtommath/demo/test.c2522
-rwxr-xr-xlibtommath/testme.sh394
-rw-r--r--libtommath/tommath.def11
-rw-r--r--libtommath/tommath.h60
-rw-r--r--libtommath/tommath_private.h28
-rwxr-xr-xlibtommath/win32/libtommath.dllbin0 -> 72704 bytes
-rw-r--r--libtommath/win32/tommath.libbin0 -> 29796 bytes
-rwxr-xr-xlibtommath/win64-arm/libtommath.dllbin0 -> 69120 bytes
-rw-r--r--libtommath/win64-arm/libtommath.dll.abin0 -> 22478 bytes
-rw-r--r--libtommath/win64-arm/tommath.libbin0 -> 28856 bytes
-rwxr-xr-xlibtommath/win64/libtommath.dllbin0 -> 81408 bytes
-rw-r--r--libtommath/win64/libtommath.dll.abin0 -> 22478 bytes
-rw-r--r--libtommath/win64/tommath.libbin0 -> 29044 bytes
-rw-r--r--macosx/GNUmakefile4
-rw-r--r--macosx/README24
-rw-r--r--macosx/Tcl-Common.xcconfig6
-rw-r--r--macosx/Tcl.xcode/default.pbxuser200
-rw-r--r--macosx/Tcl.xcode/project.pbxproj2922
-rw-r--r--macosx/Tcl.xcodeproj/project.pbxproj208
-rw-r--r--macosx/configure.ac2
-rw-r--r--macosx/tclMacOSXBundle.c9
-rw-r--r--macosx/tclMacOSXFCmd.c80
-rw-r--r--macosx/tclMacOSXNotify.c524
-rw-r--r--tests-perf/clock.perf.tcl2
-rw-r--r--tests-perf/comparePerf.tcl371
-rw-r--r--tests-perf/listPerf.tcl1295
-rw-r--r--tests-perf/test-performance.tcl4
-rw-r--r--tests-perf/timer-event.perf.tcl2
-rw-r--r--tests/aaa_exit.test6
-rw-r--r--tests/all.tcl8
-rw-r--r--tests/append.test39
-rw-r--r--tests/appendComp.test6
-rw-r--r--tests/apply.test10
-rw-r--r--tests/assemble.test17
-rw-r--r--tests/assocd.test14
-rw-r--r--tests/async.test18
-rw-r--r--tests/auto-files.zipbin0 -> 4447 bytes
-rw-r--r--tests/autoMkindex.test14
-rw-r--r--tests/basic.test20
-rw-r--r--tests/binary.test658
-rw-r--r--tests/case.test11
-rw-r--r--tests/chan.test10
-rw-r--r--tests/chanio.test252
-rw-r--r--tests/clock.test36
-rw-r--r--tests/cmdAH.test622
-rw-r--r--tests/cmdIL.test112
-rw-r--r--tests/cmdInfo.test8
-rw-r--r--tests/cmdMZ.test49
-rw-r--r--tests/compExpr-old.test87
-rw-r--r--tests/compExpr.test54
-rw-r--r--tests/compile.test28
-rw-r--r--tests/concat.test6
-rw-r--r--tests/config.test10
-rw-r--r--tests/coroutine.test228
-rw-r--r--tests/dcall.test8
-rw-r--r--tests/dict.test119
-rw-r--r--tests/dstring.test56
-rw-r--r--tests/encoding.test671
-rw-r--r--tests/encodingVectors.tcl655
-rw-r--r--tests/env.test6
-rw-r--r--tests/error.test6
-rw-r--r--tests/eval.test6
-rw-r--r--tests/event.test21
-rw-r--r--tests/exec.test16
-rw-r--r--tests/execute.test50
-rw-r--r--tests/expr-old.test157
-rw-r--r--tests/expr.test402
-rw-r--r--tests/fCmd.test329
-rw-r--r--tests/fileName.test108
-rw-r--r--tests/fileSystem.test50
-rw-r--r--tests/fileSystemEncoding.test4
-rw-r--r--tests/for-old.test4
-rw-r--r--tests/for.test2
-rw-r--r--tests/foreach.test4
-rw-r--r--tests/format.test103
-rw-r--r--tests/get.test48
-rw-r--r--tests/history.test6
-rw-r--r--tests/http.test724
-rw-r--r--tests/http11.test263
-rw-r--r--tests/httpPipeline.test30
-rw-r--r--tests/httpProxy.test1146
-rw-r--r--tests/httpProxySquidConfigForEL8.tar.gzbin0 -> 2266 bytes
-rw-r--r--tests/httpTest.tcl8
-rw-r--r--tests/httpTestScript.tcl2
-rw-r--r--tests/httpcookie.test875
-rw-r--r--tests/httpd11
-rw-r--r--tests/httpd11.tcl41
-rw-r--r--tests/httpold.test306
-rw-r--r--tests/icuUcmTests.tcl1891
-rw-r--r--tests/if-old.test6
-rw-r--r--tests/if.test4
-rw-r--r--tests/incr-old.test8
-rw-r--r--tests/incr.test16
-rw-r--r--tests/indexObj.test65
-rw-r--r--tests/info.test206
-rw-r--r--tests/init.test8
-rw-r--r--tests/internals.tcl4
-rw-r--r--tests/interp.test26
-rw-r--r--tests/io.test1648
-rw-r--r--tests/ioCmd.test475
-rw-r--r--tests/ioTrans.test4
-rw-r--r--tests/iogt.test12
-rw-r--r--tests/join.test6
-rw-r--r--tests/lindex.test137
-rw-r--r--tests/link.test515
-rw-r--r--tests/linsert.test6
-rw-r--r--tests/list.test20
-rw-r--r--tests/listObj.test107
-rw-r--r--tests/listRep.test2538
-rw-r--r--tests/llength.test6
-rw-r--r--tests/lmap.test6
-rw-r--r--tests/load.test110
-rw-r--r--tests/lpop.test145
-rw-r--r--tests/lrange.test123
-rw-r--r--tests/lrepeat.test2
-rw-r--r--tests/lreplace.test342
-rw-r--r--tests/lsearch.test175
-rw-r--r--tests/lseq.test702
-rw-r--r--tests/lset.test44
-rw-r--r--tests/lsetComp.test6
-rw-r--r--tests/macOSXFCmd.test2
-rw-r--r--tests/macOSXLoad.test5
-rw-r--r--tests/main.test124
-rw-r--r--tests/mathop.test244
-rw-r--r--tests/misc.test8
-rw-r--r--tests/msgcat.test305
-rw-r--r--tests/namespace-old.test8
-rw-r--r--tests/namespace.test96
-rw-r--r--tests/notify.test4
-rw-r--r--tests/nre.test4
-rw-r--r--tests/obj.test109
-rw-r--r--tests/oo.test1457
-rw-r--r--tests/ooNext2.test4
-rw-r--r--tests/ooProp.test885
-rw-r--r--tests/ooUtil.test586
-rw-r--r--tests/opt.test6
-rw-r--r--tests/package.test181
-rw-r--r--tests/parse.test28
-rw-r--r--tests/parseExpr.test65
-rw-r--r--tests/parseOld.test21
-rw-r--r--tests/pid.test6
-rw-r--r--tests/pkgIndex.tcl2
-rw-r--r--tests/pkgMkIndex.test6
-rw-r--r--tests/platform.test18
-rw-r--r--tests/proc-old.test6
-rw-r--r--tests/proc.test45
-rw-r--r--tests/process.test341
-rw-r--r--tests/pwd.test6
-rw-r--r--tests/range.test0
-rw-r--r--tests/reg.test13
-rw-r--r--tests/regexp.test269
-rw-r--r--tests/regexpComp.test68
-rw-r--r--tests/registry.test13
-rw-r--r--tests/remote.tcl2
-rw-r--r--tests/rename.test8
-rw-r--r--tests/resolver.test6
-rw-r--r--tests/result.test14
-rw-r--r--tests/safe-stock.test391
-rw-r--r--tests/safe-zipfs.test837
-rw-r--r--tests/safe.test2063
-rw-r--r--tests/scan.test60
-rw-r--r--tests/security.test4
-rw-r--r--tests/set-old.test26
-rw-r--r--tests/set.test10
-rw-r--r--tests/socket.test1112
-rw-r--r--tests/source.test47
-rw-r--r--tests/split.test21
-rw-r--r--tests/stack.test2
-rw-r--r--tests/string.test734
-rw-r--r--tests/stringComp.test801
-rw-r--r--tests/stringObj.test184
-rw-r--r--tests/subst.test12
-rw-r--r--tests/switch.test6
-rw-r--r--tests/tailcall.test4
-rw-r--r--tests/tcltest.test6
-rw-r--r--tests/tcltests.tcl81
-rw-r--r--tests/thread.test12
-rw-r--r--tests/timer.test22
-rw-r--r--tests/tm.test5
-rw-r--r--tests/trace.test22
-rw-r--r--tests/unixFCmd.test26
-rw-r--r--tests/unixFile.test4
-rw-r--r--tests/unixForkEvent.test10
-rw-r--r--tests/unixInit.test18
-rw-r--r--tests/unixNotfy.test13
-rw-r--r--tests/unknown.test12
-rw-r--r--tests/unload.test64
-rw-r--r--tests/uplevel.test32
-rw-r--r--tests/upvar.test35
-rw-r--r--tests/utf.test693
-rw-r--r--tests/utfext.test90
-rw-r--r--tests/util.test1569
-rw-r--r--tests/var.test448
-rw-r--r--tests/while-old.test8
-rw-r--r--tests/while.test8
-rw-r--r--tests/winConsole.test345
-rw-r--r--tests/winDde.test111
-rw-r--r--tests/winFCmd.test126
-rw-r--r--tests/winFile.test32
-rw-r--r--tests/winNotify.test6
-rw-r--r--tests/winPipe.test40
-rw-r--r--tests/winTime.test6
-rw-r--r--tests/zipfiles/LICENSE-libzip31
-rw-r--r--tests/zipfiles/README7
-rw-r--r--tests/zipfiles/broken.zipbin0 -> 75091 bytes
-rw-r--r--tests/zipfiles/empty.zipbin0 -> 528 bytes
-rw-r--r--tests/zipfiles/incons-cdoffset.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/incons-central-crc.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/incons-central-magic-bad.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/incons-file-count-high.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/incons-file-count-low.zipbin0 -> 304 bytes
-rw-r--r--tests/zipfiles/incons-local-crc.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/incons-local-magic-bad.zipbin0 -> 153 bytes
-rw-r--r--tests/zipfiles/junk-at-end.zipbin0 -> 416 bytes
-rw-r--r--tests/zipfiles/junk-at-start.zipbin0 -> 416 bytes
-rw-r--r--tests/zipfiles/streamed.zipbin0 -> 120 bytes
-rw-r--r--tests/zipfiles/test-overlay.zipbin0 -> 498 bytes
-rw-r--r--tests/zipfiles/test-password.zipbin0 -> 956 bytes
-rw-r--r--tests/zipfiles/test-password2.zipbin0 -> 478 bytes
-rw-r--r--tests/zipfiles/test-paths.zipbin0 -> 671 bytes
-rw-r--r--tests/zipfiles/test-zip-in-zip.zipbin0 -> 665 bytes
-rw-r--r--tests/zipfiles/test.zipbin0 -> 412 bytes
-rw-r--r--tests/zipfiles/testbzip2.zipbin0 -> 175 bytes
-rw-r--r--tests/zipfiles/testdeflated2.zipbin0 -> 270 bytes
-rw-r--r--tests/zipfiles/testfile-UTF8.zipbin0 -> 126 bytes
-rw-r--r--tests/zipfiles/testfile-cp437.zipbin0 -> 130 bytes
-rw-r--r--tests/zipfiles/testfile-lzma.zipbin0 -> 161 bytes
-rw-r--r--tests/zipfiles/testfile-nocompression.zipbin0 -> 122 bytes
-rw-r--r--tests/zipfiles/testfile-xz.zipbin0 -> 200 bytes
-rw-r--r--tests/zipfiles/testfile-zstd.zipbin0 -> 160 bytes
-rw-r--r--tests/zipfiles/teststored.zipbin0 -> 188 bytes
-rw-r--r--tests/zipfiles/zip64.zipbin0 -> 198 bytes
-rw-r--r--tests/zipfs.test1943
-rw-r--r--tests/zlib.test16
-rw-r--r--tools/Makefile.in67
-rwxr-xr-xtools/addVerToFile.tcl9
-rw-r--r--tools/checkLibraryDoc.tcl4
-rwxr-xr-xtools/configure2172
-rw-r--r--tools/configure.in37
-rw-r--r--tools/encoding/Makefile5
-rw-r--r--tools/encoding/txt2enc.c8
-rw-r--r--tools/eolFix.tcl78
-rwxr-xr-xtools/findBadExternals.tcl2
-rwxr-xr-xtools/fix_tommath_h.tcl102
-rw-r--r--tools/genStubs.tcl6
-rw-r--r--tools/index.tcl2
-rw-r--r--tools/installData.tcl2
-rw-r--r--tools/installVfs.tcl54
-rwxr-xr-xtools/loadICU.tcl5
-rw-r--r--tools/makeHeader.tcl182
-rw-r--r--tools/man2help.tcl141
-rw-r--r--tools/man2help2.tcl1033
-rw-r--r--tools/man2html.tcl185
-rw-r--r--tools/man2html1.tcl258
-rw-r--r--tools/man2html2.tcl927
-rw-r--r--tools/man2tcl.c424
-rw-r--r--tools/mkVfs.tcl99
-rw-r--r--tools/mkdepend.tcl2
-rw-r--r--tools/regexpTestLib.tcl8
-rw-r--r--tools/str2c59
-rw-r--r--tools/tcl.hpj.in19
-rw-r--r--tools/tclOOScript.tcl798
-rwxr-xr-xtools/tclZIC.tcl6
-rw-r--r--tools/tcltk-man2html-utils.tcl264
-rwxr-xr-xtools/tcltk-man2html.tcl136
-rw-r--r--tools/tsdPerf.c10
-rw-r--r--tools/ucm2tests.tcl352
-rw-r--r--tools/uniParse.tcl4
-rw-r--r--tools/valgrind_check_success30
-rw-r--r--unix/Makefile.in532
-rw-r--r--unix/README4
-rwxr-xr-xunix/configure21927
-rw-r--r--unix/configure.ac (renamed from unix/configure.in)284
-rw-r--r--unix/dltest/Makefile.in13
-rw-r--r--unix/dltest/pkga.c6
-rw-r--r--unix/dltest/pkgb.c28
-rw-r--r--unix/dltest/pkgc.c6
-rw-r--r--unix/dltest/pkgd.c6
-rw-r--r--unix/dltest/pkge.c2
-rw-r--r--unix/dltest/pkgooa.c4
-rw-r--r--unix/dltest/pkgt.c116
-rw-r--r--unix/dltest/pkgua.c11
-rwxr-xr-xunix/installManPage43
-rw-r--r--unix/tcl.m4571
-rw-r--r--unix/tcl.pc.in4
-rw-r--r--unix/tcl.spec2
-rw-r--r--unix/tclAppInit.c21
-rw-r--r--unix/tclConfig.h.in128
-rw-r--r--unix/tclConfig.sh.in11
-rw-r--r--unix/tclEpollNotfy.c844
-rw-r--r--unix/tclKqueueNotfy.c840
-rw-r--r--unix/tclLoadAix.c4
-rw-r--r--unix/tclLoadDl.c76
-rw-r--r--unix/tclLoadDyld.c88
-rw-r--r--unix/tclLoadNext.c40
-rw-r--r--unix/tclLoadOSF.c42
-rw-r--r--unix/tclLoadShl.c40
-rw-r--r--unix/tclSelectNotfy.c1233
-rw-r--r--unix/tclUnixChan.c900
-rw-r--r--unix/tclUnixCompat.c29
-rw-r--r--unix/tclUnixEvent.c4
-rw-r--r--unix/tclUnixFCmd.c397
-rw-r--r--unix/tclUnixFile.c107
-rw-r--r--unix/tclUnixInit.c80
-rw-r--r--unix/tclUnixNotfy.c1506
-rw-r--r--unix/tclUnixPipe.c62
-rw-r--r--unix/tclUnixPort.h66
-rw-r--r--unix/tclUnixSock.c330
-rw-r--r--unix/tclUnixTest.c348
-rw-r--r--unix/tclUnixThrd.c291
-rw-r--r--unix/tclUnixThrd.h19
-rw-r--r--unix/tclUnixTime.c83
-rw-r--r--unix/tclXtNotify.c29
-rw-r--r--unix/tclXtTest.c6
-rw-r--r--unix/tclooConfig.sh2
-rw-r--r--win/Makefile.in327
-rw-r--r--win/README16
-rwxr-xr-x[-rw-r--r--]win/buildall.vc.bat8
-rw-r--r--win/coffbase.txt43
-rwxr-xr-xwin/configure8195
-rw-r--r--win/configure.ac (renamed from win/configure.in)132
-rw-r--r--win/makefile.vc343
-rw-r--r--win/rules.vc42
-rw-r--r--win/tcl.dsp98
-rw-r--r--win/tcl.hpj.in19
-rw-r--r--win/tcl.m4347
-rw-r--r--win/tcl.rc8
-rw-r--r--win/tclAppInit.c39
-rw-r--r--win/tclConfig.sh.in18
-rw-r--r--win/tclWin32Dll.c184
-rw-r--r--win/tclWinChan.c466
-rw-r--r--win/tclWinConsole.c2450
-rw-r--r--win/tclWinDde.c147
-rw-r--r--win/tclWinError.c17
-rw-r--r--win/tclWinFCmd.c256
-rw-r--r--win/tclWinFile.c208
-rw-r--r--win/tclWinInit.c75
-rw-r--r--win/tclWinInt.h47
-rw-r--r--win/tclWinLoad.c75
-rw-r--r--win/tclWinNotify.c501
-rw-r--r--win/tclWinPanic.c88
-rw-r--r--win/tclWinPipe.c241
-rw-r--r--win/tclWinPort.h64
-rw-r--r--win/tclWinReg.c140
-rw-r--r--win/tclWinSerial.c228
-rw-r--r--win/tclWinSock.c535
-rw-r--r--win/tclWinTest.c47
-rw-r--r--win/tclWinThrd.c112
-rw-r--r--win/tclWinTime.c553
-rw-r--r--win/tclooConfig.sh2
-rw-r--r--win/tclsh.exe.manifest.in6
-rw-r--r--win/tclsh.rc8
-rwxr-xr-xwin/x86_64-w64-mingw32-nmakehlp.exebin25600 -> 25088 bytes
831 files changed, 116066 insertions, 117346 deletions
diff --git a/.fossil-settings/crlf-glob b/.fossil-settings/crlf-glob
index 11ecd11..6aa950b 100644
--- a/.fossil-settings/crlf-glob
+++ b/.fossil-settings/crlf-glob
@@ -11,7 +11,6 @@ compat/zlib/zlib.map
libtommath/*.dsp
libtommath/*.sln
libtommath/*.vcproj
-tools/tcl.hpj.in
tools/tcl.wse.in
win/buildall.vc.bat
win/coffbase.txt
@@ -21,4 +20,3 @@ win/rules-ext.vc
win/targets.vc
win/tcl.dsp
win/tcl.dsw
-win/tcl.hpj.in
diff --git a/.fossil-settings/encoding-glob b/.fossil-settings/encoding-glob
index 8582dd4..28ce243 100644
--- a/.fossil-settings/encoding-glob
+++ b/.fossil-settings/encoding-glob
@@ -1,9 +1,7 @@
-tools/tcl.hpj.in
tools/tcl.wse.in
win/buildall.vc.bat
win/coffbase.txt
win/makefile.vc
win/rules.vc
win/tcl.dsp
-win/tcl.dsw
-win/tcl.hpj.in \ No newline at end of file
+win/tcl.dsw \ No newline at end of file
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml
index f881b47..41b41d0 100644
--- a/.github/workflows/linux-build.yml
+++ b/.github/workflows/linux-build.yml
@@ -16,13 +16,12 @@ jobs:
matrix:
cfgopt:
- ""
+ - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
- "CFLAGS=-ftrapv"
- - "CFLAGS=-DTCL_UTF_MAX=4"
- - "CFLAGS=-DTCL_UTF_MAX=6"
# Duplicated below
- "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit"
defaults:
@@ -39,7 +38,7 @@ jobs:
sudo apt install gcc-multilib libc6-dev-i386
- name: Prepare
run: |
- touch tclStubInit.c tclOOStubInit.c
+ touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml
index 1645bc7..7119f34 100644
--- a/.github/workflows/mac-build.yml
+++ b/.github/workflows/mac-build.yml
@@ -21,10 +21,12 @@ jobs:
uses: actions/checkout@v4
- name: Prepare
run: |
- touch tclStubInit.c tclOOStubInit.c
+ touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make all
+ env:
+ CFLAGS: -arch x86_64 -arch arm64
- name: Run Tests
run: make test styles=develop
env:
@@ -49,17 +51,20 @@ jobs:
uses: actions/checkout@v4
- name: Prepare
run: |
- touch tclStubInit.c tclOOStubInit.c
+ 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
- run: ./configure --enable-64bit --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1)
+ run: ./configure --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1)
env:
+ CFLAGS: -arch x86_64 -arch arm64
CFGOPT: ${{ matrix.cfgopt }}
- name: Build
run: |
make all tcltest
+ env:
+ CFLAGS: -arch x86_64 -arch arm64
- name: Run Tests
run: |
make test
diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml
new file mode 100644
index 0000000..a9f02c9
--- /dev/null
+++ b/.github/workflows/onefiledist.yml
@@ -0,0 +1,152 @@
+name: Build Binaries
+on:
+ push:
+ branches:
+ - "main"
+ - "core-8-branch"
+ tags:
+ - "core-**"
+permissions:
+ contents: read
+jobs:
+ linux:
+ name: Linux
+ runs-on: ubuntu-20.04
+ defaults:
+ run:
+ shell: bash
+ steps:
+ - name: Checkout
+ uses: actions/checkout@v4
+ - 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
+ run: ./configure --disable-symbols --disable-shared --enable-zipfs
+ working-directory: unix
+ - name: Build
+ run: |
+ make tclsh
+ make shell SCRIPT="$VER_PATH $GITHUB_ENV"
+ echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
+ working-directory: unix
+ - 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@v4
+ - name: Checkout create-dmg
+ uses: actions/checkout@v4
+ with:
+ repository: create-dmg/create-dmg
+ ref: v1.0.8
+ path: create-dmg
+ - name: Prepare
+ run: |
+ mkdir 1dist
+ touch generic/tclStubInit.c generic/tclOOStubInit.c || true
+ wget https://github.com/culler/macher/releases/download/v1.3/macher
+ sudo cp macher /usr/local/bin
+ sudo chmod a+x /usr/local/bin/macher
+ echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV
+ echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV
+ echo "CFLAGS=-arch x86_64 -arch arm64" >> $GITHUB_ENV
+ - name: Configure
+ run: ./configure --disable-symbols --disable-shared --enable-zipfs
+ working-directory: unix
+ - name: Build
+ run: |
+ make tclsh
+ make shell SCRIPT="$VER_PATH $GITHUB_ENV"
+ echo "TCL_BIN=`pwd`/tclsh" >> $GITHUB_ENV
+ echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
+ working-directory: unix
+ - name: Package
+ run: |
+ mkdir contents
+ cp $TCL_BIN contents/tclsh${TCL_PATCHLEVEL}_snapshot
+ chmod +x contents/tclsh${TCL_PATCHLEVEL}_snapshot
+ cat > contents/README.txt <<EOF
+ This is a single-file executable developer preview of Tcl $TCL_PATCHLEVEL
+
+ It is not intended as an official release at all, so it is unsigned and unnotarized.
+ Use strictly at your own risk.
+
+ To run it, you need to copy the executable out and run:
+ xattr -d com.apple.quarantine tclsh${TCL_PATCHLEVEL}_snapshot
+ to mark the executable as runnable on your machine.
+ EOF
+ $CREATE_DMG \
+ --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@v4
+ - 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
+ run: ./configure $CFGOPT
+ working-directory: win
+ - name: Build
+ run: |
+ make binaries libraries
+ echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
+ working-directory: win
+ - name: Get Exact Version
+ run: |
+ ./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'
diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml
index 29ea421..2b772f9 100644
--- a/.github/workflows/win-build.yml
+++ b/.github/workflows/win-build.yml
@@ -22,7 +22,8 @@ jobs:
matrix:
cfgopt:
- ""
- - "OPTS=static,msvcrt"
+ - "CHECKS=nodep"
+ - "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
@@ -59,6 +60,7 @@ jobs:
matrix:
cfgopt:
- ""
+ - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
@@ -74,7 +76,7 @@ jobs:
uses: actions/checkout@v4
- name: Prepare
run: |
- touch tclStubInit.c tclOOStubInit.c
+ touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "${HOME}/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
@@ -88,3 +90,6 @@ jobs:
run: make tcltest
- name: Run Tests
run: make test
+
+# If you add builds with Wine, be sure to define the environment variable
+# CI_USING_WINE when running them so that broken tests know not to run.
diff --git a/.project b/.project
index 358cc74..eddd834 100644
--- a/.project
+++ b/.project
@@ -1,6 +1,6 @@
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
- <name>tcl8.6</name>
+ <name>tcl8</name>
<comment></comment>
<projects>
</projects>
diff --git a/.travis.yml b/.travis.yml
index 061fe2d..b63be12 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -20,20 +20,13 @@ jobs:
compiler: gcc
env:
- BUILD_DIR=unix
- - name: "Linux/GCC/Shared: UTF_MAX=4"
+ - name: "Linux/GCC/Shared: NO_DEPRECATED"
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- - CFGOPT=CFLAGS=-DTCL_UTF_MAX=4
- - name: "Linux/GCC/Shared: UTF_MAX=6"
- os: linux
- dist: focal
- compiler: gcc
- env:
- - BUILD_DIR=unix
- - CFGOPT=CFLAGS=-DTCL_UTF_MAX=6
+ - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: focal
@@ -83,6 +76,13 @@ jobs:
compiler: clang
env:
- BUILD_DIR=unix
+ - name: "Linux/Clang/Shared:NO_DEPRECATED"
+ os: linux
+ dist: xenial
+ compiler: clang
+ env:
+ - BUILD_DIR=unix
+ - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/Clang/Static"
os: linux
dist: focal
@@ -105,7 +105,7 @@ jobs:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- - name: "macOS/Xcode 12/Shared"
+ - name: "macOS/Clang/Xcode 12/Shared"
os: osx
osx_image: xcode12.2
env:
@@ -115,14 +115,25 @@ jobs:
- make all
# The styles=develop avoids some weird problems on OSX
- make test styles=develop
- - name: "macOS/Xcode 12/Shared/Unix-like"
+ - name: "macOS/Clang/Xcode 12/Shared/Unix-like"
os: osx
osx_image: xcode12.2
env:
- BUILD_DIR=unix
- CFGOPT="--enable-dtrace"
+ - name: "macOS/Clang/Xcode 12/Shared/libtommath"
+ os: osx
+ osx_image: xcode12.2
+ env:
+ - BUILD_DIR=macosx
+ install: []
+ script: *mactest
+ addons:
+ homebrew:
+ packages:
+ - libtommath
# Newer MacOS versions
- - name: "macOS/Xcode 12/Universal Apps/Shared"
+ - name: "macOS/Clang/Xcode 12/Universal Apps/Shared"
os: osx
osx_image: xcode12u
env:
@@ -130,28 +141,28 @@ jobs:
install: []
script: *mactest
# Older MacOS versions
- - name: "macOS/Xcode 11/Shared"
+ - name: "macOS/Clang/Xcode 11/Shared"
os: osx
osx_image: xcode11.7
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- - name: "macOS/Xcode 10/Shared"
+ - name: "macOS/Clang/Xcode 10/Shared"
os: osx
osx_image: xcode10.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- - name: "macOS/Xcode 9/Shared"
+ - name: "macOS/Clang/Xcode 9/Shared"
os: osx
osx_image: xcode9.4
env:
- BUILD_DIR=macosx
install: []
script: *mactest
- - name: "macOS/Xcode 8/Shared"
+ - name: "macOS/Clang/Xcode 8/Shared"
os: osx
osx_image: xcode8.3
env:
@@ -190,31 +201,31 @@ jobs:
- BUILD_DIR=win
- VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build"
before_install: &vcpreinst
- - touch generic/tclStubInit.c generic/tclOOStubInit.c
+ - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- PATH="$PATH:$VCDIR"
- cd ${BUILD_DIR}
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake '-f' makefile.vc test
- - name: "Windows/MSVC/Static"
+ - name: "Windows/MSVC/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest
- - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test
- - name: "Windows/MSVC/StaticPackage"
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc test
+ - name: "Windows/MSVC/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc all tcltest
- - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,staticpkg,msvcrt' '-f' makefile.vc test
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static' '-f' makefile.vc test
- name: "Windows/MSVC/Debug"
os: windows
compiler: cl
@@ -243,6 +254,15 @@ jobs:
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc test
+ - name: "Windows/MSVC-x86/Shared: NO_DEPRECATED"
+ os: windows
+ compiler: cl
+ env: *vcenv
+ before_install: *vcpreinst
+ install: []
+ script:
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'CHECKS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Static"
os: windows
compiler: cl
@@ -250,8 +270,8 @@ jobs:
before_install: *vcpreinst
install: []
script:
- - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest
- - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static' '-f' makefile.vc all tcltest
+ - cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Debug"
os: windows
compiler: cl
@@ -278,15 +298,15 @@ jobs:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- - touch generic/tclStubInit.c generic/tclOOStubInit.c
- - choco install -y make
+ - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
+ - choco install -y make zip
- cd ${BUILD_DIR}
- - name: "Windows/GCC/Shared: UTF_MAX=4"
+ - name: "Windows/GCC/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- - CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=4"
+ - CFGOPT="--enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/GCC/Static"
os: windows
@@ -316,12 +336,12 @@ jobs:
env:
- BUILD_DIR=win
before_install: *makepreinst
- - name: "Windows/GCC-x86/Shared: UTF_MAX=4"
+ - name: "Windows/GCC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- - CFGOPT="CFLAGS=-DTCL_UTF_MAX=4"
+ - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/GCC-x86/Static"
os: windows
@@ -354,7 +374,7 @@ jobs:
script:
- make dist
before_install:
- - touch generic/tclStubInit.c generic/tclOOStubInit.c
+ - touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- cd ${BUILD_DIR}
install:
- mkdir "$HOME/install dir"
diff --git a/ChangeLog b/ChangeLog
deleted file mode 100644
index b189086..0000000
--- a/ChangeLog
+++ /dev/null
@@ -1,8856 +0,0 @@
-A NOTE ON THE CHANGELOG:
-Starting in early 2011, Tcl source code has been under the management of
-fossil, hosted at https://core.tcl-lang.org/tcl/ . Fossil presents a "Timeline"
-view of changes made that is superior in every way to a hand edited log file.
-Because of this, many Tcl developers are now out of the habit of maintaining
-this log file. You may still find useful things in it, but the Timeline is
-a better first place to look now.
-============================================================================
-
-2013-09-19 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6.1 TAGGED FOR RELEASE ***
-
- * generic/tcl.h: Bump version number to 8.6.1.
- * library/init.tcl:
- * unix/configure.in:
- * win/configure.in:
- * unix/tcl.spec:
- * README:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2013-09-19 Donal Fellows <dkf@users.sf.net>
-
- * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected
- description of method search order.
-
-2013-09-18 Donal Fellows <dkf@users.sf.net>
-
- Bump TclOO version to 1.0.1 for release.
-
-2013-09-17 Donal Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]:
- Corrected implementation of the core of uuencode handling so that the
- line length processing is correctly applied.
- ***POTENTIAL INCOMPATIBILITY***
- Existing code that was using the old versions and working around the
- limitations will now need to do far less. The -maxlen option now has
- strict limits on the range of supported lengths; this is a limitation
- of the format itself.
-
-2013-09-09 Donal Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip
- the internal representation of method bodies during cloning in order
- to ensure that any bound references to instance variables are removed.
-
-2013-09-01 Donal Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that
- whitespace at the end of a string don't cause the decoder to drop the
- last decoded byte.
-
-2013-08-03 Donal Fellows <dkf@users.sf.net>
-
- * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found
- by the autoloading mechanism.
-
-2013-08-02 Donal Fellows <dkf@users.sf.net>
-
- * generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop
- crashes when emptying the superclass slot, even when doing elaborate
- things with metaclasses.
-
-2013-08-01 Harald Oehlmann <oehhar@users.sf.net>
-
- * tclUnixNotify.c (Tcl_InitNotifier): Bug [a0bc856dcd]: Start notifier
- thread again if we were forked, to solve Rivet bug 55153.
-
-2013-07-05 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/America/Asuncion:
- * library/tzdata/Antarctica/Macquarie:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Hebron:
- * library/tzdata/Asia/Jerusalem:
- http://www.iana.org/time-zones/repository/releases/tzdata2013d.tar.gz
-
-2013-07-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclXtNotify.c: Bug [817249]: bring tclXtNotify.c up to date with
- Tcl_SetNotifier() change.
-
-2013-07-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Bug [32afa6e256]: dirent64 check is incorrect in tcl.m4
- * unix/configure: (thanks to Brian Griffin)
-
-2013-06-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs
- * generic/tclMain.c: initialized encodings.
-
-2013-06-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread
- issue.
-
-2013-06-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/regc_locale.c: Bug [a876646efe]: re_expr character class
- [:cntrl:] should contain \u0000 - \u001f
-
-2013-06-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (TclCompileTryCmd): [Bug 779d38b996]:
- Rewrote the [try] compiler to generate better code in some cases and
- to behave correctly in others; when an error happens during the
- processing of an exception-trap clause or a finally clause, the
- *original* return options are now captured in a -during option, even
- when fully compiled.
-
-2013-06-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (INST_EXPAND_DROP): [Bugs 2835313, 3614226]:
- New opcode to allow resetting the stack to get rid of an expansion,
- restoring the stack to a known state in the process.
- * generic/tclCompile.c, generic/tclCompCmds.c: Adjusted the compilers
- for [break] and [continue] to get stack cleanup right in the majority
- of cases.
- * tests/for.test (for-7.*): Set of tests for these evil cases.
-
-2013-06-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Eliminate NO_VIZ macro as current zlib uses HAVE_HIDDEN
- instead. One more last-moment fix for FreeBSD by Pietro Cerutti
-
-2013-06-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: fix for perf bug detected by Kieran
- (https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ),
- diagnosed by dgp to be a close relative of [Bug 781585], which was
- fixed by commit [f46fb50cb3]. This bug was introduced by myself in
- commit [cbfe055d8c].
-
-2013-06-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileBreakCmd, TclCompileContinueCmd):
- Added code to allow [break] and [continue] to be issued as a jump (in
- the most common cases) rather than using the more expensive exception
- processing path in the bytecode engine. [Bug 3614226]: Partial fix for
- the issues relating to cleaning up the stack when dealing with [break]
- and [continue].
-
-2013-05-27 Harald Oehlmann <oehhar@users.sf.net>
-
- * library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from
- registry key HCU\Control Panel\Desktop : PreferredUILanguages to honor
- installed language packs on Vista+.
- Bumped msgcat version to 1.5.2
-
-2013-05-22 Andreas Kupries <andreask@activestate.com>
-
- * tclCompile.c: Removed duplicate const qualifier causing the HP
- native cc to error out.
-
-2013-05-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclUtf.c (TclUtfCasecmp): [Bug 3613609]: Replace problematic
- uses of strcasecmp with a proper UTF-8-aware version. Affects both
- [lsearch -nocase] and [lsort -nocase].
-
-2013-05-22 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/file.n: [Bug 3613671]: Added note to portability section on the
- fact that [file owned] does not produce useful results on Windows.
-
-2013-05-20 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixFCmd.c (DefaultTempDir): [Bug 3613567]: Corrected logic
- for checking return code of access() system call, which was inverted.
-
-2013-05-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Fix for FreeBSD, and remove support for older
- * unix/configure: FreeBSD versions. Patch by Pietro Cerutti.
-
-2013-05-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsGR.c: Split tclCompCmds.c again to keep size of
- code down.
-
-2013-05-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBasic.c: Add panic in order to detect incompatible
- mingw32 sys/stat.h and sys/time.h headers.
-
-2013-05-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/zlib/*: Upgrade to zlib 1.2.8
-
-2013-05-10 Donal K. Fellows <dkf@users.sf.net>
-
- Optimizations and general bytecode generation improvements.
- * generic/tclCompCmds.c (TclCompileAppendCmd, TclCompileLappendCmd):
- (TclCompileReturnCmd): Make these generate bytecode in more cases.
- (TclCompileListCmd): Make this able to push a literal when it can.
- * generic/tclCompile.c (TclSetByteCodeFromAny, PeepholeOptimize):
- Added checks to see if we can apply some simple cross-command-boundary
- optimizations, and defined a small number of such optimizations.
- (TclCompileScript): Added the special ability to compile the list
- command with expansion ([list {*}blah]) into bytecode that does not
- call an external command.
-
-2013-05-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit
- * generic/tclDecls.h: "long" type. Binary compatibility with win64
- requires that all stub entries use 32-bit long's, therefore the need
- for various wrapper functions/macros. For Tcl 9 a better solution is
- needed, but that cannot be done without introducing binary
- incompatibility.
-
-2013-04-30 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl (::platform::LibcVersion):
- * library/platform/pkgIndex.tcl: Followup to the 2013-01-30 change.
- The RE become too restrictive again. SuSe added a timestamp after the
- version. Loosened up a bit. Bumped package to version 1.0.12.
-
-2013-04-29 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileArraySetCmd): Generate better code
- when the list of things to set is a literal.
-
-2013-04-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj
- and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj
- and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it
- only eliminates code duplication.
- * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's
- exactly the same as TCL_WIDE_INT_IS_LONG
-
-2013-04-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: Implement many Tcl_*Var* functions and
- Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp their
- Tcl_*Var*2 equivalent and Tcl_GetIndexFromObjStruct.
-
-2013-04-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: Implement Tcl_Pkg* functions as
- (faster/stack-saving) macros around Tcl_Pkg*Ex functions.
-
-2013-04-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/regc_color.c: [Bug 3610026]: Stop crash when the number of
- * generic/regerrs.h: "colors" in a regular expression overflows a
- * generic/regex.h: short int. Thanks to Heikki Linnakangas for
- * generic/regguts.h: the report and the patch.
- * tests/regexp.test:
-
-2013-04-04 Reinhard Max <max@suse.de>
-
- * library/http/http.tcl (http::geturl): Allow URLs that don't have a
- path, but a query query, e.g. http://example.com?foo=bar
- * Bump the http package to 2.8.7.
-
-2013-03-22 Venkat Iyer <venkat@comit.com>
- * library/tzdata/Africa/Cairo: Update to tzdata2013b.
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/Africa/Gaborone:
- * library/tzdata/Africa/Tripoli:
- * library/tzdata/America/Asuncion:
- * library/tzdata/America/Barbados:
- * library/tzdata/America/Bogota:
- * library/tzdata/America/Costa_Rica:
- * library/tzdata/America/Curacao:
- * library/tzdata/America/Nassau:
- * library/tzdata/America/Port-au-Prince:
- * library/tzdata/America/Santiago:
- * library/tzdata/Antarctica/Palmer:
- * library/tzdata/Asia/Aden:
- * library/tzdata/Asia/Hong_Kong:
- * library/tzdata/Asia/Muscat:
- * library/tzdata/Asia/Rangoon:
- * library/tzdata/Asia/Shanghai:
- * library/tzdata/Atlantic/Bermuda:
- * library/tzdata/Europe/Vienna:
- * library/tzdata/Pacific/Easter:
- * library/tzdata/Pacific/Fiji:
- * library/tzdata/Asia/Khandyga: (new)
- * library/tzdata/Asia/Ust-Nera: (new)
- * library/tzdata/Europe/Busingen: (new)
-
-2013-03-21 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: [Bug 2102614]: Add ensemble indexing support to
- * tests/autoMkindex.test: [auto_mkindex]. Thanks Brian Griffin.
-
-2013-03-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFCmd.c: [Bug 3597000]: Consistent [file copy] result.
- * tests/fileSystem.test:
-
-2013-03-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: [Bug 3608360]: Incompatible behaviour of "file
- exists".
-
-2013-03-18 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/cmdAH.test (cmdAH-19.12): [Bug 3608360]: Added test to ensure
- that we never ever allow [file exists] to do globbing.
-
-2013-03-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Patch by Andrew Shadura, providing better support for
- three architectures they have in Debian.
-
-2013-03-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: [Bugs 3607246,3607372]: Unbalanced refcounts
- * generic/tclLiteral.c: of literals in the global literal table.
-
-2013-03-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/regc_nfa.c: [Bugs 3604074,3606683]: Rewrite of the
- * generic/regcomp.c: fixempties() routine (and supporting routines)
- to completely eliminate the infinite loop hazard. Thanks to Tom Lane
- for the much improved solution.
-
-2013-02-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclLiteral.c: Revise TclReleaseLiteral() to tolerate a NULL
- interp argument.
-
- * generic/tclCompile.c: Update callers and revise mistaken comments.
- * generic/tclProc.c:
-
-2013-02-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/regcomp.c: [Bug 3606139]: missing error check allows
- * tests/regexp.test: regexp to crash Tcl. Thanks to Tom Lane for
- providing the test-case and the patch.
-
-2013-02-26 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/chanio.test (chan-io-28.7): [Bug 3605120]: Stop test from
- hanging when run standalone.
-
-2013-02-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclObj.c: Don't panic if Tcl_ConvertToType is called for a
- type that doesn't have a setFromAnyProc, create a proper error message.
-
-2013-02-25 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/binary.test (binary-41.*): [Bug 3605721]: Test independence
- fixes. Thanks to Rolf Ade for pointing out the problem.
-
-2013-02-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/assocd.test: [Bugs 3605719,3605720]: Test independence.
- * tests/basic.test: Thanks Rolf Ade for patches.
-
-2013-02-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/fake-rfc2553.c: [Bug 3599194]: compat/fake-rfc2553.c is
- broken.
-
-2013-02-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclAssembly.c: Shift more burden of smart cleanup
- * generic/tclCompile.c: onto the TclFreeCompileEnv() routine.
- Stop crashes when the hookProc raises an error.
-
-2013-02-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c: [Bug 3605447]: Make sure the -clear option
- * tests/namespace.test: to [namespace export] always clears, whether
- or not new export patterns are specified.
-
-2013-02-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: [Bug 3605401]: Compiler error with latest mingw-w64
- headers.
-
-2013-02-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTrace.c: [Bug 2438181]: Incorrect error reporting in
- * tests/trace.test: traces. Test-case and fix provided by Poor
- Yorick.
-
-2013-02-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/regc_nfa.c: [Bug 3604074]: Fix regexp optimization to
- * tests/regexp.test: stop hanging on the expression
- ((((((((a)*)*)*)*)*)*)*)* . Thanks to Bjørn Grathwohl for discovery.
-
-2013-02-14 Harald Oehlmann <oehhar@users.sf.net>
-
- * library/msgcat/msgcat.tcl: [Bug 3604576]: Catch missing registry
- entry "HCU\Control Panel\International".
- Bumped msgcat version to 1.5.1
-
-2013-02-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibTransformOutput): [Bug 3603553]: Ensure that
- data gets written to the underlying stream by compressing transforms
- when the amount of data to be written is one buffer's-worth; problem
- was particularly likely to occur when compressing large quantities of
- not-very-compressible data. Many thanks to Piera Poggio (vampiera) for
- reporting.
-
-2013-02-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change
- the way that the 'varname' method is implemented so that there are no
- longer problems with interactions due to the resolver. Thanks to
- Taylor Venable <tcvena@gmail.com> for identifying the problem.
-
-2013-02-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/regc_nfa.c (duptraverse): [Bug 3603557]: Increase the
- maximum depth of recursion used when duplicating an automaton in
- response to encountering a "wild" RE that hit the previous limit.
- Allow the limit (DUPTRAVERSE_MAX_DEPTH) to be set by defining its
- value in the Makefile. Problem reported by Jonathan Mills.
-
-2013-02-05 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinFile.c: [Bug 3603434]: Make sure TclpObjNormalizePath()
- properly declares "a:/" to be normalized, even when no "A:" drive is
- present on the system.
-
-2013-02-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclLoadNone.c (TclpLoadMemory): [Bug 3433012]: Added dummy
- version of this function to use in the event that a platform thinks it
- can load from memory but cannot actually do so due to it being
- disabled at configuration time.
-
-2013-02-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileArraySetCmd): [Bug 3603163]: Stop
- crash in weird case where [eval] is used to make [array set] get
- confused about whether there is a local variable table or not. Thanks
- to Poor Yorick for identifying a reproducible crashing case.
-
-2013-01-30 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl (::platform::LibcVersion): See
- * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE
- * unix/Makefile.in: extracting the version to avoid issues with
- * win/Makefile.in: recent changes to the glibc banner. Now targeting a
- less variable part of the string. Bumped package to version 1.0.11.
-
-2013-01-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileArraySetCmd)
- (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd)
- (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd)
- (TclCompileDictLappendCmd, TclCompileDictMergeCmd)
- (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd)
- (TclCompileDictWithCmd, TclCompileInfoCommandsCmd):
- * generic/tclCompCmdsSZ.c (TclCompileStringMatchCmd)
- (TclCompileStringMapCmd): Improve the code generation in cases where
- full compilation is impossible but a full ensemble invoke is provably
- not necessary.
-
-2013-01-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation
- fault on Darwin.
-
-2013-01-23 Donal K. Fellows <dkf@users.sf.net>
-
- * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait
- for connect to avoid reentrancy problems (except when operating
- without a -command option). Internally, this means that all sockets
- created by the http package will always be operated in asynchronous
- mode.
-
-2013-01-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName)
- in private stub table, so extensions using this (like Tk 8.4) will
- continue to work in all Tcl 8.x versions. Extensions using this
- still cannot be compiled against Tcl 8.6 headers.
-
-2013-01-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include
- sys/stat.h
-
-2013-01-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (PushVarName): [Bug 3600328]: Added mechanism
- for suppressing compilation of variables when we couldn't cope with
- the results. Useful for some [array] subcommands.
- * generic/tclEnsemble.c (CompileToCompiledCommand): Must restore the
- compilation environment when a command compiler fails.
-
-2013-01-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (TclZlibInit): [Bug 3601086]: Register the config
- info in the iso8859-1 encoding as that is guaranteed to be present.
-
-2013-01-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * Makefile.in: Allow win32 build with -DTCL_NO_DEPRECATED, just as
- * generic/tcl.h: in the UNIX build. Define Tcl_EvalObj and
- * generic/tclDecls.h: Tcl_GlobalEvalObj as macros, even when
- * generic/tclBasic.c: TCL_NO_DEPRECATED is defined, so Tk can benefit
- from it too.
-
-2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tcl.m4: More flexible search for win32 tclConfig.sh, backported
- from TEA (not actually used in Tcl, only for Tk)
-
-2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Put back Tcl_[GS]etStartupScript in internal
- stub table, so extensions using this, compiled against 8.5 headers
- still run in Tcl 8.6.
-
-2013-01-13 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false
- positives" in the case of multibyte encodings/transforms.
-
-2013-01-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure
- that TIP #139 functions all are taken from the public stub table, even
- if the inclusion is through tclInt.h.
-
-2013-01-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Put back TclBackgroundException in internal
- stub table, so extensions using this, compiled against 8.5 headers
- still run in Tcl 8.6.
-
-2013-01-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/http/http.tcl: [Bug 3599395]: http assumes status line is a
- proper Tcl list.
-
-2013-01-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: [Bug 3092089]: [file normalize] can remove path
- components. [Bug 3587096]: win vista/7: "can't find init.tcl" when
- called via junction without folder list access.
-
-2013-01-07 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclOOStubLib.c: Restrict the stub library to only use
- * generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult and
- Tcl_AppendResult, not any other function. This puts least restrictions
- on eventual Tcl 9 stubs re-organization, and it works on the widest
- range of Tcl versions.
-
-2013-01-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/http/http.tcl: Don't depend on Spencer-specific regexp
- * tests/env.test: syntax (/u and /U) any more in unrelated places.
- * tests/exec.test:
- Bump http package to 2.8.6.
-
-2013-01-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple
- compiler (which just compiles to a normal invoke of the implementation
- command) for many ensemble subcommands where we can prove that there
- is no way for scripts to detect the difference even through error
- handling or [info level]/[info frame]. This improves the code produced
- from some ensembles (e.g., [info], [string]) to the point where the
- ensemble is now not normally seen at the bytecode level at all.
-
-2013-01-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h: Insure that PURIFY builds cannot exploit the
- * generic/tclExecute.c: Tcl stack to hide mem defects.
-
-2013-01-03 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/fconfigure.n, doc/CrtChannel.3: Updated to reflect the fact that
- the minimum buffer size is one byte, not ten. Identified by Schelte
- Bron on the Tcler's Chat.
-
- * generic/tclExecute.c (TEBCresume:INST_INVOKE_REPLACE):
- * generic/tclEnsemble.c (TclCompileEnsemble): Added new mechanism to
- allow for more efficient dispatch of non-bytecode-compiled subcommands
- of bytecode-compiled ensembles. This can provide substantial speed
- benefits in some cases.
-
-2013-01-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclEnsemble.c: Remove stray calls to Tcl_Alloc and friends:
- * generic/tclExecute.c: the core should only use ckalloc to allow
- * generic/tclIORTrans.c: MEM_DEBUG to work properly.
- * generic/tclTomMathInterface.c:
-
-2012-12-31 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/string.n: Noted the obsolescence of the 'bytelength',
- 'wordstart' and 'wordend' subcommands, and moved them to later in the
- file.
-
-2012-12-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclListObj.c: [Bug 3598580]: Tcl_ListObjReplace may release
- deleted elements too early.
-
-2012-12-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclUtil.c: [Bug 3598150]: Stop leaking allocated space when
- objifying a zero-length DString. Spotted by afredd.
-
-2012-12-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/dltest/pkgb.c: Inline compat Tcl_GetDefaultEncodingDir.
- * generic/tclStubLib.c: Eliminate unnecessary static HasStubSupport()
- and isDigit() functions, just do the same inline.
-
-2012-12-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (TclSubstCompile): Improved the sequence of
- instructions issued for [subst] when dealing with simple variable
- references.
-
-2012-12-14 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6.0 TAGGED FOR RELEASE ***
-
- * changes: updates for 8.6.0
-
-2012-12-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclZlib.c: Repair same issue with misusing the
- * tests/zlib.test: 'fire and forget' nature of Tcl_ObjSetVar2
- in the new TIP 400 implementation.
-
-2012-12-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdAH.c: (CatchObjCmdCallback): do not decrRefCount
- * tests/cmdAH.test: the newValuePtr sent to Tcl_ObjSetVar2:
- TOSV2 is 'fire and forget', it decrs on its own.
- Fix for [Bug 3595576], found by andrewsh.
-
-2012-12-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it doesn't
- access its objPtr parameter twice any more.
-
-2012-12-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump version number to 8.6.0.
- * library/init.tcl:
- * unix/configure.in:
- * win/configure.in:
- * unix/tcl.spec:
- * README:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2012-12-10 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (plus-pkgs): Increased robustness of
- version number detection code to deal with packages whose names are
- prefixes of other packages.
- * unix/Makefile.in (dist): Added pkgs/package.list.txt to distribution
- builds to ensure that 'make html' will work better.
-
-2012-12-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6
- leading to a spurious "'" at end of chan.test under certain conditions
- (see [Bug 3389289] and [Bug 3389251]).
-
- * doc/expr.n: [Bug 3594188]: Clarifications about commas.
-
-2012-12-08 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT
- when there are unflushed nonblocking channels. Thanks Miguel for
- spotting.
-
-2012-12-07 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test
- library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should
- either result in an error-message, either succeed, but never crash.
-
-2012-11-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism
- for complex option resolution that has fewer problems with more
- finicky compilers.
-
-2012-11-26 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c: Factor out creation of the -sockname and
- -peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it
- robust against implementations of getnameinfo() that error out if
- reverse mapping fails instead of falling back to the numeric
- representation.
-
-2012-11-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (BinaryDecode64): [Bug 3033307]: Corrected
- handling of trailing whitespace when decoding base64. Thanks to Anton
- Kovalenko for reporting, and Andy Goth for the fix and tests.
-
-2012-11-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (INST_STR_RANGE_IMM): [Bug 3588366]: Corrected
- implementation of bounds restriction for end-indexed compiled [string
- range]. Thanks to Emiliano Gavilan for diagnosis and fix.
-
-2012-11-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- IMPLEMENTATION OF TIP#416
-
- New Options for 'load': -global and -lazy
-
- * generic/tcl.h:
- * generic/tclLoad.c
- * unix/tclLoadDl.c
- * unix/tclLoadDyld.c
- * tests/load.test
- * doc/Load.3
- * doc/load.n
-
-2012-11-14 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixFCmd.c (TclUnixOpenTemporaryFile): [Bug 2933003]: Factor
- out all the code to do temporary file creation so that it is possible
- to make it correct in one place. Allow overriding of the back-stop
- default temporary file location at compile time by setting the
- TCL_TEMPORARY_FILE_DIRECTORY #def to a string containing the directory
- name (defaults to "/tmp" as that is the most common default).
-
-2012-11-13 Joe Mistachkin <joe@mistachkin.com>
-
- * win/tclWinInit.c: also search for the library directory (init.tcl,
- encodings, etc) relative to the build directory associated with the
- source checkout.
-
-2012-11-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: re-enable bcc-tailcall, after fixing an
- * generic/tclExecute.c: infinite loop in the TCL_COMPILE_DEBUG mode
-
-
-2012-11-07 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/America/Araguaina:
- * library/tzdata/America/Bahia:
- * library/tzdata/America/Havana:
- * library/tzdata/Asia/Amman:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Hebron:
- * library/tzdata/Asia/Jerusalem:
- * library/tzdata/Pacific/Apia:
- * library/tzdata/Pacific/Fakaofo:
- * library/tzdata/Pacific/Fiji: Import tzdata2012i.
-
-2012-11-06 Donal K. Fellows <dkf@users.sf.net>
-
- * library/http/http.tcl (http::Finish): [Bug 3581754]: Ensure that
- callbacks are done at most once to prevent problems with timeouts on a
- keep-alive connection (combined with reentrant http package use)
- causing excessive stack growth. Not a fix for the underlying problem,
- but ensures that pain will be mostly kept away from users.
- Bump http package to 2.8.5.
-
-2012-11-05 Donal K. Fellows <dkf@users.sf.net>
-
- Added bytecode compilation of many Tcl commands. Some of these are
- total compilations and some are only partial (i.e., only compile in
- some cases). The (sub-)commands affected are:
- * array: exists, set, unset
- * dict: create, exists, merge
- * format: (simple cases only)
- * info: commands, coroutine, level, object
- * info object: class, isa object, namespace
- * namespace: current, code, qualifiers, tail, which
- * regsub: (only cases convertable to simple [string map])
- * self: (only no-argument and [self object] cases)
- * string: first, last, map, range
- * tailcall:
- * yield:
-
- [This was work originally done on the 'dkf-compile-misc-info' branch.]
-
-2012-11-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- IMPLEMENTATION OF TIP#413
-
- Align the [string trim] and [string is space] commands, such that
- [string trim] by default trims all characters for which [string is
- space] returns 1, augmented with the NUL character.
-
- * generic/tclUtf.c: Add NEL, BOM and two more characters to [string is
- space]
- * generic/tclCmdMZ.c: Modify [string trim] for Unicode modifications.
- * generic/regc_locale.c: Regexp engine must match [string is space]
- * doc/string.n
- * tests/string.test
- ***POTENTIAL INCOMPATIBILITY***
- Code that relied on characters not previously trimmed being not
- removed will notice a difference; it is believed that this is rare,
- but a workaround to get the behavior in Tcl 8.5 is to use " \t\n\r" as
- an explicit trim set.
-
-2012-10-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: Dde version number to 1.4.0, ready for Tcl 8.6.0rc1
- * win/makefile.vc
- * win/tclWinDde.c
- * library/dde/pkgIndex.tcl
- * tests/winDde.test
-
-2012-10-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictUnsetCmd): Added compilation of
- the [dict unset] command (for scalar var in LVT only).
-
-2012-10-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Add "flags" parameter from Tcl_LoadFile to
- * generic/tclIOUtil.c: to various internal functions, so these
- * generic/tclLoadNone.c: flags are available through the whole
- * unix/tclLoad*.c: filesystem for (future) internal use.
- * win/tclWinLoad.c:
-
-2012-10-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclNRCoroutineObjCmd): insure that numlevels
- are properly set, fix bug discovered by dkf and reported at
- http://code.activestate.com/lists/tcl-core/12213/
-
-2012-10-16 Donal K. Fellows <dkf@users.sf.net>
-
- IMPLEMENTATION OF TIP#405
-
- New commands for applying a transformation to the elements of a list
- to produce another list (the [lmap] command) and to the mappings of a
- dictionary to produce another dictionary (the [dict map] command). In
- both cases, a [continue] will cause the skipping of an element/pair,
- and a [break] will terminate the construction early and successfully.
-
- * generic/tclCmdAH.c (Tcl_LmapObjCmd, TclNRLmapCmd): Implementation of
- the new [lmap] command, based on (and sharing much of) [foreach].
- * generic/tclDictObj.c (DictMapNRCmd): Implementation of the new [dict
- map] subcommand, based on (and sharing much of) [dict for].
- * generic/tclCompCmds.c (TclCompileLmapCmd, TclCompileDictMapCmd):
- Compilation engines for [lmap] and [dict map].
-
- IMPLEMENTATION OF TIP#400
-
- * generic/tclZlib.c: Allow the specification of a compression
- dictionary (a binary blob used to seed the compression engine) in both
- streams and channel transformations. Also some reorganization to allow
- for getting gzip header dictionaries and controlling buffering levels
- in channel transformations (allowing a trade-off between formal
- correctness and speed).
- (Tcl_ZlibStreamSetCompressionDictionary): New C API to allow setting
- the compression dictionary without using a Tcl script.
-
-2012-10-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDictObj.c: [Bug 3576509]: ::tcl::Bgerror crashes with
- * generic/tclEvent.c: invalid arguments. Better fix, which helps
- for all Tcl_DictObjGet() calls in Tcl's source code.
-
-2012-10-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclEvent.c: [Bug 3576509]: tcl::Bgerror crashes with invalid
- arguments
-
-2012-10-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: [Bug 2459774]: tcl/win/Makefile.in not compatible
- with msys 0.8.
-
-2012-10-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIO.c: When checking for std channels being closed,
- compare the channel state, not the channel itself so that stacked
- channels do not cause trouble.
-
-2012-09-26 Reinhard Max <max@suse.de>
-
- * generic/tclIOSock.c (TclCreateSocketAddress): Work around a bug in
- getaddrinfo() on OSX that caused name resolution to fail for [socket
- -server foo -myaddr localhost 0].
-
-2012-09-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/configure.in: New import libraries for zlib 1.2.7, usable for
- * win/configure: all win32/win64 compilers
- * compat/zlib/win32/zdll.lib:
- * compat/zlib/win64/zdll.lib:
-
- * win/tclWinDde.c: [FRQ 3527238]: Full unicode support for dde. Dde
- version is now 1.4.0b2.
- ***POTENTIAL INCOMPATIBILITY***
-
-2012-09-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Make Tcl_Interp a fully opaque structure if
- TCL_NO_DEPRECATED is set (TIP 330 and 336).
- * win/nmakehlp.c: Let "nmakehlp -V" start searching digits after the
- found match (suggested by Harald Oehlmann).
-
-2012-09-19 Harald Oehlmann <oehhar@users.sf.net>
-
- IMPLEMENTATION OF TIP#412.
-
- * library/msgcat/msgcat.tcl: dynamic locale change with mc file
- * library/clock.tcl: load on locale change.
- clock uses new msgcat features.
-
-2012-09-07 Harald Oehlmann <oehhar@users.sf.net>
-
- *** 8.6b3 TAGGED FOR RELEASE ***
-
- IMPLEMENTATION OF TIP#404.
-
- * library/msgcat/msgcat.tcl: [FRQ 3544988]: New commands [mcflset]
- * library/msgcat/pkgIndex.tcl: and [mcflmset] to set mc entries with
- * unix/Makefile.in: implicit message file locale.
- * win/Makefile.in: Bump to 1.5.0.
-
-2012-08-25 Donal K. Fellows <dkf@users.sf.net>
-
- * library/msgs/uk.msg: [Bug 3561330]: Use the correct full name of
- March in Ukrainian. Thanks to Mikhail Teterin for reporting.
-
-2012-08-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBinary.c: [Bug 3496014]: Unecessary memset() in
- Tcl_SetByteArrayObj().
-
-2012-08-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 3559678]: Fix bad filename normalization
- when the last component is the empty string.
-
-2012-08-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Remove wrapper macro for ntohs(): unnecessary,
- because it doesn't require an initialized winsock_2 library. See:
- <http://msdn.microsoft.com/en-us/library/windows/desktop/ms740075%28v=vs.85%29.aspx>
- * win/tclWinSock.c:
- * generic/tclStubInit.c:
-
-2012-08-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/nmakehlp.c: Add "-V<num>" option, in order to be able to detect
- partial version numbers.
-
-2012-08-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/buildall.vc.bat: Only build the threaded builds by default
- * win/rules.vc: Some code cleanup
-
-2010-08-13 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/tclUnixCompat.c: [Bug 3555454]: Rearrange a bit to quash
- 'declared but never defined' compiler warnings.
-
-2012-08-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/zlib/win64/zlib1.dll: Add 64-bit build of zlib1.dll, and use
- * compat/zlib/win64/zdll.lib: it for the dynamic mingw-w64 build.
- * win/Makefile.in:
- * win/configure.in:
- * win/configure:
-
-2012-08-09 Reinhard Max <max@suse.de>
-
- * tests/http.test: Fix http-3.29 for machines without IPv6 support.
-
-2010-08-08 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/tclUnixCompat.c: Change one '#ifdef' to '#if defined()' for
- improved consistency within the file.
-
-2012-08-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclfileName.c: [Bug #1536227]: Cygwin network pathname
- * tests/fileName.test: support
-
-2012-08-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c: [Bug 3554250]: Overlooked one field of cleanup
- in the thread exit handler for the filesystem subsystem.
-
-2012-07-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInterp.c (Tcl_GetInterpPath):
- * unix/tclUnixPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
- * win/tclWinPipe.c (TclGetAndDetachPids, Tcl_PidObjCmd):
- Purge use of Tcl_AppendElement, and corrected conversion of PIDs to
- integer objects.
-
-2012-07-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/nmakehlp.c: Add -Q option from sampleextension.
- * win/Makefile.in: [FRQ 3544967]: Missing objectfiles in static lib
- * win/makefile.vc: (Thanks to Jos Decoster).
-
-2012-07-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: No longer build tcltest.exe to run the tests,
- but use tclsh86.exe in combination with tcltest86.dll to do that.
- * tests/*.test: load tcltest86.dll if necessary.
-
-2012-07-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tests/clock.test: [Bug 3549770]: Multiple test failures running
- * tests/registry.test: tcltest outside build tree
- * tests/winDde.test:
-
-2012-07-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUniData.c: Support Unicode 6.2 (Add Turkish lira sign)
- * generic/regc_locale.c:
-
-2012-07-25 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * win/tclWinPipe.c: [Bug 3547994]: Abandon the synchronous Windows
- pipe driver to its fate when needed to honour TIP#398.
-
-2012-07-24 Trevor Davel <twylite@crypt.co.za>
-
- * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file
- descriptors for a socket where required (TcpCloseProc, SocketProc).
- Refactor socket/descriptor setup to manage linked list operations in
- one place. Fix memory leak in socket close (TcpCloseProc) and related
- dangling pointers in SocketEventProc.
-
-2012-07-19 Reinhard Max <max@suse.de>
-
- * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough
- buffer for accept()ing IPv6 connections. Fix conversion of host and
- port for passing to the accept proc to be independent of the IP
- version.
-
-2012-07-23 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: [Bug 3545365]: Never try a bg-flush on a dead
- channel, just like before 2011-08-17.
-
-2012-07-19 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclTest.c: Fix several more missing mutex-locks in
- TestasyncCmd.
-
-2012-07-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclTest.c: [Bug 3544685]: Missing mutex-lock in
- TestasyncCmd since 2011-08-19. Unbounded gratitude to Stuart
- Cassoff for spotting it.
-
-2012-07-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails
-
-2012-07-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclUtil.c (UpdateStringOfEndOffset): [Bug 3544658]: Stop
- 1-byte overrun in memcpy, that object placement rules made harmless
- but which still caused compiler complaints.
-
-2012-07-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/reg/pkgIndex.tcl: Make registry 1.3 package dynamically
- loadable when ::tcl::pkgconfig is available.
-
-2012-07-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinReg.c: [Bug 3362446]: registry keys command fails
- with 8.5/8.6. Follow Microsofts example better in order to prevent
- problems when using HKEY_PERFORMANCE_DATA.
-
-2012-07-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixNotfy.c: [Bug 3541646]: Don't panic on triggerPipe
- overrun.
-
-2012-07-10 Donal K. Fellows <dkf@users.sf.net>
-
- * win/tclWinSock.c (InitializeHostName): Corrected logic that
- extracted the name of the computer from the gethostname call so that
- it would use the name on success, not failure. Also ensured that the
- buffer size is exactly that recommended by Microsoft.
-
-2012-07-08 Reinhard Max <max@suse.de>
-
- * library/http/http.tcl: [Bug 3531209]: Add fix and test for URLs that
- * tests/http.test: contain literal IPv6 addresses.
-
-2012-07-05 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixPipe.c: [Bug 1189293]: Make "<<" binary safe.
- * win/tclWinPipe.c:
-
-2012-07-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclUtil.c (TclDStringAppendObj, TclDStringAppendDString):
- * generic/tclInt.h (TclDStringAppendLiteral, TclDStringClear):
- * generic/tclCompile.h (TclDStringAppendToken): Added wrappers to make
- common cases of appending to Tcl_DStrings simpler to write. Prompted
- by looking at [FRQ 1357401] (these are an _internal_ implementation of
- that FRQ).
-
-2012-06-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/msgcat/msgcat.tcl: Add tn, ro_MO and ru_MO to msgcat.
-
-2012-06-29 Harald Oehlmann <oehhar@users.sf.net>
-
- * library/msgcat/msgcat.tcl: [Bug 3536888]: Locale guessing of
- * library/msgcat/pkgIndex.tcl: msgcat fails on (some) Windows 7. Bump
- * unix/Makefile.in: to 1.4.5
- * win/Makefile.in:
-
-2012-06-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/GetIndex.3: Reinforced the description of the requirement for
- the tables of names to index over to be static, following posting to
- tcl-core by Brian Griffin about a bug caused by Tktreectrl not obeying
- this rule correctly. This does not represent a functionality change,
- merely a clearer documentation of a long-standing constraint.
-
-2012-06-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Let Cygwin shared build link with
- * unix/configure.in: zlib1.dll, not cygz.dll (two less
- * unix/configure: dependencies on cygwin-specific dll's)
- * unix/Makefile.in:
-
-2012-06-26 Reinhard Max <max@suse.de>
-
- * generic/tclIOSock.c: Use EAI_SYSTEM only if it exists.
- * unix/tclUnixSock.c:
-
-2012-06-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileSystem.h: [Bug 3024359]: Make sure that the
- * generic/tclIOUtil.c: per-thread cache of the list of file systems
- * generic/tclPathObj.c: currently registered is only updated at times
- when no active loops are traversing it. Also reduce the amount of
- epoch storing and checking to where it can make a difference.
-
-2012-06-25 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (EncodingDirsObjCmd): [Bug 3537605]: Do the right
- thing when reporting errors with the number of arguments.
-
-2012-06-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclfileName.c: [Patch 1536227]: Cygwin network pathname
- * tests/fileName.test: support.
-
-2012-06-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixNotfy.c: [Bug 3508771]: Cygwin notifier for handling
- win32 events.
-
-2012-06-22 Reinhard Max <max@suse.de>
-
- * generic/tclIOSock.c: Rework the error message generation of [socket],
- * unix/tclUnixSock.c: so that the error code of getaddrinfo is used
- * win/tclWinSock.c: instead of errno unless it is EAI_SYSTEM.
-
-2012-06-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinReg.c: [Bug 3362446]: registry keys command fails
- * tests/registry.test: with 8.5/8.6
-
-2012-06-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: [Bug 3532959]: Make sure the lifetime
- * generic/tclProc.c: management of entries in the linePBodyPtr
- * tests/proc.test: hash table can tolerate either order of
- teardown, interp first, or Proc first.
-
-2012-06-08 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure.in: Update autogoo for gettimeofday().
- * unix/tclUnixPort.h: Thanks Joe English.
- * unix/configure: autoconf 2.13
-
- * unix/tclUnixPort.h: [Bug 3530533]: Centralize #include <pthread.h>
- * unix/tclUnixThrd.c: in the tclUnixPort.h header so that old unix
- systems that need inclusion in all compilation units are supported.
-
-2012-06-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: Revise the "null data" check: null strings are
- possible, but empty binary arrays are not.
- * tests/winDde.test: Add test-case (winDde-9.4) for transferring
- null-strings with dde. Convert tests to tcltest-2 syntax.
-
-2012-06-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (TclZlibInit): Declare that Tcl is publishing the
- zlib package (version 2.0) as part of its bootstrap process. This will
- have an impact on tclkit (which includes zlib 1.1) but otherwise be
- very low impact.
-
-2012-06-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixInit.c: On Cygwin, use win32 API in stead of uname()
- to determine the tcl_platform variables.
-
-2012-05-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclZlib.c: [Bug 3530536]: zlib-7.4 fails on IRIX64
- * tests/zlib.test:
- * doc/zlib.n: Document that [stream checksum] doesn't do
- what's expected for "inflate" and "deflate" formats
-
-2012-05-31 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (safe::AliasFileSubcommand): Don't assume that
- slaves have corresponding commands, as that is not true for
- sub-subinterpreters (used in Tk's test suite).
-
- * doc/safe.n: [Bug 1997845]: Corrected formatting so that generated
- HTML can link properly.
-
- * tests/socket.test (socket*-13.1): Prevented intermittent test
- failure due to race condition.
-
-2012-05-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/expr.n, doc/mathop.n: [Bug 2931407]: Clarified semantics of
- division and remainder operators.
-
-2012-05-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: [Bug 3525762]: Encoding handling in dde.
- * win/Makefile.in: Fix "make genstubs" when cross-compiling on UNIX
-
-2012-05-28 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (safe::AliasFileSubcommand): [Bug 3529949]: Made a
- more sophisticated method for preventing information leakage; it
- changes references to "~user" into "./~user", which is safe.
-
-2012-05-25 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/namespace.n, doc/Ensemble.3: [Bug 3528418]: Document what is
- going on with respect to qualification of command prefixes in ensemble
- subcommand maps.
-
- * generic/tclIO.h (SYNTHETIC_EVENT_TIME): Factored out the definition
- of the amount of time that should be waited before firing a synthetic
- event on a channel.
-
-2012-05-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: [Bug 473946]: Special characters were not correctly
- sent, now for XTYP_EXECUTE as well as XTYP_REQUEST.
- * win/Makefile.in: Fix "make genstubs" when cross-compiling on UNIX
-
-2012-05-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Take cygwin handling of X11 into account.
- * generic/tcl*Decls.h: re-generated
- * generic/tclStubInit.c: Implement TclpIsAtty, Cygwin only.
- * doc/dde.n: Doc fix: "dde execute iexplore" doesn't work
- without -async, because iexplore doesn't return a value
-
-2012-05-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Let cygwin share stub table with win32
- * win/tclWinSock.c: implement TclpInetNtoa for win32
- * generic/tclInt.decls: Revert most of [3caedf05df], since when
- we let cygwin share the win32 stub table this is no longer necessary
- * generic/tcl*Decls.h: re-generated
- * doc/dde.n: 1.3 -> 1.4
-
-2012-05-23 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibTransformInput): [Bug 3525907]: Ensure that
- decompressed input is flushed through the transform correctly when the
- input stream gets to the end. Thanks to Alexandre Ferrieux and Andreas
- Kupries for their work on this.
-
-2012-05-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c: When using Tcl_SetObjLength() calls to
- * generic/tclPathObj.c: grow and shrink the objPtr->bytes
- buffer, care must be taken that the value cannot possibly become pure
- Unicode. Calling Tcl_AppendToObj() has the possibility of making such
- a conversion. Bug found while valgrinding the trunk.
-
-2012-05-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- IMPLEMENTATION OF TIP#106
-
- * win/tclWinDde.c: Added encoding-related abilities to
- * library/dde/pkgIndex.tcl: the [dde] command. The dde package's
- * tests/winDde.test: version is now 1.4.0.
- * doc/dde.n:
-
-2012-05-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut
- the amount of hackiness in class constructors, and refactor some of
- the error message handling from [oo::define] to be saner in the face
- of odd happenings.
-
-2012-05-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected
- resulting indexes from -indexvar option to be usable with [string
- range]; this was always the intention (and is consistent with [regexp
- -indices] too).
- ***POTENTIAL INCOMPATIBILITY***
- Uses of [switch -regexp -indexvar] that previously compensated for the
- wrong offsets (by subtracting 1 from the end indices) now do not need
- to do so as the value is correct.
-
- * library/safe.tcl (safe::InterpInit): Ensure that the module path is
- constructed in the correct order.
- (safe::AliasGlob): [Bug 2964715]: More extensive handling of what
- globbing is required to support package loading.
-
- * doc/expr.n: [Bug 3525462]: Corrected statement about what happens
- when comparing "0y" and "0x12"; the previously documented behavior was
- actually a subtle bug (now long-corrected).
-
-2012-05-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3445787]: Improve
- the compatibility of safe interpreters' version of 'file' with that of
- unsafe interpreters.
- * library/safe.tcl (::safe::InterpInit): Teach the safe-interp scripts
- about how to expose 'file' properly.
-
-2012-05-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: Protect against receiving strings without ending
- \0, as external applications (or Tcl with TIP #106) could generate
- that.
-
-2012-05-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: [Bug 473946]: Special characters not correctly sent
- * library/dde/pkgIndex.tcl: Increase version to 1.3.3
-
-2012-05-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * {win,unix}/configure{,.in}: [Bug 2812981]: Clean up bundled
- packages' build directory from within Tcl's ./configure, to avoid
- stale configuration.
-
-2012-05-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c: [Bug 3522560]: Fixed the crash, enabled the
- test case. Modified [chan postevent] to properly inject the event(s)
- into the owner thread's event queue for execution in the correct
- context. Renamed the ForwardOpTo...Thread() function to match with our
- terminology.
-
- * tests/ioCmd.test: [Bug 3522560]: Added a test which crashes the core
- if it were not disabled as knownBug. For a reflected channel
- transfered to a different thread the [chan postevent] run in the
- handler thread tries to execute the owner threads's fileevent scripts
- by itself, wrongly reaching across thread boundaries.
-
-2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: Properly close nonblocking channels even when
- not flushing them.
-
-2012-05-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/zlib/*: Upgrade to zlib 1.2.7 (prebuilt dll is still 1.2.5,
- will be upgraded as soon as the official build is available)
-
-2012-05-03 Don Porter <dgp@users.sourceforge.net>
-
- * tests/socket.test: [Bug 3428754]: Test socket-14.2 tolerate
- [socket -async] connection that connects synchronously.
-
- * unix/tclUnixSock.c: [Bug 3428753]: Fix [socket -async] connections
- that manage to connect synchronously.
-
-2012-05-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/configure.in: Better detection and implementation for
- * generic/configure: cpuid instruction on Intel-derived
- * generic/tclUnixCompat.c: processors, both 32-bit and 64-bit.
- * generic/tclTest.c: Move cpuid testcase from win-specific to
- * win/tclWinTest.c: generic tests, as it should work on all
- * tests/platform.test: Intel-related platforms now.
-
-2012-04-30 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/ioCmd.test: [Bug 3522560]: Tame deadlocks in broken refchan
- tests.
-
-2012-04-28 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- IMPLEMENTATION OF TIP#398
-
- * generic/tclIO.c: Quickly Exit with Non-Blocking Blocked Channels
- * tests/io.test : *** POTENTIAL INCOMPATIBILITY ***
- * doc/close.n : (compat flag available)
-
-2012-04-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPort.h: Move CYGWIN-specific stuff from tclPort.h to
- * generic/tclEnv.c: tclUnixPort.h, where it belongs.
- * unix/tclUnixPort.h:
- * unix/tclUnixFile.c:
-
-2012-04-27 Donal K. Fellows <dkf@users.sf.net>
-
- * library/init.tcl (auto_execok): Allow shell builtins to be detected
- even if they are upper-cased.
-
-2012-04-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStubInit.c: Get rid of _ANSI_ARGS_ and CONST
- * generic/tclIO.c:
- * generic/tclIOCmd.c:
- * generic/tclTest.c:
- * unix/tclUnixChan.c:
-
-2012-04-25 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclUtil.c (TclDStringToObj): Added internal function to make
- the fairly-common operation of converting a DString into an Obj a more
- efficient one; for long strings, it can just transfer the ownership of
- the buffer directly. Replaces this:
- obj=Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- with this:
- obj=TclDStringToObj(&ds);
-
-2012-04-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin
- tclsh
- * generic/tclIntPlatDecls.h: Implement TclWinGetSockOpt,
- * generic/tclStubInit.c: TclWinGetServByName and TclWinCPUID for
- * generic/tclUnixCompat.c: Cygwin.
- * unix/configure.in:
- * unix/configure:
- * unix/tclUnixCompat.c:
-
-2012-04-18 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/America/Port-au-Prince:
- * library/tzdata/Asia/Damascus:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Hebron: tzdata2012c
-
-2012-04-16 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/FileSystem.3 (Tcl_FSOpenFileChannelProc): [Bug 3518244]: Fixed
- documentation of this filesystem callback function; it must not
- register its created channel - that's the responsibility of the caller
- of Tcl_FSOpenFileChannel - as that leads to reference leaks.
-
-2012-04-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclEnsemble.c (NsEnsembleImplementationCmdNR):
- * generic/tclIOUtil.c (Tcl_FSEvalFileEx): Cut out levels of the C
- stack by going direct to the relevant internal evaluation function.
-
- * generic/tclZlib.c (ZlibTransformSetOption): [Bug 3517696]: Make
- flushing work correctly in a pushed compressing channel transform.
-
-2012-04-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: [Bug 3514475]: Remove TclpGetTimeZone and
- * generic/tclIntDecls.h: TclpGetTZName
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * unix/tclUnixTime.c:
- * unix/tclWinTilemc:
-
-2012-04-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinInit.c: [Bug 3448512]: clock scan "1958-01-01" fails
- * win/tcl.m4: only in debug compilation.
- * win/configure:
- * unix/tcl.m4: Use NDEBUG consistantly meaning: no debugging.
- * unix/configure:
- * generic/tclBasic.c:
- * library/dde/pkgIndex.tcl: Use [::tcl::pkgconfig get debug] instead
- * library/reg/pkgIndex.tcl: of [info exists ::tcl_platform(debug)]
-
-2012-04-10 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that
- can be used to mark parts of Tcl's API as deprecated. Currently only
- used for fields of Tcl_Interp, which TIPs 330 and 336 have deprecated
- with a migration strategy; we want to encourage people to move away
- from those fields.
-
-2012-04-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]:
- Ensure that the lists of variable names used to drive variable
- resolution will never have the same name twice.
-
- * generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with
- reporting of declared variables in methods. It's really a problem with
- how [info vars] interacts with variable resolvers; this is just a bit
- of a hack so it is no longer a big problem.
-
-2012-04-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance):
- [Bug 3514761]: Fixed bogosity with automated argument description
- handling when constructing an instance of a class that is itself a
- member of an ensemble. Thanks to Andreas Kupries for identifying that
- this was a problem case at all!
- (Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble
- information into [oo::copy].
-
-2012-04-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs
- * generic/tclIOSock.c: platform implementation.
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
-2012-04-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStubInit.c: Remove the TclpGetTZName implementation for
- * generic/tclIntDecls.h: Cygwin (from 2012-04-02 commit), re-generated
- * generic/tclIntPlatDecls.h:
-
-2012-04-02 Donal K. Fellows <dkf@users.sf.net>
-
- IMPLEMENTATION OF TIP#396.
-
- * generic/tclBasic.c (builtInCmds, TclNRYieldToObjCmd): Convert the
- formerly-unsupported yieldm and yieldTo commands into [yieldto].
-
-2012-04-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin tclsh
- * generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance,
- * generic/tclStubInit.c: TclpGetTZName, and various more
- win32-specific internal functions for Cygwin, so win32 extensions
- using those can be loaded in the cygwin version of tclsh.
-
-2012-03-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: [Bug 3511806]: Compiler checks too early
- * unix/configure.in: This change allows to build the cygwin and
- * unix/tclUnixPort.h: mingw32 ports of Tcl/Tk to build out-of-the-box
- * win/tcl.m4: using a native or cross-compiler.
- * win/configure.in:
- * win/tclWinPort.h:
- * win/README Document how to build win32 or win64 executables
- with Linux, Cygwin or Darwin.
-
-2012-03-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCmdMZ.c (StringIsCmd): Faster mem-leak free
- implementation of [string is entier].
-
-2012-03-27 Donal K. Fellows <dkf@users.sf.net>
-
- IMPLEMENTATION OF TIP#395.
-
- * generic/tclCmdMZ.c (StringIsCmd): Implementation of the [string is
- entier] check. Code by Jos Decoster.
-
-2012-03-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW.
- * generic/tclFCmd.c: [Bug 2015723]: Duplicate inodes from file stat
- * generic/tclCmdAH.c: on windows (but now for cygwin as well).
- * generic/tclOODefineCmds.c: minor gcc warning
- * win/tclWinPort.h: Use lower numbers, preventing integer overflow.
- Remove the workaround for mingw-w64 [Bug 3407992]. It's long fixed.
-
-2012-03-27 Donal K. Fellows <dkf@users.sf.net>
-
- IMPLEMENTATION OF TIP#397.
-
- * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
- target object name optional when copying classes. [RFE 3485060]: Add
- callback method ("<cloned>") so that scripted control over copying is
- easier.
- ***POTENTIAL INCOMPATIBILITY***
- If you'd previously been using the "<cloned>" method name, this now
- has a standard semantics and call interface. Only a problem if you are
- also using [oo::copy].
-
-2012-03-26 Donal K. Fellows <dkf@users.sf.net>
-
- IMPLEMENTATION OF TIP#380.
-
- * doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
- * generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
- * tests/oo.test: Switch definitions of lists of things in objects and
- classes to a slot-based approach, which gives a lot more flexibility
- and programmability at the script-level. Introduce new [::oo::Slot]
- class which is the implementation of these things.
-
- ***POTENTIAL INCOMPATIBILITY***
- The unknown method handler now may be asked to deal with the case
- where no method name is provided at all. The default implementation
- generates a compatible error message, and any override that forces the
- presence of a first argument (i.e., a method name) will continue to
- function as at present as well, so this is a pretty small change.
-
- * generic/tclOOBasic.c (TclOO_Object_Destroy): Made it easier to do a
- tailcall inside a normally-invoked destructor; prevented leakage out
- to calling command.
-
-2012-03-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin
- * generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError,
- * generic/tclStubInit.c: TclWinConvertWSAError, and various more
- * unix/Makefile.in: win32-specific internal functions for
- * unix/tcl.m4: Cygwin, so win32 extensions using those
- * unix/configure: can be loaded in the cygwin version of
- * win/tclWinError.c: tclsh.
-
-2012-03-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Revert some cygwin-related signature
- * generic/tclIntPlatDecls.h: changes from [835f8e1e9d] (2010-01-22).
- * win/tclWinError.c: They were an attempt to make the cygwin
- port compile again, but since cygwin is
- based on unix this serves no purpose any
- more.
- * win/tclWinSerial.c: Use EAGAIN in stead of EWOULDBLOCK,
- * win/tclWinSock.c: because in VS10+ the value of
- EWOULDBLOCK is no longer the same as
- EAGAIN.
- * unix/Makefile.in: Add tclWinError.c to the CYGWIN build.
- * unix/tcl.m4:
- * unix/configure:
-
-2012-03-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls: [Bug 3508771]: load tclreg.dll in cygwin
- * generic/tclInt.decls: tclsh. Implement TclWinGetPlatformId,
- * generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf (and
- * generic/tclPlatDecls.h: a dummy TclWinCPUID) for Cygwin, so win32
- * generic/tclStubInit.c: extensions using those can be loaded in
- * unix/tclUnixCompat.c: the cygwin version of tclsh.
-
-2012-03-19 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/America/Atikokan: Update to tzdata2012b.
- * library/tzdata/America/Blanc-Sablon:
- * library/tzdata/America/Dawson_Creek:
- * library/tzdata/America/Edmonton:
- * library/tzdata/America/Glace_Bay:
- * library/tzdata/America/Goose_Bay:
- * library/tzdata/America/Halifax:
- * library/tzdata/America/Havana:
- * library/tzdata/America/Moncton:
- * library/tzdata/America/Montreal:
- * library/tzdata/America/Nipigon:
- * library/tzdata/America/Rainy_River:
- * library/tzdata/America/Regina:
- * library/tzdata/America/Santiago:
- * library/tzdata/America/St_Johns:
- * library/tzdata/America/Swift_Current:
- * library/tzdata/America/Toronto:
- * library/tzdata/America/Vancouver:
- * library/tzdata/America/Winnipeg:
- * library/tzdata/Antarctica/Casey:
- * library/tzdata/Antarctica/Davis:
- * library/tzdata/Antarctica/Palmer:
- * library/tzdata/Asia/Yerevan:
- * library/tzdata/Atlantic/Stanley:
- * library/tzdata/Pacific/Easter:
- * library/tzdata/Pacific/Fakaofo:
- * library/tzdata/America/Creston: (new)
-
-2012-03-19 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (Tcl_OpenTcpServer): Use the values returned
- by getaddrinfo() for all three arguments to socket() instead of
- only using ai_family. Try to keep the most meaningful error while
- iterating over the result list, because using the last error can
- be misleading.
-
-2012-03-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin
- * unix/tclUnixFile.c:
- * unix/tclUnixPort.h:
- * win/cat.c: Remove cygwin stuff no longer needed
- * win/tclWinFile.c:
- * win/tclWinPort.h:
-
-2012-03-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings
-
-2012-03-11 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/*.n, doc/*.3: A number of small spelling and wording fixes.
-
-2012-03-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/info.n: Various minor fixes (prompted by Andreas Kupries
- * doc/socket.n: detecting a spelling mistake).
-
-2012-03-07 Andreas Kupries <andreask@activestate.com>
-
- * library/http/http.tcl: [Bug 3498327]: Generate upper-case
- * library/http/pkgIndex.tcl: hexadecimal output for compliance
- * tests/http.test: with RFC 3986. Bumped version to 2.8.4.
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2012-03-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Compatibility with older Visual Studio versions.
-
-2012-03-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclLoad.c: Patch from the cygwin folks
- * unix/tcl.m4:
- * unix/configure: (re-generated)
-
-2012-03-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (Tcl_SetByteArrayObj): [Bug 3496014]: Only zero
- out the memory block if it is not being immediately overwritten. (Our
- caller might still overwrite, but we should at least avoid
- known-useless work.)
-
-2012-02-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIOUtil.c: [Bug 3466099]: BOM in Unicode
- * generic/tclEncoding.c:
- * tests/source.test:
-
-2012-02-23 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/reg.test (14.21-23): Add tests relating to Bug 1115587. Actual
- bug is characterised by test marked with 'knownBug'.
-
-2012-02-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIOUtil.c: [Bug 2233954]: AIX: compile error
- * unix/tclUnixPort.h:
-
-2012-02-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (INST_LIST_RANGE_IMM): Enhance implementation
- so that shortening a (not multiply-referenced) list by lopping the end
- off with [lrange] or [lreplace] is efficient.
-
-2012-02-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation
- strategy for [lreplace] that tackles the cases which are equivalent to
- a static [lrange].
- (TclCompileLrangeCmd): Add compiler for [lrange] with constant indices
- so we can take advantage of existing TCL_LIST_RANGE_IMM opcode.
- (TclCompileLindexCmd): Improve coverage of constant-index-style
- compliation using technique developed for [lrange] above.
-
- (TclCompileDictForCmd): [Bug 3487626]: Fix crash in compilation of
- [dict for] when its implementation command is used directly rather
- than through the ensemble.
-
-2012-02-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Converted the memcpy() calls in append
- operations to memmove() calls. This adds safety in the case of
- overlapping copies, and improves performance on some benchmarks.
-
-2012-02-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEnsemble.c: [Bug 3485022]: TclCompileEnsemble() avoid
- * tests/trace.test: compile when exec traces set.
-
-2012-02-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclTrace.c: [Bug 3484621]: Ensure that execution traces on
- * tests/trace.test: bytecoded commands bump the interp's compile
- epoch.
-
-2012-02-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUniData.c: [FRQ 3464401]: Support Unicode 6.1
- * generic/regc_locale.c:
-
-2012-02-02 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinFile.c: [Bugs 2974459,2879351,1951574,1852572,
- 1661378,1613456]: Revisions to the NativeAccess() routine that queries
- file permissions on Windows native filesystems. Meant to fix numerous
- bugs where [file writable|readable|executable] "lies" about what
- operations are possible, especially when the file resides on a Samba
- share.
-
-2012-02-01 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/AddErrInfo.3: [Bug 3482614]: Documentation nit.
-
-2012-01-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileCatchCmd): Added a more efficient
- bytecode generator for the case where 'catch' is used without any
- variable arguments; don't capture the result just to discard it.
-
-2012-01-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c: [Bug 3479689]: New internal routine
- * generic/tclFCmd.c: TclJoinPath(). Refactor all the
- * generic/tclFileName.c: *Join*Path* routines to give them more
- * generic/tclInt.h: useful interfaces that are easier to
- * generic/tclPathObj.c: manage getting the refcounts right.
-
-2012-01-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 3475569]: Add checks for unshared values
- before calls demanding them. [Bug 3479689]: Stop memory corruption
- when shimmering 0-refCount value to "path" type.
-
-2012-01-25 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: When
- copying an object, make sure that the configuration of the variable
- resolver is also duplicated.
-
-2012-01-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related
- * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be
- * generic/tclUniData.c: able to handle characters > 0xFFFF. Done in
- * generic/tclUtf.c: all branches in order to simplify merges for
- * generic/regc_locale.c: new Unicode versions (such as 6.1)
-
-2012-01-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictExistsCmd): [Bug 3475264]: Ensure that
- errors only ever happen when insufficient arguments are supplied, and
- not when a path doesn't exist or a dictionary is poorly formatted (the
- two cases can't be easily distinguished).
-
-2012-01-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3474726]: Eliminate detection of struct
- * generic/tclWinPort.h: _stat32i64, just use _stati64 in combination
- * generic/tclFCmd.c: with _USE_32BIT_TIME_T, which is the same
- * generic/tclTest.c: then. Only keep _stat32i64 usage for cygwin,
- * win/configure.in: so it will not conflict with cygwin's own
- * win/configure: struct stat.
-
-2012-01-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: [Bug 3475667]: Prevent buffer read overflow.
- Thanks to "sebres" for the report and fix.
-
-2012-01-17 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n (dict with): [Bug 3474512]: Explain better what is going
- on when a dictionary key and the dictionary variable collide.
-
-2012-01-13 Donal K. Fellows <dkf@users.sf.net>
-
- * library/http/http.tcl (http::Connect): [Bug 3472316]: Ensure that we
- only try to read the socket error exactly once.
-
-2012-01-12 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/tclvars.n: [Bug 3466506]: Document more environment variables.
-
-2012-01-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] was
- * generic/regc_locale.c: wrong. Add table for Unicode [:cntrl:] class.
- * tools/uniClass.tcl: Generate Unicode [:cntrl:] class table.
- * tests/utf.test:
-
-2012-01-08 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (ReadZoneinfoFile): [Bug 3470928]: Corrected a bug
- * tests/clock.test (clock-56.4): where loading zoneinfo would
- fail if one timezone abbreviation was a proper tail of another, and
- zic used the same bytes of the file to represent both of them. Added a
- test case for the bug, using the same data that caused the observed
- failure "in the wild."
-
-2011-12-30 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/America/Bahia: Update to Olson's tzdata2011n
- * library/tzdata/America/Havana:
- * library/tzdata/Europe/Kiev:
- * library/tzdata/Europe/Simferopol:
- * library/tzdata/Europe/Uzhgorod:
- * library/tzdata/Europe/Zaporozhye:
- * library/tzdata/Pacific/Fiji:
-
-2011-12-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUtf.c: [Bug 3464428]: [string is graph \u0120] is wrong.
- * generic/tclUniData.c:
- * generic/regc_locale.c:
- * tests/utf.test:
- * tools/uniParse.tcl: Clean up some unused stuff, and be more robust
- against changes in UnicodeData.txt syntax
-
-2011-12-13 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCompile.c (TclInitAuxDataTypeTable): Extended to register
- the DictUpdateInfo structure as an AuxData type. For use by tbcload,
- tclcompiler.
-
-2011-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/regc_locale.c: [Bug 3457031]: Some Unicode 6.0 chars not
- * tests/utf.test: in [:print:] class
-
-2011-12-07 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/uniParse.tcl: [Bug 3444754]: string tolower \u01c5 is wrong
- * generic/tclUniData.c:
- * tests/utf.test:
-
-2011-11-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work
- when tclsh is compiled without using the setargv() function on mingw.
-
-2011-11-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: don't install tommath_(super)?class.h
- * unix/Makefile.in: don't install directories like 8.2 and 8.3
- * generic/tclTomMath.h: [Bug 2991415]: move include tclInt.h from
- * generic/tclTomMathInt.h: tclTomMath.h to tclTomMathInt.h
-
-2011-11-25 Donal K. Fellows <dkf@users.sf.net>
-
- * library/history.tcl (history): Simplify the dance of variable
- management used when chaining to the implementation command.
-
-2011-11-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclCompileObj): Simplify and de-indent the
- logic so that it is easier to comprehend.
-
-2011-11-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: [Bug 3354324]: Windows: [file mtime] sets wrong
- * win/tclWinFile.c: time (VS2005+ only).
- * generic/tclTest.c:
-
-2011-11-20 Joe Mistachkin <joe@mistachkin.com>
-
- * tests/thread.test: Remove unnecessary [after] calls from the thread
- tests. Make error message matching more robust for tests that may
- have built-in race conditions. Test thread-7.26 must first unset all
- thread testing related variables. Revise results of the thread-7.28
- through thread-7.31 tests to account for the fact they are canceled
- via a script sent to the thread asynchronously, which then impacts the
- error message handling. Attempt to manually drain the event queue for
- the main thread after joining the test thread to make sure no stray
- events are processed at the wrong time on the main thread. Revise all
- the synchronization and comparison semantics related to the thread id
- and error message.
-
-2011-11-18 Joe Mistachkin <joe@mistachkin.com>
-
- * tests/thread.test: Remove all use of thread::release from the thread
- 7.x tests, replacing it with a script that can easily cause "stuck"
- threads to self-destruct for those test cases that require it. Also,
- make the error message handling far more robust by keeping track of
- every asynchronous error.
-
-2011-11-17 Joe Mistachkin <joe@mistachkin.com>
-
- * tests/thread.test: Refactor all the remaining thread-7.x tests that
- were using [testthread]. Note that this test file now requires the
- very latest version of the Thread package to pass all tests. In
- addition, the thread-7.18 and thread-7.19 tests have been flagged as
- knownBug because they cannot pass without modifications to the [expr]
- command, persuant to TIP #392.
-
-2011-11-17 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclThreadTest.c: For [testthread cancel], avoid creating a
- new Tcl_Obj when the default script cancellation result is desired.
-
-2011-11-11 Donal K. Fellows <dkf@users.sf.net>
-
- * win/tclWinConsole.c: Refactor common thread handling patterns.
-
-2011-11-11 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/zlib.test: [Bug 3428756]: Use nonblocking writes in
- single-threaded IO tests to avoid deadlocks when going beyond OS
- buffers. Tidy up [chan configure] flags across zlib.test.
-
-2011-11-03 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam)
- (TclpGetGrGid): Use the elaborate memory management scheme outlined on
- http://www.opengroup.org/austin/docs/austin_328.txt to handle Tcl's
- use of standard reentrant versions of the passwd/group access
- functions so that everything can work on all BSDs. Problem identified
- by Stuart Cassoff.
-
-2011-10-20 Don Porter <dgp@users.sourceforge.net>
-
- * library/http/http.tcl: Bump to version 2.8.3
- * library/http/pkgIndex.tcl:
- * unix/Makefile.in:
- * win/Makefile.in:
-
- * changes: Updates toward 8.6b3 release.
-
-2011-10-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]:
- Additional code for handling the invalidation of literals.
- * generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand)
- (TclRenameCommand, Tcl_ExposeCommand): The four additional places that
- need extra care when dealing with literals.
- * generic/tclTest.c (TestInterpResolverCmd): Additional test machinery
- for interpreter resolvers.
-
-2011-10-18 Reinhard Max <max@suse.de>
-
- * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time
- zone only if it was detected by one of the expensive methods.
- Otherwise after unsetting TCL_TZ or TZ the previous value will still
- be used.
-
-2011-10-15 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/America/Sitka: Update to Olson's tzdata2011l
- * library/tzdata/Pacific/Fiji:
- * library/tzdata/Asia/Hebron: (New)
-
-2011-10-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by
- [file stat] command.
-
-2011-10-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of
- qualified names, and added spacial cases for empty bodies (used when
- [dict with] is just used for extracting variables).
-
-2011-10-07 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Fix gcc warnings (discovered with latest
- * generic/tclIORChan.c: mingw, based on gcc 4.6.1)
- * tests/env.test: Fix env.test, when running under wine 1.3.
-
-2011-10-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (TclDictWithInit, TclDictWithFinish):
- * generic/tclCompCmds.c (TclCompileDictWithCmd): Experimental
- compilation for the [dict with] subcommand, using parts factored out
- from the interpreted version of the command.
-
-2011-10-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinInt.h: Remove tclWinProcs, as it is no longer
- * win/tclWin32Dll.c: being used.
-
-2011-10-03 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k
- * library/tzdata/Africa/Kampala:
- * library/tzdata/Africa/Nairobi:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Europe/Kaliningrad:
- * library/tzdata/Europe/Kiev:
- * library/tzdata/Europe/Minsk:
- * library/tzdata/Europe/Simferopol:
- * library/tzdata/Europe/Uzhgorod:
- * library/tzdata/Europe/Zaporozhye:
- * library/tzdata/Pacific/Apia:
-
-2011-09-29 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More
- refactoring so that more of the utility code is decently out of the
- way. Adjusted the header-material generator so that version numbers
- are only included in locations where there is room.
-
-2011-09-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclOO.h: [RFE 3010352]: make all TclOO API functions
- * generic/tclOODecls.h: MODULE_SCOPE
- * generic/tclOOIntDecls.h:
-
-2011-09-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIndexObj.c (Tcl_ParseArgsObjv): [Bug 3413857]: Corrected
- the memory management for the code parsing arguments when returning
- "large" numbers of arguments. Also unbroke the TCL_ARGV_AUTO_REST
- macro in passing.
-
-2011-09-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also
- make the main [file] command hidden by default in safe interpreters,
- because that's what existing code expects. This will reduce the amount
- which the code breaks, but not necessarily eliminate it...
-
-2011-09-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORTrans.c: More revisions to get finalization of
- ReflectedTransforms correct, including adopting a "dead" field as was
- done in tclIORChan.c.
-
- * tests/thread.test: Stop using the deprecated thread management
- commands of the tcltest package. The test suite ought to provide
- these tools for itself. They do not belong in a testing harness.
-
-2011-09-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdIL.c: Revise [info frame] so that it stops creating
- cycles in the iPtr->cmdFramePtr stack.
-
-2011-09-22 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at
- least something sane on Solaris.
- * tools/tcltk-man2html-utils.tcl (process-text): Teach the HTML
- generator how to handle this magic.
-
-2011-09-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclThreadTest.c: Revise the thread exit handling of the
- [testthread] command so that it properly maintains the per-process
- data structures even when the thread exits for reasons other than the
- [testthread exit] command.
-
-2011-09-21 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * unix/tclIO.c: [Bug 3412487]: Now short reads are allowed in
- synchronous fcopy, avoid mistaking them as nonblocking ones.
-
-2011-09-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing
- initialization of the 'dsti' field. Reported by Don Porter, on chat.
-
-2011-09-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORChan.c: Re-using the "interp" field to signal a dead
- channel (via NULL value) interfered with conditional cleanup tasks
- testing for "the right interp". Added a new field "dead" to perform
- the dead channel signalling task so the corrupted logic is avoided.
-
- * generic/tclIORTrans.c: Revised ReflectClose() and
- FreeReflectedTransform() so that we stop leaking ReflectedTransforms,
- yet free all Tcl_Obj values in the same thread that alloced them.
-
-2011-09-19 Don Porter <dgp@users.sourceforge.net>
-
- * tests/ioTrans.test: Conversion from [testthread] to Thread package
- stops most memory leaks.
-
- * tests/thread.test: Plug most memory leaks in thread.test.
- Constrain the rest to be skipped during `make valgrind'. Tests using
- the [testthread cancel] testing command are leaky. Corrections wait
- for either addition of [thread::cancel] to the Thread package, or
- improvements to the [testthread] testing command to make leak-free
- versions of these tests possible.
-
- * generic/tclIORChan.c: Plug all memory leaks in ioCmd.test exposed
- * tests/ioCmd.test: by `make valgrind'.
- * unix/Makefile.in:
-
-2011-09-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- IMPLEMENTATION OF TIP #388
-
- * doc/Tcl.n:
- * doc/re_syntax.n:
- * generic/regc_lex.c:
- * generic/regcomp.c:
- * generic/regcustom.h:
- * generic/tcl.h:
- * generic/tclParse.c:
- * tests/reg.test:
- * tests/utf.test:
-
-2011-09-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]:
- Corrected the handling of procedure error messages (found by TclOO).
-
-2011-09-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Don't change Tcl_UniChar type when
- * generic/regcustom.h: TCL_UTF_MAX == 4 (not supported anyway)
-
-2011-09-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]:
- Ensemble-like rewriting of error messages is complex, and TclOO (in
- combination with iTcl) hits the most tricky cases.
-
- * library/http/http.tcl (http::geturl): [Bug 3391977]: Ensure that the
- -headers option overrides the -type option (important because -type
- has a default that is not always appropriate, and the header must not
- be duplicated).
-
-2011-09-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: [Bug 3408408]: Partial improvement by sharing
- as literals the computed values of constant subexpressions when we can
- do so without incurring the cost of string rep generation.
-
-2011-09-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: [Bug 3390638]: Workaround broken Solaris
- Studio cc optimizer. Thanks to Wolfgang S. Kechel.
-
- * generic/tclDTrace.d: [Bug 3405652]: Portability workaround for
- broken system DTrace support. Thanks to Dagobert Michelson.
-
-2011-09-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with
- EOVERFLOW==E2BIG
-
-2011-09-11 Don Porter <dgp@users.sourceforge.net>
-
- * tests/thread.test: Convert [testthread] use to Thread package use
- in thread-6.1. Eliminates a memory leak in `make valgrind`.
-
- * tests/socket.test: [Bug 3390699]: Convert [testthread] use to
- Thread package use in socket_*-13.1. Eliminates a memory leak in
- `make valgrind`.
-
-2011-09-09 Don Porter <dgp@users.sourceforge.net>
-
- * tests/chanio.test: [Bug 3389733]: Convert [testthread] use to
- * tests/io.test: Thread package use in *io-70.1. Eliminates a
- memory leak in `make valgrind`.
-
-2011-09-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: [Bug 3401704]: Allow function names like
- * tests/parseExpr.test: influence(), nanobot(), and 99bottles() that
- have been parsed as missing operator syntax errors before with the
- form NUMBER + FUNCTION.
- ***POTENTIAL INCOMPATIBILITY***
-
-2011-09-06 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/America/Goose_Bay: Update to Olson's tzdata2011i
- * library/tzdata/America/Metlakatla:
- * library/tzdata/America/Resolute:
- * library/tzdata/America/St_Johns:
- * library/tzdata/Europe/Kaliningrad:
- * library/tzdata/Pacific/Apia:
- * library/tzdata/Pacific/Honolulu:
- * library/tzdata/Africa/Juba: (new)
-
-2011-09-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [RFE 1711975]: Tcl_MainEx() (like Tk_MainEx())
- * generic/tclDecls.h:
- * generic/tclMain.c:
-
-2011-09-02 Don Porter <dgp@users.sourceforge.net>
-
- * tests/http.test: Convert [testthread] use to Thread package use.
- Eliminates memory leak seen in `make valgrind`.
-
-2011-09-01 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * unix/tclUnixSock.c: [Bug 3401422]: Cache script-level changes to the
- nonblocking flag of an async client socket in progress, and commit
- them on completion.
-
-2011-09-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStrToD.c: [Bug 3402540]: Corrections to TclParseNumber()
- * tests/binary.test: to make it reject invalid Nan(Hex) strings.
-
- * tests/scan.test: [scan Inf %g] is portable; remove constraint.
-
-2011-08-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInterp.c (SlaveCommandLimitCmd, SlaveTimeLimitCmd):
- [Bug 3398794]: Ensure that low-level conditions in the limit API are
- enforced at the script level through errors, not a Tcl_Panic. This
- means that interpreters cannot read their own limits (writing already
- did not work).
-
-2011-08-30 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (TcpWatchProc): [Bug 3394732]: Put back the check
- for server sockets.
-
-2011-08-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORTrans.c: Leak of ReflectedTransformMap.
-
-2011-08-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [RFE 3396731]: Revise the [string reverse]
- * tests/string.test: implementation to operate on the representation
- that comes in, avoid conversion to other reps.
-
-2011-08-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORChan.c: [Bug 3396948]: Leak of ReflectedChannelMap.
-
-2011-08-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORTrans.c: [Bugs 3393279, 3393280]: ReflectClose(.) is
- missing Tcl_EventuallyFree() calls at some of its exits.
-
- * generic/tclIO.c: [Bugs 3394654, 3393276]: Revise FlushChannel() to
- account for the possibility that the ChanWrite() call might recycle
- the buffer out from under us.
-
- * generic/tclIO.c: Preserve the chanPtr during FlushChannel so that
- channel drivers don't yank it away before we're done with it.
-
-2011-08-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclTest.c: [Bug 2981154]: async-4.3 segfault.
- * tests/async.test: [Bug 1774689]: async-4.3 sometimes fails.
-
-2011-08-18 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: [Bug 3096275]: Sync fcopy buffers input.
-
-2011-08-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUniData.c: [Bug 3393714]: Overflow in toupper delta
- * tools/uniParse.tcl:
- * tests/utf.test:
-
-2011-08-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: [Bug 2946474]: Consistently resume backgrounded
- * tests/ioCmd.test: flushes+closes when exiting.
-
-2011-08-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/interp.n: Document TIP 378's one-way-ness.
-
-2011-08-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclGet.c: [Bug 3393150]: Overlooked free of intreps.
- (It matters for bignums!)
-
-2011-08-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: [Bug 3392070]: More complete prevention of
- Tcl_Obj reference cycles when producing an intrep of ByteCode.
-
-2011-08-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings
- about (unreachable) cases of uninitialized variables.
- * generic/tclCmdIL.c (SelectObjFromSublist): Improve the generation of
- * generic/tclIndexObj.c (Tcl_ParseArgsObjv): messages through the use
- * generic/tclVar.c (ArrayStartSearchCmd): of Tcl_ObjPrintf.
-
-2011-08-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value.
-
-2011-08-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPosixStr.c: [Bug 3388350]: mingw64 compiler warnings
- * win/tclWinPort.h:
- * win/configure.in:
- * win/configure:
-
-2011-08-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/FindExec.3: [Patch 3124554]: Move WishPanic from Tk to Tcl
- * doc/Panic.3 Added Documentation
-
-2011-08-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 3389764]: Eliminate possibility that dup
- of a "path" value can create reference cycle.
-
-2011-08-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibTransformOutput): [Bug 3390073]: Return the
- correct length of written data for a compressing transform.
-
-2011-08-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclTestObj.c: [Bug 3386721]: Allow multiple [load]ing of the
- Tcltest package.
-
-2011-08-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclBasic.c: [Bug 2919042]: Restore "valgrindability" of Tcl
- * generic/tclEvent.c: that was lost by the streamlining of [exit], by
- * generic/tclExecute.c: conditionally forcing a full Finalize:
- * generic/tclInt.h: use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)
-
-2011-08-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclCompCmds.c: [Bug 3386417]: Avoid a reference loop between
- * generic/tclInt.h: the bytecode and its companion errostack
- * generic/tclResult.c: when compiling a syntax error.
-
-2011-08-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings
- * win/tclWinDde.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
-
-2011-08-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Change the signature of TclParseHex(), such that
- * generic/tclParse.c: it can now parse up to 8 hex characters.
-
-2011-08-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibStreamCmd): Make the -buffersize option to
- '$zstream add' function correctly instead of having its value just be
- discarded unceremoniously. Also generate error codes from more of the
- code, not just the low-level code but also the Tcl infrastructure.
-
-2011-08-07 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOInfo.c (InfoClassCallCmd): [Bug 3387082]: Plug memory
- leak in call chain introspection.
-
-2011-08-06 Kevin B, Kenny <kennykb@acm.org>
-
- * generic/tclAssemnbly.c: [Bug 3384840]: Plug another memory leak.
- * generic/tclStrToD.c: [Bug 3386975]: Plug another memory leak.
-
-2011-08-05 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c: [Bug 3386975]: Plugged a memory leak in
- double->string conversion.
-
-2011-08-05 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6b2 TAGGED FOR RELEASE ***
-
- * changes: Updates for 8.6b2 release.
-
-2011-08-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclAssembly.c (AssembleOneLine): Ensure that memory isn't
- leaked when an unknown instruction is encountered. Also simplify code
- through use of Tcl_ObjPrintf in error message generation.
-
- * generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory
- leak found by Miguel with valgrind, and ensure that the correct
- direction's buffers are released.
-
-2011-08-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclPtrSetVar): Fix valgrind-detected error when
- newValuePtr is the interp's result obj.
-
-2011-08-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another
- possible memory leak due to over-complex code for freeing the table of
- labels.
-
-2011-08-04 Reinhard Max <max@suse.de>
-
- * generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using
- AI_ADDRCONFIG for now, as it was causing problems in various
- situations.
-
-2011-08-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand)
- (GetIntegerOperand, GetListIndexOperand, FindLocalVar): [Bug 3384840]:
- A Tcl_Obj is allocated by GetNextOperand, so callers of it must not
- hold a reference to one in the 'out' parameter when calling it. This
- was causing a great many memory leaks.
- * tests/assemble.test (assemble-51.*): Added group of memory leak
- tests.
-
-2011-08-02 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6b2 release.
- * tools/tcltk-man2html.tcl: Variable substitution botch.
-
-2011-08-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount)
- (Tcl_DbIsShared): [Bug 3384007]: Fix the panic messages so they share
- what should be shared and have the right number of spaces.
-
-2011-08-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (TclProcCompileProc): [Bug 3383616]: Fix for leak
- of resolveInfo when recompiling procs. Thanks go to Gustaf Neumann for
- detecting the bug and providing the fix.
-
-2011-08-01 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/tclvars.n (EXAMPLES): Added some examples of how some of the
- standard global variables can be used, following prompting by a
- request by Robert Hicks.
-
- * tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to
- determine the version number of contributed packages from their
- directory names so that HTML documentation builds are less confusing.
-
-2011-07-29 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target):
- Small enhancements to improve cross-linking with contributed packages.
- * tools/tcltk-man2html-utils.tcl (insert-cross-references): Enhance to
- cope with contributed packages' C API.
-
-2011-07-28 Reinhard Max <max@suse.de>
-
- * unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
- NEED_FAKE_RFC2553.
- * unix/configure: autoconf-2.59
-
-2011-07-28 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6b2 release.
-
- * library/tzdata/Asia/Anadyr: Update to Olson's tzdata2011h
- * library/tzdata/Asia/Irkutsk:
- * library/tzdata/Asia/Kamchatka:
- * library/tzdata/Asia/Krasnoyarsk:
- * library/tzdata/Asia/Magadan:
- * library/tzdata/Asia/Novokuznetsk:
- * library/tzdata/Asia/Novosibirsk:
- * library/tzdata/Asia/Omsk:
- * library/tzdata/Asia/Sakhalin:
- * library/tzdata/Asia/Vladivostok:
- * library/tzdata/Asia/Yakutsk:
- * library/tzdata/Asia/Yekaterinburg:
- * library/tzdata/Europe/Kaliningrad:
- * library/tzdata/Europe/Moscow:
- * library/tzdata/Europe/Samara:
- * library/tzdata/Europe/Volgograd:
- * library/tzdata/America/Kralendijk: (new)
- * library/tzdata/America/Lower_Princes: (new)
-
-2011-07-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (initScript): Ensure that TclOO is properly found by
- all the various package mechanisms (by adding a dummy ifneeded script)
- and not just some of them.
-
-2011-07-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: [Bug 3372130]: Fix hypot math function with MSVC10
-
-2011-07-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: [Bug 3371644]: Repair failure to properly handle
- * tests/util.test: (length == -1) scanning in TclConvertElement().
- Thanks to Thomas Sader and Alexandre Ferrieux.
-
-2011-07-19 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/*.3, doc/*.n: Many small fixes to documentation as part of
- project to improve quality of generated HTML docs.
-
- * tools/tcltk-man2html.tcl (remap_link_target): More complete set of
- definitions of link targets, especially for major C API types.
- * tools/tcltk-man2html-utils.tcl (output-IP-list, cross-reference):
- Update to generation to produce proper HTML bulleted and enumerated
- lists.
-
-2011-07-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/upvar.n: Undocument long gone limitation of [upvar].
-
-2011-07-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump version number to 8.6b2.
- * library/init.tcl:
- * unix/configure.in:
- * win/configure.in:
- * unix/tcl.spec:
- * tools/tcl.wse.in:
- * README:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2011-07-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats() is
- called in a deleted interp.
-
- * generic/tclCompile.c: [Bug 467523, 3357771]: Prevent circular
- references in values with ByteCode intreps. They can lead to memory
- leaks.
-
-2011-07-14 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOCall.c (TclOORenderCallChain): [Bug 3365156]: Remove
- stray refcount bump that caused a memory leak.
-
-2011-07-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUnixSock.c: [Bug 3364777]: Stop segfault caused by
- reading from struct after it had been freed.
-
-2011-07-11 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclExecute.c: [Bug 3339502]: Correct cast for CURR_DEPTH to
- silence compiler warning.
-
-2011-07-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/http.n: [FRQ 3358415]: State what RFC defines HTTP/1.1.
-
-2011-07-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Add missing INT2PTR
-
-2011-07-03 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/FileSystem.3: Corrected statements about ctime field of 'struct
- stat'; that was always the time of the last metadata change, not the
- time of creation.
-
-2011-07-02 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c:
- * generic/tclTomMath.decls:
- * generic/tclTomMathDecls.h:
- * macosx/Tcl.xcode/project.pbxproj:
- * macosx/Tcl.xcodeproj/project.pbxproj:
- * tests/util.test:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/Makefile.vc:
- [Bug 3349507]: Fix a bug where bignum->double conversion is "round up"
- and not "round to nearest" (causing expr double(1[string repeat 0 23])
- not to be 1e+23).
-
-2011-06-28 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (CreateClientSocket): [Bug 3325339]: Fix and
- simplify posting of the writable fileevent at the end of an
- asynchronous connection attempt. Improve comments for some of the
- trickery around [socket -async].
-
- * tests/socket.test: Adjust tests to the async code changes. Add more
- tests for corner cases of async sockets.
-
-2011-06-22 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/pkgIndex.tcl: Updated to platform 1.0.10. Added
- * library/platform/platform.tcl: handling of the DEB_HOST_MULTIARCH
- * unix/Makefile.in: location change for libc.
- * win/Makefile.in:
-
- * generic/tclInt.h: Fixed the inadvertently committed disabling of
- stack checks, see my 2010-11-15 commit.
-
-2011-06-22 Reinhard Max <max@suse.de>
-
- Merge from rmax-ipv6-branch:
- * unix/tclUnixSock.c: Fix [socket -async], so that all addresses
- returned by getaddrinfo() are tried, not just the first one. This
- requires the event loop to be running while the async connection is in
- progress. ***POTENTIAL INCOMPATIBILITY***
- * tests/socket.test: Add a test for the above.
- * doc/socket: Document the fact that -async needs the event loop
- * generic/tclIOSock.c: AI_ADDRCONFIG is broken on HP-UX
-
-2011-06-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclLink.c: [Bug 3317466]: Prevent multiple links to a
- single Tcl variable when calling Tcl_LinkVar().
-
-2011-06-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStrToD.c: [Bug 3315098]: Mem leak fix from Gustaf
- Neumann.
-
-2011-06-08 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclExecute.c: Reverted the fix for [Bug 3274728] committed
- on 2011-04-06 and replaced with one which is 64bit-safe. The existing
- fix crashed tclsh on Windows 64bit.
-
-2011-06-08 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/fileSystem.test: Reduce the amount of use of duplication of
- complex code to perform common tests, and convert others to do the
- test result check directly using Tcltest's own primitives.
-
-2011-06-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tests/socket.test: Add test constraint, so 6.2 and 6.3 don't fail
- when the machine does not have support for ip6. Follow-up to checkin
- from 2011-05-11 by rmax.
-
-2011-06-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Removed TclCleanupLiteralTable(), and old
- * generic/tclInt.h: band-aid routine put in place while a fix for
- * generic/tclLiteral.c: [Bug 994838] took shape. No longer needed.
-
-2011-06-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h (TclInvalidateNsCmdLookup): [Bug 3185407]: Extend
- the set of epochs that are potentially bumped when a command is
- created, for a slight performance drop (in some circumstances) and
- improved semantics.
-
-2011-06-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Using the two free data elements in NRCommand to
- store objc and objv - useful for debugging.
-
-2011-06-01 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUtil.c: Fix for [Bug 3309871]: Valgrind finds: invalid
- read in TclMaxListLength().
-
-2011-05-31 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Use a complete growth algorithm for lists so
- * generic/tclListObj.c: that length limits do not overconstrain by a
- * generic/tclStringObj.c: factor of 2. [Bug 3293874]: Fix includes
- * generic/tclUtil.c: rooting all growth routines by default on a
- common tunable parameter TCL_MIN_GROWTH.
-
-2011-05-25 Don Porter <dgp@users.sourceforge.net>
-
- * library/msgcat/msgcat.tcl: Bump to msgcat 1.4.4.
- * library/msgcat/pkgIndex.tcl:
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2011-05-25 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.h (TCLOO_VERSION): Bump version.
-
- IMPLEMENTATION OF TIP#381.
-
- * doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c,
- * generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c,
- * generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added
- introspection of call chains ([self call], [info object call], [info
- class call]) and ability to skip ahead in chain ([nextto]).
-
-2011-05-24 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/Africa/Cairo: Update to Olson tzdata2011g
-
-2011-05-24 Donal K. Fellows <dkf@users.sf.net>
-
- * library/msgcat/msgcat.tcl (msgcat::mcset, msgcat::mcmset): Remove
- some useless code; [dict set] builds dictionary levels for us.
-
-2011-05-17 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed
- * generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation of
- my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter. When a
- bytecode was grown during jump fixup the pc -> command line mapping
- was not updated. When things aligned just wrong the mapping would
- direct command A to the data for command B, with a different number of
- arguments.
-
-2011-05-11 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (TcpWatchProc): No need to check for server
- sockets here, as the generic server code already takes care of that.
- * tests/socket.test (accept): Add tests to make sure that this remains
- so.
-
-2011-05-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: New internal routines TclScanElement() and
- * generic/tclUtil.c: TclConvertElement() are rewritten guts of
- machinery to produce string rep of lists. The new routines avoid and
- correct [Bug 3173086]. See comments for much more detail.
-
- * generic/tclDictObj.c: Update all callers.
- * generic/tclIndexObj.c:
- * generic/tclListObj.c:
- * generic/tclUtil.c:
- * tests/list.test:
-
-2011-05-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (NamespacePathCmd): Convert to use Tcl_Obj API
- * generic/tclPkg.c (Tcl_PackageObjCmd): for result generation in
- * generic/tclTimer.c (Tcl_AfterObjCmd): [after info], [namespace
- path] and [package versions].
-
-2011-05-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclListObj.c: Revise empty string tests so that we avoid
- potentially expensive string rep generations, especially for dicts.
-
-2011-05-07 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclLoad.c (TclGetLoadedPackages): Convert to use Tcl_Obj API
- for result generation.
-
-2011-05-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h: Fix USE_TCLALLOC so that it can be enabled without
- * unix/Makefile.in: editing the Makefile.
-
-2011-05-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclListObj.c: Stop generating string rep of dict when
- converting to list. Tolerate NULL interps more completely.
-
-2011-05-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: Tighten Tcl_SplitList().
- * generic/tclListObj.c: Tighten SetListFromAny().
- * generic/tclDictObj.c: Tighten SetDictFromAny().
- * tests/join.test:
- * tests/mathop.test:
-
-2011-05-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: Revised TclFindElement() interface. The final
- * generic/tclDictObj.c: argument had been bracePtr, the address of a
- * generic/tclListObj.c: boolean var, where the caller can be told
- * generic/tclParse.c: whether or not the parsed list element was
- * generic/tclUtil.c: enclosed in braces. In practice, no callers
- really care about that. What the callers really want to know is
- whether the list element value exists as a literal substring of the
- string being parsed, or whether a call to TclCopyAndCollpase() is
- needed to produce the list element value. Now the final argument is
- changed to do what callers actually need. This is a better fit for the
- calls in tclParse.c, where now a good deal of post-processing checking
- for "naked backslashes" is no longer necessary.
- ***POTENTIAL INCOMPATIBILITY***
- For any callers calling in via the internal stubs table who really do
- use the final argument explicitly to check for the enclosing brace
- scenario. Simply looking for the braces where they must be is the
- revision available to those callers, and it will backport cleanly.
-
- * tests/parse.test: Tests for expanded literals quoting detection.
-
- * generic/tclCompCmdsSZ.c: New TclFindElement() is also a better
- fit for the [switch] compiler.
-
- * generic/tclInt.h: Replace TclCountSpaceRuns() with
- * generic/tclListObj.c: TclMaxListLength() which is the function we
- * generic/tclUtil.c: actually want.
- * generic/tclCompCmdsSZ.c:
-
- * generic/tclCompCmdsSZ.c: Rewrite of parts of the switch compiler to
- better use the powers of TclFindElement() and do less parsing on its
- own.
-
-2011-04-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: New utility routines:
- * generic/tclParse.c: TclIsSpaceProc() and TclCountSpaceRuns()
- * generic/tclUtil.c:
-
- * generic/tclCmdMZ.c: Use new routines to replace calls to isspace()
- * generic/tclListObj.c: and their /* INTL */ risk.
- * generic/tclStrToD.c:
- * generic/tclUtf.c:
- * unix/tclUnixFile.c:
-
- * generic/tclStringObj.c: Improved reaction to out of memory.
-
-2011-04-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: TclFreeIntRep() correction & cleanup.
- * generic/tclExecute.c:
- * generic/tclIndexObj.c:
- * generic/tclInt.h:
- * generic/tclListObj.c:
- * generic/tclNamesp.c:
- * generic/tclResult.c:
- * generic/tclStringObj.c:
- * generic/tclVar.c:
-
- * generic/tclListObj.c: FreeListInternalRep() cleanup.
-
-2011-04-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Use macro to set List intreps.
- * generic/tclListObj.c:
-
- * generic/tclCmdIL.c: Limits on list length were too strict.
- * generic/tclInt.h: Revised panics to errors where possible.
- * generic/tclListObj.c:
- * tests/lrepeat.test:
-
- * generic/tclCompile.c: Make sure SetFooFromAny routines react
- * generic/tclIO.c: reasonably when passed a NULL interp.
- * generic/tclIndexObj.c:
- * generic/tclListObj.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * macosx/tclMacOSXFCmd.c:
-
-2011-04-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf
- * generic/tclInt.h: used on MinGW. Make sure that all _WIN32
- * win/tclWinFile.c: compilers use exactly the same layout
- * win/configure.in: for Tcl_StatBuf - the one used by MSVC6 -
- * win/configure: in all situations.
-
-2011-04-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclConfig.c: Reduce internals access in the implementation
- of [<foo>::pkgconfig list].
-
-2011-04-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdIL.c: Use ListRepPtr(.) and other cleanup.
- * generic/tclConfig.c:
- * generic/tclListObj.c:
-
- * generic/tclInt.h: Define and use macros that test whether a Tcl
- * generic/tclBasic.c: list value is canonical.
- * generic/tclUtil.c:
-
-2011-04-18 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: [Bug 3288696]: Command summary was confusingly wrong
- when it came to [dict filter] with a 'value' filter.
-
-2011-04-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclFCmd.c (TclFileAttrsCmd): Add comments to make this code
- easier to understand. Added a panic to handle the case where the VFS
- layer does something odd.
-
-2011-04-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: [Bug 3285375]: Rewrite of Tcl_Concat*()
- routines to prevent segfaults on buffer overflow. Build them out of
- existing primitives already coded to handle overflow properly. Uses
- the new TclTrim*() routines.
-
- * generic/tclCmdMZ.c: New internal utility routines TclTrimLeft()
- * generic/tclInt.h: and TclTrimRight(). Refactor the
- * generic/tclUtil.c: [string trim*] implementations to use them.
-
-2011-04-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a
- variable with a write trace that unsets it.
-
-2011-04-13 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclUtil.c (Tcl_ConcatObj): [Bug 3285375]: Make the crash
- less mysterious through the judicious use of a panic. Not yet properly
- fixed, but at least now clearer what the failure mode is.
-
-2011-04-12 Don Porter <dgp@users.sourceforge.net>
-
- * tests/string.test: Test for [Bug 3285472]. Not buggy in trunk.
-
-2011-04-12 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/Atlantic/Stanley: Update to Olson tzdata2011f
-
-2011-04-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Fix for [Bug 2440625], kbk's patch
-
-2011-04-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * tests/coroutine.test: [Bug 3282869]: Ensure that 'coroutine eval'
- runs the initial command in the proper context.
-
-2011-04-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Fix for [Bug 3281728]: Tcl sources from 2011-04-06
- * unix/tcl.m4: do not build on GCC9 (RH9)
- * unix/configure:
-
-2011-04-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Fix for [Bug 3280043]: win2k: unresolved DLL
- * win/configure.in: imports.
- * win/configure
-
-2011-04-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclCompileObj): Earlier return if Tip280
- gymnastics not needed.
-
- * generic/tclExecute.c: Fix for [Bug 3274728]: making *catchTop an
- unsigned long.
-
-2011-04-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclAppInit.c: Make symbols "main" and "Tcl_AppInit"
- MODULE_SCOPE: there is absolutely no reason for exporting them.
- * unix/tcl.m4: Don't use -fvisibility=hidden with static
- * unix/configure libraries (--disable-shared)
-
-2011-04-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclFCmd.c, macosx/tclMacOSXFCmd.c, unix/tclUnixChan.c,
- * unix/tclUnixFCmd.c, win/tclWinChan.c, win/tclWinDde.c,
- * win/tclWinFCmd.c, win/tclWinLoad.c, win/tclWinPipe.c,
- * win/tclWinReg.c, win/tclWinSerial.c, win/tclWinSock.c: More
- generation of error codes (most platform-specific parts not already
- using Tcl_PosixError).
-
-2011-04-05 Venkat Iyer <venkat@comit.com>
-
- * library/tzdata/Africa/Casablanca: Update to Olson's tzdata2011e
- * library/tzdata/America/Santiago:
- * library/tzdata/Pacific/Easter:
- * library/tzdata/America/Metlakatla: (new)
- * library/tzdata/America/North_Dakota/Beulah: (new)
- * library/tzdata/America/Sitka: (new)
-
-2011-04-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c, generic/tclOOBasic.c, generic/tclOODefineCmds.c
- * generic/tclOOInfo.c, generic/tclOOMethod.c: More generation of
- error codes (TclOO miscellany).
-
- * generic/tclCmdAH.c, generic/tclCmdIL.c: More generation of error
- codes (miscellaneous commands mostly already handled).
-
-2011-04-04 Don Porter <dgp@users.sourceforge.net>
-
- * README: [Bug 3202030]: Updated README files, repairing broken
- * macosx/README:URLs and removing other bits that were clearly wrong.
- * unix/README: Still could use more eyeballs on the detailed build
- * win/README: advice on various plaforms.
-
-2011-04-04 Donal K. Fellows <dkf@users.sf.net>
-
- * library/init.tcl (tcl::mathfunc::rmmadwiw): Disable by default to
- make test suite work.
-
- * generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c,
- * generic/tclTrace.c, generic/tclUtil.c: More generation of error
- codes ([format], [after], [trace], RE optimizer).
-
-2011-04-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCmdAH.c: Better error-message in case of errors
- * generic/tclCmdIL.c: related to setting a variable. This fixes
- * generic/tclDictObj.c: a warning: "Why make your own error
- * generic/tclScan.c: message? Why?"
- * generic/tclTest.c:
- * test/error.test:
- * test/info.test:
- * test/scan.test:
- * unix/tclUnixThrd.h: Remove this unused header file.
-
-2011-04-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c:
- * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c:
- * generic/tclScan.c: More generation of error codes (namespace
- creation, path normalization, pipeline creation, package handling,
- procedures, [scan] formats)
-
-2011-04-02 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (QuickConversion): Replaced another couple
- of 'double' declarations with 'volatile double' to work around
- misrounding issues in mingw-gcc 3.4.5.
-
-2011-04-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c:
- More generation of errorCodes ([interp], [lset], [load], [unload]).
-
- * generic/tclEvent.c, generic/tclFileName.c: More generation of
- errorCode information (default [bgerror] and [glob]).
-
-2011-04-01 Reinhard Max <max@suse.de>
-
- * library/init.tcl: TIP#131 implementation.
-
-2011-03-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd):
- More generation of errorCode information.
-
-2011-03-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More
- generation of errorCode information, notably when lists are mis-parsed
-
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the
- error messages generated by the variable management code rather than
- creating our own.
-
-2011-03-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably
- apparent in tclbench's "LIST lset foreach". Many thanks to Twylite for
- patiently researching the issue and explaining it to me: a missing
- Tcl_ResetObjResult that causes unwanted sharing of the current result
- Tcl_Obj.
-
-2011-03-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More
- generation of errorCode information.
-
- * generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c:
- * generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c:
- * generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of
- casts used to manage Tcl_Obj internal representations.
-
-2011-03-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory
- allocation and free macros.
-
-2011-03-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to
- temporary index tables is squelched immediately rather than hanging
- around to trip us up in the future.
-
-2011-03-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclObj.c: Exploit HAVE_FAST_TSD for the deletion context in
- TclFreeObj()
-
-2011-03-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclThreadAlloc.c: Simpler initialization of Cache under
- HAVE_FAST_TSD, from mig-alloc-reform.
-
-2011-03-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclLoadDl.c: [Bug 3216070]: Loading extension libraries
- * unix/tclLoadDyld.c: from embedded Tcl applications.
- ***POTENTIAL INCOMPATIBILITY***
- For extensions which rely on symbols from other extensions being
- present in the global symbol table. For an example and some discussion
- of workarounds, see http://stackoverflow.com/q/8330614/301832
-
-2011-03-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCkAlloc.c:
- * generic/tclInt.h: Remove one level of allocator indirection in
- non-memdebug builds, imported from mig-alloc-reform.
-
-2011-03-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclThreadAlloc.c: Imported HAVE_FAST_TSD support from
- mig-alloc-reform. The feature has to be enabled by hand: no autoconf
- support has been added. It is not clear how universal a build using
- this will be: it also requires some loader support.
-
-2011-03-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompExpr.c (ParseExpr): Generate errorCode information on
- failure to parse expressions.
-
-2011-03-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclMain.c: [Patch 3124683]: Reorganize the platform-specific
- stuff in (tcl|tk)Main.c.
-
-2011-03-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCkalloc.c: [Bug 3197864]: Pointer truncation on Win64
- TCL_MEM_DEBUG builds.
-
-2011-03-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Some rewrites to eliminate calls to isspace()
- * generic/tclParse.c: and their /* INTL */ risk.
- * generic/tclProc.c:
-
-2011-03-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Make SHLIB_LD_LIBS='${LIBS}' the default and
- * unix/configure: set to "" on per-platform necessary basis.
- Backported from TEA, but kept all original platform code which was
- removed from TEA.
-
-2011-03-14 Kevin B. Kenny <kennykb@acm.org>
-
- * tools/tclZIC.tcl (onDayOfMonth): Allow for leading zeroes in month
- and day so that tzdata2011d parses correctly.
- * library/tzdata/America/Havana:
- * library/tzdata/America/Juneau:
- * library/tzdata/America/Santiago:
- * library/tzdata/Europe/Istanbul:
- * library/tzdata/Pacific/Apia:
- * library/tzdata/Pacific/Easter:
- * library/tzdata/Pacific/Honolulu: tzdata2011d
-
- * generic/tclAssembly.c (BBEmitInstInt1): Changed parameter data types
- in an effort to silence a MSVC warning reported by Ashok P. Nadkarni.
- Unable to test, since both forms work on my machine in VC2005, 2008,
- 2010, in both release and debug builds.
- * tests/tclTest.c (TestdstringCmd): Restored MSVC buildability broken
- by [5574bdd262], which changed the effective return type of 'ckalloc'
- from 'char*' to 'void*'.
-
-2011-03-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: remove TEBCreturn()
-
-2011-03-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.h (ckalloc,ckfree,ckrealloc): Moved casts into these
- macro so that they work with VOID* (which is a void* on all platforms
- which Tcl actually builds on) and unsigned int for the length
- parameters, removing the need for MANY casts across the rest of Tcl.
- Note that this is a strict source-level-only change, so size_t cannot
- be used (would break binary compatibility on 64-bit platforms).
-
-2011-03-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: [Bug 3185609]: File normalization corner case
- of ... broken with -DUNICODE
-
-2011-03-11 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/unixInit.test: Make better use of tcltest2.
-
-2011-03-10 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c, generic/tclCompCmds.c, generic/tclEnsemble.c:
- * generic/tclInt.h, generic/tclNamesp.c, library/auto.tcl:
- * tests/interp.test, tests/namespace.test, tests/nre.test:
- Converted the [namespace] command into an ensemble. This has the
- consequence of making it vital for Tcl code that wishes to work with
- namespaces to _not_ delete the ::tcl namespace.
- ***POTENTIAL INCOMPATIBILITY***
-
- * library/tcltest/tcltest.tcl (loadIntoSlaveInterpreter): Added this
- command to handle connecting tcltest to a slave interpreter. This adds
- in the hook (inside the tcltest namespace) that allows the tests run
- in the child interpreter to be reported as part of the main sequence
- of test results. Bumped version of tcltest to 2.3.3.
- * tests/init.test, tests/package.test: Adapted these test files to use
- the new feature.
-
- * generic/tclAlloc.c, generic/tclCmdMZ.c, generic/tclCompExpr.c:
- * generic/tclCompile.c, generic/tclEnv.c, generic/tclEvent.c:
- * generic/tclIO.c, generic/tclIOCmd.c, generic/tclIORChan.c:
- * generic/tclIORTrans.c, generic/tclLiteral.c, generic/tclNotify.c:
- * generic/tclParse.c, generic/tclStringObj.c, generic/tclUtil.c:
- * generic/tclZlib.c, unix/tclUnixFCmd.c, unix/tclUnixNotfy.c:
- * unix/tclUnixPort.h, unix/tclXtNotify.c: Formatting fixes, mainly to
- comments, so code better fits the style in the Engineering Manual.
-
-2011-03-09 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/incr.test: Update more of the test suite to use Tcltest 2.
-
-2011-03-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c: [Bug 3202171]: Tighten the detector of nested
- * tests/namespace.test: [namespace code] quoting that the quoted
- scripts function properly even in a namespace that contains a custom
- "namespace" command.
-
- * doc/tclvars.n: Formatting fix. Thanks to Pat Thotys.
-
-2011-03-09 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/dstring.test, tests/init.test, tests/link.test: Update more of
- the test suite to use Tcltest 2.
-
-2011-03-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBasic.c: Fix gcc warnings: variable set but not used
- * generic/tclProc.c:
- * generic/tclIORChan.c:
- * generic/tclIORTrans.c:
- * generic/tclAssembly.c: Fix gcc warning: comparison between signed
- and unsigned integer expressions
-
-2011-03-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Remove TclMarkList() routine, an experimental
- * generic/tclUtil.c: dead-end from the 8.5 alpha days.
-
- * generic/tclResult.c (ResetObjResult): [Bug 3202905]: Correct failure
- to clear invalid intrep. Thanks to Colin McDonald.
-
-2011-03-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclAssembly.c, tests/assemble.test: Migrate to use a style
- more consistent with the rest of Tcl.
-
-2011-03-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: More replacements of Tcl_UtfBackslash() calls
- * generic/tclCompile.c: with TclParseBackslash() where possible.
- * generic/tclCompCmdsSZ.c:
- * generic/tclParse.c:
- * generic/tclUtil.c:
-
- * generic/tclUtil.c (TclFindElement): [Bug 3192636]: Guard escape
- sequence scans to not overrun the string end.
-
-2011-03-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c (TclParseBackslash): [Bug 3200987]: Correct
- * tests/parse.test: trunction checks in \x and \u substitutions.
-
-2011-03-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclStackFree): insure that the execStack
- satisfies "at most one free stack after the current one" when
- consecutive reallocs caused the creation of intervening stacks.
-
-2011-03-05 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclAssembly.c (new file):
- * generic/tclBasic.c (Tcl_CreateInterp):
- * generic/tclInt.h:
- * tests/assemble.test (new file):
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: Merged dogeen-assembler-branch into HEAD. Since
- all functional changes are in the tcl::unsupported namespace, there's
- no reason to sequester this code on a separate branch.
-
-2011-03-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Cleaner mem management for TEBCdata
-
- * generic/tclExecute.c:
- * tests/nre.test: Renamed BottomData to TEBCdata, so that the name
- refers to what it is rather than to its storage location.
-
- * generic/tclBasic.c: Renamed struct TEOV_callback to the more
- * generic/tclCompExpr.c: descriptive NRE_callback.
- * generic/tclCompile.c:
- * generic/tclExecute.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclTest.c:
-
-2011-03-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect)
- (ProcedureMethodCompiledVarDelete): [Bug 3185009]: Keep references to
- resolved object variables so that an unset doesn't leave any dangling
- pointers for code to trip over.
-
-2011-03-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclNREvalObjv): Missing a variable declaration
- in commented out non-optimised code, left for ref in checkin
- [b97b771b6d]
-
-2011-03-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c (Tcl_AppendResultVA): Use the directive
- USE_INTERP_RESULT [TIP 330] to force compat with interp->result
- access, instead of the improvised hack USE_DIRECT_INTERP_RESULT_ACCESS
- from releases past.
-
-2011-03-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (TclCompileThrowCmd, TclCompileUnsetCmd):
- fix leaks
-
- * generic/tclBasic.c: This is [Patch 3168398],
- * generic/tclCompCmdsSZ.c: Joe Mistachkin's optimisation
- * generic/tclExecute.c: of Tip #285
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclInterp.c:
- * generic/tclOODecls.h:
- * generic/tclStubInit.c:
- * win/makefile.vc:
-
- * generic/tclExecute.c (ExprObjCallback): Fix object leak
-
- * generic/tclExecute.c (TEBCresume): Store local var array and
- constants in automatic vars to reduce indirection, slight perf
- increase
-
- * generic/tclOOCall.c (TclOODeleteContext): Added missing '*' so that
- trunk compiles.
-
- * generic/tclBasic.c (TclNRRunCallbacks): [Patch 3168229]: Don't do
- the trampoline dance for commands that do not have an nreProc.
-
-2011-03-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance)
- (TclOOObjectCmdCore, FinalizeObjectCall):
- * generic/tclOOBasic.c (TclOO_Object_Destroy, AfterNRDestructor):
- * generic/tclOOCall.c (TclOODeleteContext, TclOOGetCallContext):
- Reorganization of call context reference count management so that code
- is (mostly) simpler.
-
-2011-01-26 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/RegExp.3: [Bug 3165108]: Corrected documentation of description
- of subexpression info in Tcl_RegExpInfo structure.
-
-2011-01-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPreserve.c: Don't miss 64-bit address bits in panic
- message.
- * win/tclWinChan.c: Fix various gcc-4.5.2 64-bit warning
- * win/tclWinConsole.c: messages, e.g. by using full 64-bits for
- * win/tclWinDde.c: socket fd's
- * win/tclWinPipe.c:
- * win/tclWinReg.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
- * win/tclWinThrd.c:
-
-2011-01-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: [FRQ 3159920]: Tcl_ObjPrintf() crashes with
- * generic/tcl.decls bad format specifier.
- * generic/tcl.h:
- * generic/tclDecls.h:
-
-2011-01-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (PushMethodCallFrame): [Bug 3001438]: Make
- sure that the cmdPtr field of the procPtr is correct and relevant at
- all times so that [info frame] can report sensible information about a
- frame after a return to it from a recursive call, instead of probably
- crashing (depending on what else has overwritten the Tcl stack!)
-
-2011-01-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBasic.c: Various mismatches between Tcl_Panic
- * generic/tclCompCmds.c: format string and its arguments,
- * generic/tclCompCmdsSZ.c: discovered thanks to [Bug 3159920]
- * generic/tclCompExpr.c:
- * generic/tclEnsemble.c:
- * generic/tclPreserve.c:
- * generic/tclTest.c:
-
-2011-01-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIOCmd.c: [Bug 3148192]: Commands "read/puts" incorrectly
- * tests/chanio.test: interpret parameters. Improved error-message
- * tests/io.test regarding legacy form.
- * tests/ioCmd.test
-
-2011-01-15 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/tclvars.n:
- * generic/tclStrToD.c:
- * generic/tclUtil.c (Tcl_PrintDouble):
- * tests/util.test (util-16.*): [Bug 3157475]: Restored full Tcl 8.4
- compatibility for the formatting of floating point numbers when
- $::tcl_precision is not zero. Added compatibility tests to make sure
- that excess trailing zeroes are suppressed for all eight major code
- paths.
-
-2011-01-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: Use _vsnprintf in stead of vsnprintf, because
- MSVC 6 doesn't have it. Reported by andreask.
- * win/tcl.m4: handle --enable-64bit=ia64 for gcc
- * win/configure.in: more accurate test for correct <intrin.h>
- * win/configure: (autoconf-2.59)
- * win/tclWin32Dll.c: VS 2005 64-bit does not have intrin.h, and
- * generic/tclPanic.c: does not need it.
-
-2011-01-07 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/util.test (util-15.*): Added test cases for floating point
- conversion of the largest denormal and the smallest normal number, to
- avoid any possibility of the failure suffered by PHP in the last
- couple of days. (They didn't fail, so no actual functional change.)
-
-2011-01-05 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/package.test, tests/pkg.test: Coalesce these tests into one
- file that is concerned with the package system. Convert to use
- tcltest2 properly.
- * tests/autoMkindex.test, tests/pkgMkIndex.test: Convert to use
- tcltest2 properly.
-
-2011-01-01 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/cmdAH.test, tests/cmdMZ.test, tests/compExpr.test,
- * tests/compile.test, tests/concat.test, tests/eval.test,
- * tests/fileName.test, tests/fileSystem.test, tests/interp.test,
- * tests/lsearch.test, tests/namespace-old.test, tests/namespace.test,
- * tests/oo.test, tests/proc.test, tests/security.test,
- * tests/switch.test, tests/unixInit.test, tests/var.test,
- * tests/winDde.test, tests/winPipe.test: Clean up of tests and
- conversion to tcltest 2. Target has been to get init and cleanup code
- out of the test body and into the -setup/-cleanup stanzas.
-
- * tests/execute.test (execute-11.1): [Bug 3142026]: Added test that
- fails (with a crash) in an unfixed memdebug build on 64-bit systems.
-
-2010-12-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (SortElement): Use unions properly in the
- definition of this structure so that there is no need to use nasty
- int/pointer type punning. Made it clearer what the purposes of the
- various parts of the structure are.
-
-2010-12-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/dltest/*.c: [Bug 3148192]: Fix broken [load] tests by ensuring
- that the affected files are never compiled with -DSTATIC_BUILD.
-
-2010-12-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (GrowEvaluationStack): Off-by-one error in
- sizing the new allocation - was ok in comment but wrong in the code.
- Triggered by [Bug 3142026] which happened to require exactly one more
- than what was in existence.
-
-2010-12-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fix crash when multiple -index
- options are used. Simplified memory handling logic.
-
-2010-12-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1
- tdm64-1: completed for all environments.
-
-2010-12-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/configure.in: Explicitely test for intrinsics support in
- compiler, before assuming only MSVC has it.
- * win/configure: (autoconf-2.59)
- * generic/tclPanic.c:
-
-2010-12-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWin32Dll.c: [Patch 3059922]: fixes for mingw64 - gcc4.5.1
- tdm64-1: Fixed for gcc, not yet for MSVC 64-bit.
-
-2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/Makefile.in: Remove unwanted/obsolete 'ddd' target.
-
-2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/Makefile.in: Clean up '.PHONY:' targets: Arrange those
- common to Tcl and Tk as in Tk's Makefile.in,
- add any missing ones and remove duplicates.
-
-2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/Makefile.in: [Bug 2446711]: Remove 'allpatch' target.
-
-2010-12-17 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/Makefile.in: [Bug 2537626]: Use 'rpmbuild', not 'rpm'.
-
-2010-12-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPanic.c: [Patch 3124554]: Move WishPanic from Tk to Tcl
- * win/tclWinFile.c: Better communication with debugger, if present.
-
-2010-12-15 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tclAssembly.c:
- * assemble.test: Reworked beginCatch/endCatch handling to
- enforce the more severe (but more correct) restrictions on catch
- handling that appeared in the discussion of [Bug 3098302] and in
- tcl-core traffic beginning about 2010-10-29.
-
-2010-12-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPanic.c: Restore abort() as it was before.
- * win/tclWinFile.c: [Patch 3124554]: Use ExitProcess() here, like
- in wish.
-
-2010-12-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3137454]: Tcl CVS HEAD does not build on GCC 3.
-
-2010-12-14 Reinhard Max <max@suse.de>
-
- * win/tclWinSock.c (CreateSocket): Swap the loops over
- * unix/tclUnixSock.c (CreateClientSocket): local and remote addresses,
- so that the system's address preference for the remote side decides
- which family gets tried first. Cleanup and clarify some of the
- comments.
-
-2010-12-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3135271]: Link error due to hidden
- * unix/tcl.m4: symbols (CentOS 4.2)
- * unix/configure: (autoconf-2.59)
- * win/tclWinFile.c: Undocumented feature, only meant to be used by
- Tk_Main. See [Patch 3124554]: Move WishPanic from Tk to Tcl
-
-2010-12-12 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/tcl.m4: Better building on OpenBSD.
- * unix/configure: (autoconf-2.59)
-
-2010-12-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 3129448]: Possible over-allocation on
- * generic/tclCkalloc.c: 64-bit platforms, part 2
- * generic/tclCompile.c:
- * generic/tclHash.c:
- * generic/tclInt.h:
- * generic/tclIO.h:
- * generic/tclProc.c:
-
-2010-12-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: Make sure [fcopy -size ... -command ...] always
- * tests/io.test: calls the callback asynchronously, even for size
- zero.
-
-2010-12-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBinary.c: Fix gcc -Wextra warning: missing initializer
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclDictObj.c:
- * generic/tclIndexObj.c:
- * generic/tclIOCmd.c:
- * generic/tclVar.c:
- * win/tcl.m4: Fix manifest-generation for 64-bit gcc
- (mingw-w64)
- * win/configure.in: Check for availability of intptr_t and
- uintptr_t
- * win/configure: (autoconf-2.59)
- * generic/tclInt.decls: Change 1st param of TclSockMinimumBuffers
- * generic/tclIntDecls.h: to ClientData, and TclWin(Get|Set)SockOpt
- * generic/tclIntPlatDecls.h:to SOCKET, because on Win64 those are
- * generic/tclIOSock.c: 64-bit, which does not fit.
- * win/tclWinSock.c:
- * unix/tclUnixSock.c:
-
-2010-12-09 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/fCmd.test: Improve sanity of constraints now that we don't
- support anything before Windows 2000.
-
- * generic/tclCmdAH.c (TclInitFileCmd, TclMakeFileCommandSafe, ...):
- Break up [file] into an ensemble. Note that the ensemble is safe in
- itself, but the majority of its subcommands are not.
- * generic/tclFCmd.c (FileCopyRename,TclFileDeleteCmd,TclFileAttrsCmd)
- (TclFileMakeDirsCmd): Adjust these subcommand implementations to work
- inside an ensemble.
- (TclFileLinkCmd, TclFileReadLinkCmd, TclFileTemporaryCmd): Move these
- subcommand implementations from tclCmdAH.c, where they didn't really
- belong.
- * generic/tclIOCmd.c (TclChannelNamesCmd): Move to more appropriate
- source file.
- * generic/tclEnsemble.c (TclMakeEnsemble): Start of code to make
- partially-safe ensembles. Currently does not function as expected due
- to various shortcomings in how safe interpreters are constructed.
- * tests/cmdAH.test, tests/fCmd.test, tests/interp.test: Test updates
- to take into account systematization of error messages.
-
- * tests/append.test, tests/appendComp.test: Clean up tests so that
- they don't leave things in the global environment (detected when doing
- -singleproc testing).
-
-2010-12-07 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/fCmd.test, tests/safe.test, tests/uplevel.test,
- * tests/upvar.test, tests/var.test: Convert more tests to tcltest2 and
- factor them to be easier to understand.
-
- * generic/tclStrToD.c: Tidy up code so that more #ifdef-fery is
- quarantined at the front of the file and function headers follow the
- modern Tcl style.
-
-2010-12-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBinary.c: [Bug 3129448]: Possible over-allocation on
- * generic/tclCkalloc.c: 64-bit platforms.
- * generic/tclTrace.c:
-
-2010-12-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: [Patch 3116490]: Cross-compile support for unix
- * unix/configure: (autoconf-2.59)
-
-2010-12-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (TclReToGlob): Add extra check for multiple inner
- *s that leads to poor recursive glob matching, defer to original RE
- instead. tclbench RE var backtrack.
-
-2010-12-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclUtil.c: Silence gcc warning when using -Wwrite-strings
- * generic/tclStrToD.c: Silence gcc warning for non-IEEE platforms
- * win/Makefile.in: [Patch 3116490]: Cross-compile Tcl mingw32 on unix
- * win/tcl.m4: This makes it possible to cross-compile Tcl/Tk for
- * win/configure.in: Windows (either 32-bit or 64-bit) out-of-the-box
- * win/configure: on UNIX, using mingw-w64 build tools (If Itcl,
- tdbc and Thread take over the latest tcl.m4, they can do that too).
-
-2010-12-01 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (SetPrecisionLimits, TclDoubleDigits):
- [Bug 3124675]: Added meaningless initialization of 'i', 'ilim' and
- 'ilim1' to silence warnings from the C compiler about possible use of
- uninitialized variables, Added a panic to the 'switch' that assigns
- them, to assert that the 'default' case is impossible.
-
-2010-12-01 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBasic.c: Fix gcc 64-bit warnings: cast from pointer to
- * generic/tclHash.c: integer of different size.
- * generic/tclTest.c:
- * generic/tclThreadTest.c:
- * generic/tclStrToD.c: Fix gcc(-4.5.2) warning: 'static' is not at
- beginning of declaration.
- * generic/tclPanic.c: Allow Tcl_Panic() to enter the debugger on win32
- * generic/tclCkalloc.c: Use Tcl_Panic() in stead of duplicating the
- code.
-
-2010-11-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.decls, generic/tclInt.h, generic/tclIntDecls.h:
- * generic/tclStubInit.c: TclFormatInt restored at slot 24
- * generic/tclUtil.c (TclFormatInt): restore TclFormatInt func from
- 2005-07-05 macro-ization. Benchmarks indicate it is faster, as a key
- int->string routine (e.g. int-indexed arrays).
-
-2010-11-29 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclBasic.c: Patch by Miguel, providing a
- [::tcl::unsupported::inject coroname command args], which prepends
- ("injects") arbitrary code to a suspended coro's future resumption.
- Neat for debugging complex coros without heavy instrumentation.
-
-2010-11-29 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclStrToD.c:
- * generic/tclTest.c:
- * generic/tclTomMath.decls:
- * generic/tclUtil.c:
- * tests/util.test:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: Rewrite of Tcl_PrintDouble and TclDoubleDigits that
- (a) fixes a severe performance problem with floating point shimmering
- reported by Karl Lehenbauer, (b) allows TclDoubleDigits to generate
- the digit strings for 'e' and 'f' format, so that it can be used for
- tcl_precision != 0 (and possibly later for [format]), (c) fixes [Bug
- 3120139] by making TclPrintDouble inherently locale-independent, (d)
- adds test cases to util.test for correct rounding in difficult cases
- of TclDoubleDigits where fixed- precision results are requested. (e)
- adds test cases to util.test for the controversial aspects of [Bug
- 3105247]. As a side effect, two more modules from libtommath
- (bn_mp_set_int.c and bn_mp_init_set_int.c) are brought into the build,
- since the new code uses them.
-
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclTomMathDecls.h: Regenerated.
-
-2010-11-24 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/chanio.test, tests/iogt.test, tests/ioTrans.test: Convert more
- tests to tcltest2 and factor them to be easier to understand.
-
-2010-11-20 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/chanio.test: Converted many tests to tcltest2 by marking the
- setup and cleanup parts as such.
-
-2010-11-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWin32Dll.c: Fix gcc warnings: unused variable 'registration'
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
-
-2010-11-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclAppInit.c: [FRQ 491789]: "setargv() doesn't support a unicode
- cmdline" now implemented for cygwin and mingw32 too.
- * tests/main.test: No longer disable tests Tcl_Main-1.4 and 1.6 on
- Windows, because those now work on all supported platforms.
- * win/configure.in: Set NO_VIZ=1 when zlib is compiled in libtcl,
- this resolves compiler warnings in 64-bit and static builds.
- * win/configure (regenerated)
-
-2010-11-18 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/file.n: [Bug 3111298]: Typofix.
-
- * tests/oo.test: [Bug 3111059]: Added testing that neatly trapped this
- issue.
-
-2010-11-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c: [Bug 3111059]: Fix leak due to bad looping
- construct.
-
-2010-11-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tcl.m4: [FRQ 491789]: "setargv() doesn't support a unicode
- cmdline" now implemented for mingw-w64
- * win/configure (re-generated)
-
-2010-11-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclAppInit.c:Bring compilation under mingw-w64 a bit closer
- * win/cat.c: to reality. See for what's missing:
- * win/tcl.m4: <https://sourceforge.net/apps/trac/mingw-w64/wiki/Unicode%20apps>
- * win/configure: (re-generated)
- * win/tclWinPort.h: [Bug 3110161]: Extensions using TCHAR don't
- compile on VS2005 SP1
-
-2010-11-15 Andreas Kupries <andreask@activestate.com>
-
- * doc/interp.n: [Bug 3081184]: TIP #378.
- * doc/tclvars.n: Performance fix for TIP #280.
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclInterp.c:
- * tests/info.test:
- * tests/interp.test:
-
-2010-11-10 Andreas Kupries <andreask@activestate.com>
-
- * changes: Updates for 8.6b2 release.
-
-2010-11-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (ProcedureMethodVarResolver): [Bug 3105999]:
- * tests/oo.test: Make sure that resolver structures that are
- only temporarily needed get squelched.
-
-2010-11-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclMain.c: Thanks, Kevin, for the fix, but this how it was
- supposed to be (TCL_ASCII_MAIN is only supposed to be defined on
- WIN32).
-
-2010-11-05 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclMain.c: Added missing conditional on _WIN32 around code
- that messes around with the definition of _UNICODE, to correct a badly
- broken Unix build from Jan's last commit.
-
-2010-11-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: [FRQ 491789]: "setargv() doesn't support a
- * generic/tclMain.c: unicode cmdline" implemented for Tcl on MSVC++
- * doc/Tcl_Main.3:
- * win/tclAppInit.c:
- * win/makefile.vc:
- * win/Makefile.in:
- * win/tclWin32Dll.c: Eliminate minor MSVC warning TCHAR -> char
- conversion
-
-2010-11-04 Reinhard Max <max@suse.de>
-
- * tests/socket.test: Run the socket tests three times with the address
- family set to any, inet, and inet6 respectively. Use constraints to
- skip the tests if a family is found to be unsupported or not
- configured on the local machine. Adjust the tests to dynamically adapt
- to the address family that is being tested.
-
- Rework some of the tests to speed them up by avoiding (supposedly)
- unneeded [after]s.
-
-2010-11-04 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * unix/Makefile.in: [Patch 3101127]: Installer Improvements.
- * unix/install-sh:
-
-2010-11-04 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/error.test (error-19.13): Another variation on testing for
- issues in [try] compilation.
-
- * doc/Tcl.n (Variable substitution): [Bug 3099086]: Increase clarity
- of explanation of what characters are actually permitted in variable
- substitutions. Note that this does not constitute a change of
- behavior; it is just an improvement of explanation.
-
-2010-11-04 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6b2 release. (Thanks Andreas Kupries)
-
-2010-11-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFcmd.c: [FRQ 2965056]: Windows build with -DUNICODE
- * win/tclWinFile.c: (more clean-ups for pre-win2000 stuff)
- * win/tclWinReg.c:
-
-2010-11-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (TryPostBody): Ensure that errors when setting
- * tests/error.test (error-19.1[12]): message/opt capture variables get
- reflected properly to the caller.
-
-2010-11-03 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclCompCmds.c (TclCompileCatchCmd): [Bug 3098302]:
- * tests/compile.test (compile-3.6): Reworked the compilation of the
- [catch] command so as to avoid placing any code that might throw an
- exception (specifically, any initial substitutions or any stores to
- result or options variables) between the BEGIN_CATCH and END_CATCH but
- outside the exception range. Added a test case that panics on a stack
- smash if the change is not made.
-
-2010-11-01 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * library/safe.tcl: Improved handling of non-standard module path
- * tests/safe.test: lists, empty path lists in particular.
-
-2010-11-01 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Asia/Hong_Kong:
- * library/tzdata/Pacific/Apia:
- * library/tzdata/Pacific/Fiji: Olson's tzdata2010o.
-
-2010-10-29 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclTimer.c: [Bug 2905784]: Stop small [after]s from
- wasting CPU while keeping accuracy.
-
-2010-10-28 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
- * generic/tclAssembly.c:
- * tests/assembly.test (assemble-31.*): Added jump tables.
-
-2010-10-28 Don Porter <dgp@users.sourceforge.net>
-
- * tests/http.test: [Bug 3097490]: Make http-4.15 pass in
- isolation.
-
- * unix/tclUnixSock.c: [Bug 3093120]: Prevent calls of
- freeaddrinfo(NULL) which can crash some
- systems. Thanks Larry Virden.
-
-2010-10-26 Reinhard Max <max@suse.de>
-
- * Changelog.2008: Split off from Changelog.
- * generic/tclIOSock.c (TclCreateSocketAddress): The interp != NULL
- check is needed for ::tcl::unsupported::socketAF as well.
-
-2010-10-26 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixSock.c (TcpGetOptionProc): Prevent crash if interp is
- * win/tclWinSock.c (TcpGetOptionProc): NULL (a legal situation).
-
-2010-10-26 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (TcpGetOptionProc): Added support for
- ::tcl::unsupported::noReverseDNS, which if set to any value, prevents
- [fconfigure -sockname] and [fconfigure -peername] from doing
- reverse DNS queries.
-
-2010-10-24 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
- * generic/tclAssembly.c:
- * tests/assembly.test (assemble-17.15): Reworked branch handling so
- that forward branches can use jump1 (jumpTrue1, jumpFalse1). Added
- test cases that the forward branches will expand to jump4, jumpTrue4,
- jumpFalse4 when needed.
-
-2010-10-23 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
- * generic/tclAssembly.h (removed):
- Removed file that was included in only one
- source file.
- * generictclAssembly.c: Inlined tclAssembly.h.
-
-2010-10-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/info.n: [Patch 2995655]:
- * generic/tclBasic.c: Report inner contexts in [info errorstack]
- * generic/tclCompCmds.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * tests/error.test:
- * tests/result.test:
-
-2010-10-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictForCmd): Update the compilation
- * generic/tclCompile.c (tclInstructionTable): of [dict for] so that
- * generic/tclExecute.c (TEBCresume): it no longer makes any
- use of INST_DICT_DONE now that's not needed, and make it clearer in
- the implementation of the instruction that it's just a deprecated form
- of unset operation. Followup to my commit of 2010-10-16.
-
-2010-10-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (Tcl_ZlibStreamGet): [Bug 3081008]: Ensure that
- when a bytearray gets its internals entangled with zlib for more than
- a passing moment, that bytearray will never be shimmered away. This
- increases the amount of copying but is simple to get right, which is a
- reasonable trade-off.
-
- * generic/tclStringObj.c (Tcl_AppendObjToObj): Added some special
- cases so that most of the time when you build up a bytearray by
- appending, it actually ends up being a bytearray rather than
- shimmering back and forth to string.
-
- * tests/http11.test (check_crc): Use a simpler way to express the
- functionality of this procedure.
-
- * generic/tclZlib.c: Purge code that wrote to the object returned by
- Tcl_GetObjResult, as we don't want to do that anti-pattern no more.
-
-2010-10-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/uniParse.tcl: [Bug 3085863]: tclUniData was 9 years old;
- Ignore non-BMP characters and fix comment about UnicodeData.txt file.
- * generic/regcomp.c: Fix comment
- * tests/utf.test: Add some Unicode 6 testcases
-
-2010-10-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/info.n: Document [info errorstack] faithfully.
-
-2010-10-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (ReleaseDictIterator): Factored out the release
- of the bytecode-level dictionary iterator information so that the
- side-conditions on instruction issuing are simpler.
-
-2010-10-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/reg_locale.c: [Bug 3085863]: tclUniData 9 years old: Updated
- * generic/tclUniData.c: Unicode tables to latest UnicodeData.txt,
- * tools/uniParse.tcl: corresponding with Unicode 6.0 (except for
- out-of-range chars > 0xFFFF)
-
-2010-10-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Alternative fix for [Bugs 467523,983660] where
- * generic/tclExecute.c: sharing of empty scripts is allowed again.
-
-2010-10-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinThrd.h: (removed) because it is just empty en used nowhere
- * win/tcl.dsp
-
-2010-10-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/uniClass.tcl: Spacing and comments: let uniClass.tcl
- * generic/regc_locale.c: generation match better the current
- (hand-modified) regc_locale.c
- * tools/uniParse.tcl: Generate proper const qualifiers for
- * generic/tclUniData.c: tclUniData.c
-
-2010-10-12 Reinhard Max <max@suse.de>
-
- * unix/tclUnixSock.c (CreateClientSocket): [Bug 3084338]: Fix a
- memleak and refactor the calls to freeaddrinfo().
-
-2010-10-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: [FRQ 2965056]: Windows build with -DUNICODE
- * win/tclWinReg.c:
- * win/tclWinTest.c: More cleanups
- * win/tclWinFile.c: Add netapi32 to the link line, so we no longer
- * win/tcl.m4: have to use LoadLibrary to access those
- functions.
- * win/makefile.vc:
- * win/configure: (Re-generate with autoconf-2.59)
- * win/rules.vc Update for VS10
-
-2010-10-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Fix overallocation of exec stack in TEBC (due
- to mixing numwords and numbytes)
-
-2010-10-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIOSock.c: On Windows, use gai_strerrorA
-
-2010-10-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/winPipe.test: Test hygiene with makeFile and removeFile.
-
- * generic/tclCompile.c: [Bug 3081065]: Prevent writing to the intrep
- * tests/subst.test: fields of a freed Tcl_Obj.
-
-2010-10-06 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * generic/tclAssembly.c:
- * generic/tclAssembly.h:
- * tests/assemble.test: Added catches. Still needs a lot of testing.
-
-2010-10-02 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * generic/tclAssembly.c:
- * generic/tclAssembly.h:
- * tests/assemble.test: Added dictAppend, dictIncrImm, dictLappend,
- dictSet, dictUnset, nop, regexp, nsupvar, upvar, and variable.
-
-2010-10-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TEBCresume): [Bug 3079830]: Added invalidation
- of string representations of dictionaries in some cases.
-
-2010-10-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (EvalStatsCmd): change 'evalstats' to return
- data to interp by default, or if given an arg, use that as filename to
- output to (accepts 'stdout' and 'stderr'). Fix output to print used
- inst count data.
- * generic/tclCkalloc.c: Change TclDumpMemoryInfo sig to allow objPtr
- * generic/tclInt.decls: as well as FILE* as output.
- * generic/tclIntDecls.h:
-
-2010-10-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c, generic/tclClock.c, generic/tclEncoding.c,
- * generic/tclEnv.c, generic/tclLoad.c, generic/tclNamesp.c,
- * generic/tclObj.c, generic/tclRegexp.c, generic/tclResolve.c,
- * generic/tclResult.c, generic/tclUtil.c, macosx/tclMacOSXFCmd.c:
- More purging of strcpy() from locations where we already know the
- length of the data being copied.
-
-2010-10-01 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test:
- * generic/tclAssemble.h:
- * generic/tclAssemble.c: Added listIn, listNotIn, and dictGet.
-
-2010-09-30 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test: Added tryCvtToNumeric and several more list
- * generic/tclAssemble.c: operations.
- * generic/tclAssemble.h:
-
-2010-09-29 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test: Completed conversion of tests to a
- * generic/tclAssemble.c: "white box" structure that follows the
- C code. Added missing safety checks on the operands of 'over' and
- 'reverse' so that negative operand counts don't smash the stack.
-
-2010-09-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/configure: Re-generate with autoconf-2.59
- * win/configure:
- * generic/tclMain.c: Make compilable with -DUNICODE as well
-
-2010-09-28 Reinhard Max <max@suse.de>
-
- TIP #162 IMPLEMENTATION
-
- * doc/socket.n: Document the changes to the [socket] and
- [fconfigure] commands.
-
- * generic/tclInt.h: Introduce TclCreateSocketAddress() as a
- * generic/tclIOSock.c: replacement for the platform-dependent
- * unix/tclUnixSock.c: TclpCreateSocketAddress() functions. Extend
- * unix/tclUnixChan.c: the [socket] and [fconfigure] commands to
- * unix/tclUnixPort.h: behave as proposed in TIP #162. This is the
- * win/tclWinSock.c: core of what is required to support the use of
- * win/tclWinPort.h: IPv6 sockets in Tcl.
-
- * compat/fake-rfc2553.c: A compat implementation of the APIs defined
- * compat/fake-rfc2553.h: in RFC-2553 (getaddrinfo() and friends) on
- top of the existing gethostbyname() etc.
- * unix/configure.in: Test whether the fake-implementation is
- * unix/tcl.m4: needed.
- * unix/Makefile.in: Add a compile target for fake-rfc2553.
-
- * win/configure.in: Allow cross-compilation by default.
-
- * tests/socket.test: Improve the test suite to make more use of
- * tests/remote.tcl: randomized ports to reduce interference with
- tests running in parallel or other services on
- the machine.
-
-2010-09-28 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test: Added more "white box" tests.
- * generic/tclAssembly.c: Added the error checking and reporting
- for undefined labels. Revised code so that no pointers into the
- bytecode sequence are held (because the sequence can move!),
- that no Tcl_HashEntry pointers are held (because the hash table
- doesn't guarantee their stability!) and to eliminate the BBHash
- table, which is merely additional information indexed by jump
- labels and can just as easily be held in the 'label' structure.
- Renamed shared structures to CamelCase, and renamed 'label' to
- JumpLabel because other types of labels may eventually be possible.
-
-2010-09-27 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test: Added more "white box" tests.
- * generic/tclAssembly.c: Fixed bugs exposed by the new tests.
- (a) [eval] and [expr] had incorrect stack balance computed if
- the arg was not a simple word. (b) [concat] accepted a negative
- operand count. (c) [invoke] accepted a zero or negative operand
- count. (d) more misspelt error messages.
- Also replaced a funky NRCallTEBC with the new call
- TclNRExecuteByteCode, necessitated by a merge with changes on the
- HEAD.
-
-2010-09-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Patch 3072080] (minus the itcl
- * generic/tclCmdIL.c: update): a saner NRE.
- * generic/tclCompExpr.c:
- * generic/tclCompile.c: This makes TclNRExecuteByteCode (ex TEBC)
- * generic/tclCompile.h: to be a normal NRE citizen: it loses its
- * generic/tclExecute.c: special status.
- * generic/tclInt.decls: The logic flow within the BC engine is
- * generic/tclInt.h: simplified considerably.
- * generic/tclIntDecls.h:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * generic/tclTest.c:
-
- * generic/tclVar.c: Use the macro HasLocalVars everywhere
-
-2010-09-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code
- duplication, let the runtime var resolver call the compiled var
- resolver.
-
-2010-09-26 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * tests/assemble.test: Added many new tests moving toward a more
- comprehensive test suite for the assembler.
- * generic/tclAssembly.c: Fixed bugs exposed by the new tests:
- (a) [bitnot] and [not] had incorrect operand counts. (b)
- INST_CONCAT cannot concatenate zero objects. (c) misspelt error
- messages. (d) the "assembly code" internal representation lacked
- a duplicator, which caused double-frees of the Bytecode object
- if assembly code ever was duplicated.
-
-2010-09-25 Kevin B. Kenny <kennykb@acm.org>
-
- [dogeen-assembler-branch]
-
- * generic/tclAssembly.c: Massive refactoring of the assembler
- * generic/tclAssembly.h: to use a Tcl-like syntax (and use
- * tests/assemble.test: Tcl_ParseCommand to parse it). The
- * tests/assemble1.bench: refactoring also ensures that
- Tcl_Tokens in the assembler have string ranges inside the source
- code, which allows for [eval] and [expr] assembler directives
- that simply call TclCompileScript and TclCompileExpr recursively.
-
-2010-09-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/stringComp.test: improved string eq/cmp test coverage
- * generic/tclExecute.c (TclExecuteByteCode): merge INST_STR_CMP and
- INST_STR_EQ/INST_STR_NEQ paths. Speeds up eq/ne/[string eq] with
- obj-aware comparisons and eq/==/ne/!= with length equality check.
-
-2010-09-24 Andreas Kupries <andreask@activestate.com>
-
- * tclWinsock.c: [Bug 3056775]: Fixed race condition between thread and
- internal co-thread access of a socket's structure because of the
- thread not using the socketListLock in TcpAccept(). Added
- documentation on how the module works to the top.
-
-2010-09-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: Make Tcl_SetPanicProc and Tcl_GetStringResult
- * unix/tclAppInit.c: callable without stubs, just as Tcl_SetVar.
- * win/tclAppInit.c:
-
-2010-09-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c: Fix cases where value returned by
- * generic/tclEvent.c: Tcl_GetReturnOptions() was leaked.
- * generic/tclMain.c: Thanks to Jeff Hobbs for discovery of the
- anti-pattern to seek and destroy.
-
-2010-09-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclAppInit.c: Make compilable with -DUNICODE (not activated
- * win/tclAppInit.c: yet), many clean-ups in comments.
-
-2010-09-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute: [Bug 3072640]: One more DECACHE_STACK_INFO() was
- missing.
-
- * tests/execute.test: Added execute-10.3 for [Bug 3072640]. The test
- causes a mem failure.
-
- * generic/tclExecute: Protect all possible writes to ::errorInfo or
- ::errorCode with DECACHE_STACK_INFO(), as they could run traces. The
- new calls to be protected are Tcl_ResetResult(), Tcl_SetErrorCode(),
- IllegalExprOperandType(), TclExprFloatError(). The error was triggered
- by [Patch 3072080].
-
-2010-09-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tcl.m4: Add kernel32 to LIBS, so the link line for
- * win/configure: mingw is exactly the same as for MSVC++.
-
-2010-09-21 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect):
- * generic/tclVar.c (TclLookupSimpleVar, CompareVarKeys):
- * generic/tclPathObj.c (Tcl_FSGetNormalizedPath, Tcl_FSEqualPaths):
- * generic/tclIOUtil.c (TclFSCwdPointerEquals): peephole opt
- * generic/tclResult.c (TclMergeReturnOptions): Use memcmp where
- applicable as possible speedup on some libc variants.
-
-2010-09-21 Kevin B. Kenny <kennykb@acm.org>
-
- [BRANCH: dogeen-assembler-branch]
-
- * generic/tclAssembly.c (new file):
- * generic/tclAssembly.h:
- * generic/tclBasic.c (builtInCmds, Tcl_CreateInterp):
- * generic/tclInt.h:
- * tests/assemble.test (new file):
- * tests/assemble1.bench (new file):
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/Makefile.vc:
- Initial commit of Ozgur Dogan Ugurlu's (SF user: dogeen)
- assembler for the Tcl bytecode language.
-
-2010-09-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFile.c: Fix declaration after statement.
- * win/tcl.m4: Add -Wdeclaration-after-statement, so this
- * win/configure: mistake cannot happen again.
- * win/tclWinFCmd.c: [Bug 3069278]: Breakage on head Windows
- * win/tclWinPipe.c: triggered by install-tzdata, final fix
-
-2010-09-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFCmd.c: Eliminate tclWinProcs->useWide everywhere, since
- * win/tclWinFile.c: the value is always "1" on platforms >win95
- * win/tclWinPipe.c:
-
-2010-09-19 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/file.n (file readlink): [Bug 3070580]: Typofix.
-
-2010-09-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinFCmd.c [Bug 3069278]: Breakage on head Windows triggered
- by install-tzdata. Temporary don't compile this with -DUNICODE, while
- investigating this bug.
-
-2010-09-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFile.c: Remove define of FINDEX_INFO_LEVELS as all
- supported versions of compilers should now have it.
-
- * unix/Makefile.in: Do not pass current build env vars when using
- NATIVE_TCLSH in targets.
-
-2010-09-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: Make Tcl_FindExecutable() work in UNICODE
- * generic/tclEncoding.c: compiles (windows-only) as well as ASCII.
- * generic/tclStubInit.c: Needed for [FRQ 491789]: setargv() doesn't
- support a unicode cmdline.
-
-2010-09-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (TclAppendBytesToByteArray): [Bug 3067036]: Make
- sure we never try to double zero repeatedly to get a buffer size. Also
- added a check for sanity on the size of buffer being appended.
-
-2010-09-15 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Revise `make dist` target to tolerate the
- case of zero bundled packages.
-
-2010-09-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl
- * generic/tcl.decls: features to genStubs.tcl. Make the "generic"
- * generic/tclInt.decls: argument in the *.decls files optional
- * generic/tclOO.decls: (no change to any tcl*Decls.h files)
- * generic/tclTomMath.decls:
- This allows genStubs.tcl to generate the ttk stub files as well, while
- keeping full compatibility with existing *.decls files.
-
-2010-09-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Allow all Win2000+ API entries in Tcl
- * win/tclWin32Dll.c: Eliminate dynamical loading of advapi23 and
- kernel32 symbols.
-
-2010-09-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinChan.c: Various clean-ups, converting from
- * win/tclWinConsole.c: tclWinProc->xxxProc directly to Xxx
- * win/tclWinInit.c: (no change in functionality)
- * win/tclWinLoad.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
- * tools/genStubs.tcl: Add scspec feature from ttkGenStubs.tcl
- (no change in output for *Decls.h files)
-
-2010-09-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWin32Dll.c: Partly revert yesterday's change, to make it work
- on VC++ 6.0 again.
-
-2010-09-10 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/regsub.n: [Bug 3063568]: Fix for gotcha in example due to Tcl's
- special handling of backslash-newline. Makes example slightly less
- pure, but more useful.
-
-2010-09-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/makefile.vc: Mingw should always link with -ladvapi32.
- * win/tcl.m4:
- * win/configure: (regenerated)
- * win/tclWinInt.h: Remove ascii variant of tkWinPocs table, it is
- * win/tclWin32Dll.c: no longer necessary. Fix CreateProcess signature
- * win/tclWinPipe.c: and remove unused GetModuleFileName and lstrcpy.
- * win/tclWinPort.h: Mingw/cygwin fixes: <tchar.h> should always be
- included, and fix conflict in various macro values: Always force the
- same values as in VC++.
-
-2010-09-08 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinChan.c: [Bug 3059922]: #ifdef protections to permit
- * win/tclWinFCmd.c: builds with mingw on amd64 systems. Thanks to
- "mescalinum" for reporting and testing.
-
-2010-09-08 Andreas Kupries <andreask@activestate.com>
-
- * doc/tm.n: Added underscore to the set of characters accepted in
- module names. This is true for quite some time in the code, this
- change catches up the documentation.
-
-2010-09-03 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (plus-pkgs): Improve the package
- documentation search pattern to support the doctoos-generated
- directory structure.
- * tools/tcltk-man2html-utils.tcl (output-name): Made this more
- resilient against misformatted NAME sections, induced by import of
- Thread package documentation into Tcl doc tree.
-
-2010-09-02 Andreas Kupries <andreask@activestate.com>
-
- * doc/glob.n: Fixed documentation ambiguity regarding the handling
- of -join.
-
- * library/safe.tcl (safe::AliasGlob): Fixed another problem, the
- option -join does not stop option processing in the core builtin, so
- the emulation must not do that either.
-
-2010-09-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * library/safe.tcl (safe::AliasGlob): Moved the command extending the
- actual glob command with a -directory flag to when we actually have a
- proper untranslated path,
-
-2010-09-01 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclExecute.c: [Bug 3057639]: Applied patch by Jeff to make
- * generic/tclVar.c: the behaviour of lappend in bytecompiled mode
- * tests/append.test: consistent with direct-eval and 'append'
- * tests/appendComp.test: generally. Added tests (append*-9.*)
- showing the difference.
-
-2010-08-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/rules.vc: Typo (thanks to Twylite discovering
- this)
- * generic/tclStubLib.c: Revert to previous version: MSVC++ 6.0
- * generic/tclTomMathStubLib.c:cannot handle the new construct.
- * generic/tcl.decls [Patch 2997642]: Many type casts needed
- * generic/tclDecls.h: when using Tcl_Pkg* API. Remaining part.
- * generic/tclPkg.c:
- * generic/tclBasic.c:
- * generic/tclTomMathInterface.c:
- * doc/PkgRequire.3
-
-2010-08-31 Andreas Kupries <andreask@activestate.com>
-
- * win/tcl.m4: Applied patch by Jeff fixing issues with the manifest
- handling on Win64.
- * win/configure: Regenerated.
-
-2010-08-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bugs 3046594,3047235,3048771]: New
- * generic/tclCmdAH.c: implementation for [tailcall] command: it now
- * generic/tclCmdMZ.c: schedules the command and returns TCL_RETURN.
- * generic/tclExecute.c: This fixes all issues with [catch] and [try].
- * generic/tclInt.h: Thanks dgp for exploring the dark corners.
- * generic/tclNamesp.c: More thorough testing is required.
- * tests/tailcall.test:
-
-2010-08-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: [FRQ 2965056]: Windows build with -DUNICODE
- * win/rules.vc:
- * win/tclWinFCmd.c: Make sure that allocated TCHAR arrays are
- * win/tclWinFile.c: always properly aligned as wchar_t, and
- * win/tclWinPipe.c: not bigger than necessary.
- * win/tclWinSock.c:
- * win/tclWinDde.c: Those 3 files are not converted yet to be
- * win/tclWinReg.c: built with -DUNICODE, so add a TODO.
- * win/tclWinTest.c:
- * generic/tcl.decls: [Patch 2997642]: Many type casts needed when
- * generic/tclDecls.h: using Tcl_Pkg* API. Partly.
- * generic/tclPkg.c:
- * generic/tclStubLib.c: Demonstration how this change can benefit
- code.
- * generic/tclTomMathStubLib.c:
- * doc/PkgRequire.3:
-
-2010-08-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: [Bug 3046999]: Corrected cross reference to array
- manpage to refer to (correct) existing subcommand.
-
-2010-08-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure, unix/tcl.m4: SHLIB_LD_LIBS='${LIBS}' for OSF1-V*.
- Add /usr/lib64 to set of auto-search dirs. [Bug 1230554]
- (SC_PATH_X): Correct syntax error when xincludes not found.
-
- * win/Makefile.in (VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE):
- * win/configure, win/configure.in, win/tcl.m4: SC_EMBED_MANIFEST
- macro and --enable-embedded-manifest configure arg added to support
- manifest embedding where we know the magic. Help prevents DLL hell
- with MSVC8+.
-
-2010-08-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls: [Bug 3007895]: Tcl_(Find|Create)HashEntry
- * generic/tclHash.c: stub entries can never be called.
- * generic/tclDecls.h:
- * generic/tclStubInit.c: [Patch 2994165]: Change signature of
- Tcl_FSGetNativePath and TclpDeleteFile follow-up: move stub entry back
- to original location.
-
-2010-08-23 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Cairo:
- * library/tzdata/Asia/Gaza: Olson's tzdata2010l.
-
-2010-08-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBasic.c: [Patch 3009403]: Signature of Tcl_GetHashKey,
- * generic/tclBinary.c: Tcl_(Create|Find)HashEntry follow-up:
- * generic/tclCmdIL.c: Remove many type casts which are no longer
- * generic/tclCompile.c:necessary as a result of this signature change.
- * generic/tclDictObj.c:
- * generic/tclEncoding.c:
- * generic/tclExecute.c:
- * generic/tclInterp.c:
- * generic/tclIOCmd.c:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * generic/tclTest.c:
- * generic/tclTrace.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
-
-2010-08-21 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/linsert.n: [Bug 3045123]: Make description of what is actually
- happening more accurate.
-
-2010-08-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl
- features to genStubs.tcl, partly: Use void (*reserved$i)(void) = 0
- instead of void *reserved$i = NULL for unused stub entries, in case
- pointer-to-function and pointer-to-object are different sizes.
- * generic/tcl*Decls.h: (regenerated)
- * generic/tcl*StubInit.c:(regenerated)
-
-2010-08-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/Method.3: Fix definition of Tcl_MethodType.
-
-2010-08-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclTrace.c (TraceExecutionObjCmd, TraceCommandObjCmd)
- (TraceVariableObjCmd): [Patch 3048354]: Use memcpy() instead of
- strcpy() to avoid buffer overflow; we have the correct length of data
- to copy anyway since we've just allocated the target buffer.
-
-2010-08-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: [Patch 3034251]: Backport ttkGenStubs.tcl
- features to genStubs.tcl, partly: remove unneeded ifdeffery and put
- C++ guard around stubs pointer definition.
- * generic/*Decls.h: (regenerated)
-
-2010-08-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: New redesign of [tailcall]: find
- * generic/tclExecute.c: errors early on, so that errorInfo
- * generic/tclInt.h: contains the proper info [Bug 3047235]
- * generic/tclNamesp.c:
-
- * generic/tclCmdAH.c (TclNRTryObjCmd): [Bug 3046594]: Block
- tailcalling out of the body of a non-bc'ed [try].
-
- * generic/tclBasic.c: Redesign of [tailcall] to
- * generic/tclCmdAH.c: (a) fix [Bug 3047235]
- * generic/tclCompile.h: (b) enable fix for [Bug 3046594]
- * generic/tclExecute.c: (c) enable recursive tailcalls
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * tests/tailcall.test:
-
-2010-08-18 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (AliasGlob): [Bug 3004191]: Restore safe [glob] to
- working condition.
-
-2010-08-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (ProcWrongNumArgs): [Bug 3045010]: Make the
- handling of passing the wrong number of arguments to [apply] somewhat
- less verbose when a lambda term is present.
-
-2010-08-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/unicows: Remove completely, see [FRQ 2819611].
- * doc/FileSystem.3: [Patch 2994165]: Change signature of
- * generic/tcl.decls Tcl_FSGetNativePath and TclpDeleteFile
- * generic/tclDecls.h:
- * generic/tclIOUtil.c:
- * generic/tclStubInit.c:
- * generic/tclInt.h:
- * unix/tclUnixFCmd.c:
- * win/tclWinFCmd.c:
- * doc/Hash.3: [Patch 3009403]: Signature of Tcl_GetHashKey,
- * generic/tcl.h: Tcl_(Create|Find)HashEntry
-
-2010-08-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/ldAix: Remove ancient (pre-4.2) AIX support
- * unix/configure: Regen with ac-2.59
- * unix/configure.in, unix/tclConfig.sh.in, unix/Makefile.in:
- * unix/tcl.m4 (AIX): Remove the need for ldAIX, replace with
- -bexpall/-brtl. Remove TCL_EXP_FILE (export file) and other baggage
- that went with it. Remove pre-4 AIX build support.
-
-2010-08-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclNRYieldToObjCmd):
- * tests/coroutine.test: Fixed bad copypasta snafu. Thanks to Andy Goth
- for finding the bug.
-
-2010-08-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (TclByteArrayMatch): Patterns may not be
- null-terminated, so account for that.
-
-2010-08-09 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6b2 release.
-
-2010-08-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/Makefile.in, win/makefile.bc, win/makefile.vc, win/tcl.dsp:
- * win/tclWinPipe.c (TclpCreateProcess):
- * win/stub16.c (removed): Removed Win9x tclpip8x.dll build and 16-bit
- application loader stub support. Win9x is no longer supported.
-
- * win/tclWin32Dll.c (TclWinInit): Hard-enforce Windows 9x as an
- unsupported platform with a panic. Code to support it still exists in
- other files (to go away in time), but new APIs are being used that
- don't exist on Win9x.
-
- * unix/tclUnixFCmd.c: Adjust license header as per
- ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change
-
- * license.terms: Fix DFARs note for number-adjusted rights clause
-
- * win/tclWin32Dll.c (asciiProcs, unicodeProcs):
- * win/tclWinLoad.c (TclpDlopen): 'load' use LoadLibraryEx with
- * win/tclWinInt.h (TclWinProcs): LOAD_WITH_ALTERED_SEARCH_PATH to
- prefer dependent DLLs in same dir as loaded DLL.
-
- * win/Makefile.in (%.${OBJEXT}): better implicit rules support
-
-2010-08-04 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c: [Bug 3034840]: Fixed reference counting in
- * generic/tclIORTrans.c: InvokeTclMethod and callers.
- * tests/ioTrans.test:
-
-2010-08-03 Andreas Kupries <andreask@activestate.com>
-
- * tests/var.test (var-19.1): [Bug 3037525]: Added test demonstrating
- the local hashtable deletion crash and fix.
-
- * tests/info.test (info-39.1): Added forward copy of test in 8.5
- branch about [Bug 2933089]. Should not fail, and doesn't, after
- updating the line numbers to the changed position.
-
-2010-08-02 Kevin B. Kenny <kennykb@users.sf.net>
-
- * library/tzdata/America/Bahia_Banderas:
- * library/tzdata/Pacific/Chuuk:
- * library/tzdata/Pacific/Pohnpei:
- * library/tzdata/Africa/Cairo:
- * library/tzdata/Europe/Helsinki:
- * library/tzdata/Pacific/Ponape:
- * library/tzdata/Pacific/Truk:
- * library/tzdata/Pacific/Yap: Olson's tzdata2010k.
-
-2010-08-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: Correcting bad port of [Bug 3037525] fix
-
-2010-07-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: [Bug 3037525]: Lose fickle optimisation in
- TclDeleteVars (used for runtime-created locals) that caused crash.
-
-2010-07-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/zlib/win32/README.txt: Official build of zlib1.dll 1.2.5 is
- * compat/zlib/win32/USAGE.txt: finally available, so put it in.
- * compat/zlib/win32/zlib1.dll:
-
-2010-07-25 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/http.n: Corrected description of location of one of the entries
- in the state array.
-
-2010-07-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDecls.h: [Bug 3029891]: Functions that don't belong in
- * generic/tclTest.c: the stub table.
- * generic/tclBasic.c: From [Bug 3030870] make itcl 3.x built with
- pre-8.6 work in 8.6: Relax the relation between Tcl_CallFrame and
- CallFrame.
-
-2010-07-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c: Added more errorCode setting.
-
-2010-07-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Ensure that [dict get]
- * generic/tclDictObj.c (DictGetCmd): always generates an errorCode on
- a failure to look up an entry.
-
-2010-07-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * unix/configure: (regenerated)
- * unix/configure.in: For the NATIVE_TCLSH variable use the autoconf
- * unix/Makefile.in: SC_PROG_TCLSH to try and find a locally installed
- native binary. This avoids manually fixing up when cross compiling. If
- there is not one, revert to using the build product.
-
-2010-07-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.decs: Reverted to the original TIP 337
- implementation on what to do with the obsolete internal stub for
- TclBackgroundException() (eliminate it!)
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2010-07-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: [Bug 803489]: Tcl_FindNamespace problem in
- * generic/tclIntDecls.h: the Stubs table
- * generic/tclStubInit.c:
-
-2010-07-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (IllegalExprOperandType): [Bug 3024379]: Made
- sure that errors caused by an argument to an operator being outside
- the domain of the operator all result in ::errorCode being ARITH
- DOMAIN and not NONE.
-
-2010-07-01 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/rules.vc: [Bug 3020677]: wish can't link reg1.2
- * tools/checkLibraryDoc.tcl: formatting, spacing, cleanup unused
- * tools/eolFix.tcl: variables; no change in generated output
- * tools/fix_tommath_h.tcl:
- * tools/genStubs.tcl:
- * tools/index.tcl:
- * tools/man2help2.tcl:
- * tools/regexpTestLib.tcl:
- * tools/tsdPerf.tcl:
- * tools/uniClass.tcl:
- * tools/uniParse.tcl:
-
-2010-07-01 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/mathop.n: [Bug 3023165]: Fix typo that was preventing proper
- rendering of the exclusive-or operator.
-
-2010-06-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPosixStr.c: [Bug 3019634]: errno.h and tclWinPort.h have
- conflicting definitions. Added messages for ENOTRECOVERABLE, EOTHER,
- ECANCELED and EOWNERDEAD, and fixed various typing mistakes in other
- messages.
-
-2010-06-25 Reinhard Max <max@suse.de>
-
- * tests/socket.test: Prevent a race condition during shutdown of the
- remote test server that can cause a hang when the server is being run
- in verbose mode.
-
-2010-06-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: [Bug 3019634]: errno.h and tclWinPort.h have
- conflicting definitions.
-
- ***POTENTIAL INCOMPATIBILITY***
- On win32, the correspondence between errno and the related error
- message, as handled by Tcl_ErrnoMsg() changes. The error message is
- kept the same, but the corresponding errno value might change.
-
-2010-06-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsetObjCmd): [Bug 3019351]: Corrected wrong
- args message.
-
-2010-06-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclLoadDl.c: Eliminate various unnecessary type casts, use
- * unix/tclLoadNext.c: function typedefs whenever possible
- * unix/tclUnixChan.c:
- * unix/tclUnixFile.c:
- * unix/tclUnixNotfy.c:
- * unix/tclUnixSock.c:
- * unix/tclUnixTest.c:
- * unix/tclXtTest.c:
- * generic/tclZlib.c: Remove hack needed for zlib 1.2.3 on win32
-
-2010-06-18 Donal K. Fellows <dkf@users.sf.net>
-
- * library/init.tcl (auto_execok): [Bug 3017997]: Add .cmd to the
- default list of extensions that we can execute interactively.
-
-2010-06-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/loadICU.tcl: [Bug 3016135]: Traceback using clock format
- * library/msgs/he.msg: with locale of he_IL.
-
- * generic/tcl.h: Simplify Tcl_AppInit and *_Init definitions,
- * generic/tclInt.h: spacing. Change TclpThreadCreate and
- * generic/tcl.decls: Tcl_CreateThread signature, making clear that
- * generic/tclDecls.h: "proc" is a function pointer, as in all other
- * generic/tclEvent.c: "proc" function parameters.
- * generic/tclTestProcBodyObj.c:
- * win/tclWinThrd.c:
- * unix/tclUnixThrd.c:
- * doc/Thread.3:
- * doc/Class.3: Fix Tcl_ObjectMetadataType definition.
-
-2010-06-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/Makefile.in: Fix compilation of xttest with 8.6 changes
- * unix/tclXtNotify.c:
- * unix/tclXtTest.c:
- * generic/tclPipe.c: Fix gcc warning (with -fstrict-aliasing=2)
- * library/auto.tcl: Spacing and style fixes.
- * library/history.tcl:
- * library/init.tcl:
- * library/package.tcl:
- * library/safe.tcl:
- * library/tm.tcl:
-
-2010-06-13 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (make-man-pages): [Bug 3015327]: Make the
- title of a manual page be stored relative to its resulting directory
- name as well as its source filename. This was caused by both Tcl and a
- contributed package ([incr Tcl]) defining an Object.3. Also corrected
- the joining of strings in titles to avoid extra braces.
-
-2010-06-09 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Added OSX Intel 64bit
- * library/platform/pkgIndex.tcl: Package updated to version 1.0.9.
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2010-06-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/tsdPerf.c: Fix export of symbol Tsdperf_Init, when using
- -fvisibility=hidden. Make two functions static, eliminate some
- unnecessary type casts.
- * tools/configure.in: Update to Tcl 8.6
- * tools/configure: (regenerated)
- * tools/.cvsignore new file
-
-2010-06-07 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclExecute.c: Ensure proper reset of [info errorstack] even
- * generic/tclNamesp.c: when compiling constant expr's with errors.
-
-2010-06-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bug 3008307]: make callerPtr chains be
- * generic/tclExecute.c: traversable accross coro boundaries. Add the
- special coroutine CallFrame (partially reverting commit of
- 2009-12-10), as it is needed for coroutines that do not push a CF, eg,
- those with [eval] as command. Thanks to Colin McCormack (coldstore)
- and Alexandre Ferrieux for the hard work on this.
-
-2010-06-03 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclNamesp.c: Safer (and faster) computation of [uplevel]
- * tests/error.test: offsets in TIP 348. Toplevel offsets no longer
- * tests/result.test: overestimated.
-
-2010-06-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclOO.h: BUILD_tcloo is never defined (leftover)
- * win/makefile.bc: Don't set BUILD_tcloo (leftover)
- See also entry below: 2008-06-01 Joe Mistachkin
-
-2010-06-01 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclNamesp.c: Fix computation of [uplevel] offsets in TIP 348
- * tests/error.test: Only depend on callerPtr chaining now.
- * tests/result.test: Needed for upcoming coro patch.
-
-2010-05-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclVar.c: Eliminate some casts to (Tcl_HashTable *)
- * generic/tclExecute.c:
- * tests/fileSystem.test: Fix filesystem-5.1 test failure on CYGWIN
-
-2010-05-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: [Patch 3008541]: Order of TIP #348 fields in
- Interp structure
-
-2010-05-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions): [3007374]:
- Corrected error in handling of catch contexts to prevent crash with
- chained handlers.
-
- * generic/tclExecute.c (TclExecuteByteCode): Restore correct operation
- of instruction-level execution tracing (had been broken by NRE).
-
-2010-05-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/opt/optParse.tcl: Don't generate spaces at the end of a
- * library/opt/pkgIndex.tcl: line, eliminate ';' at line end, bump to
- * tools/uniParse.tcl: v0.4.6
- * generic/tclUniData.c:
- * tests/opt.test:
- * tests/safe.test:
-
-2010-05-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/installData.tcl: Make sure that copyDir only receives
- normalized paths, otherwise it might result in a crash on CYGWIN.
- Restyle according to the Tcl style guide.
- * generic/tclStrToD.c: [Bug 3005233]: Fix for build on OpenBSD vax
-
-2010-05-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/dict.test: Add missing tests for [Bug 3004007], fixed under
- the radar on 2010-02-24 (dkf): EIAS violation in list-dict conversions
-
-2010-05-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/regcomp.c: Don't use arrays of length 1, just use a
- * generic/tclFileName.c: single element then, it makes code more
- * generic/tclLoad.c: readable. (Here it even prevents a type cast)
-
-2010-05-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStrToD.c: [Bug 2996549]: Failure in expr.test on Win32
-
-2010-05-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (TclInfoFrame): Change this code to use
- Tcl_GetCommandFullName rather than rolling its own. Discovered during
- the hunting of [Bug 3001438] but unlikely to be a fix.
-
-2010-05-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinConsole.c: [Patch 2997087]: Unnecessary type casts.
- * win/tclWinDde.c:
- * win/tclWinLoad.c:
- * win/tclWinNotify.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
- * win/tclWinTime.c:
- * win/tclWinPort.h: Don't duplicate CYGWIN timezone #define from
- tclPort.h
-
-2010-05-07 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Fix cpu name for Solaris/Intel 64bit.
- * library/platform/pkgIndex.tcl: Package updated to version 1.0.8.
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2010-05-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPkg.c: Unnecessary type casts, see [Patch 2997087]
-
-2010-05-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinNotify.c: TCHAR-related fixes, making those two files
- * win/tclWinSock.c: compile fine when TCHAR != char. Please see
- comments in [FRQ 2965056] (2965056-1.patch).
-
-2010-05-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIORChan.c: Use "tclIO.h" and "tclTomMathDecls.h"
- * generic/tclIORTrans.c: everywhere
- * generic/tclTomMath.h:
- * tools/fix_tommath_h.tcl:
- * libtommath/tommath.h: Formatting (# should always be first char on
- line)
- * win/tclAppInit.c: For MINGW/CYGWIN, use GetCommandLineA
- explicitly.
- * unix/.cvsignore: Add pkg, *.dll
-
- * libtommath/tommath.h: CONSTify various useful internal
- * libtommath/bn_mp_cmp_d.c: functions (TclBignumToDouble, TclCeil,
- * libtommath/bn_mp_cmp_mag.c: TclFloor), and related tommath functions
- * libtommath/bn_mp_cmp.c:
- * libtommath/bn_mp_copy.c:
- * libtommath/bn_mp_count_bits.c:
- * libtommath/bn_mp_div_2d.c:
- * libtommath/bn_mp_mod_2d.c:
- * libtommath/bn_mp_mul_2d.c:
- * libtommath/bn_mp_neg.c:
- * generic/tclBasic.c: Handle TODO: const correctness ?
- * generic/tclInt.h:
- * generic/tclStrToD.c:
- * generic/tclTomMath.decls:
- * generic/tclTomMath.h:
- * generic/tclTomMathDecls.h:
-
-2010-04-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump patchlevel to 8.6b1.2 to distinguish
- * library/init.tcl: CVS snapshots from earlier snapshots as well
- * unix/configure.in: as the 8.6b1 and 8.6b2 releases.
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * generic/tclBinary.c (TclAppendBytesToByteArray): Add comments
- * generic/tclInt.h (TclAppendBytesToByteArray): placing overflow
- protection responsibility on caller. Convert "len" argument to signed
- int which any value already vetted for overflow issues will fit into.
- * generic/tclStringObj.c: Update caller; standardize panic msg.
-
- * generic/tclBinary.c (UpdateStringOfByteArray): [Bug 2994924]: Add
- panic when the generated string representation would grow beyond Tcl's
- size limits.
-
-2010-04-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (TclAppendBytesToByteArray): Add extra armour
- against buffer overflows.
-
- * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of
- * tests/coroutine.test (coroutine-6.4): arguments to deal with
- trickier cases.
-
-2010-04-30 Miguel Sofer <msofer@users.sf.net>
-
- * tests/coroutine.test: testing coroutine arguments after [yield]:
- check that only 0/1 allowed
-
-2010-04-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (NRInterpCoroutine): Corrected handling of
- arguments to deal with trickier cases.
-
- * generic/tclCompCmds.c (TclCompileVariableCmd): Slightly tighter
- issuing of instructions.
-
- * generic/tclExecute.c (TclExecuteByteCode): Add peephole optimization
- of the fact that INST_DICT_FIRST and INST_DICT_NEXT always have a
- conditional jump afterwards.
-
- * generic/tclBasic.c (TclNRYieldObjCmd, TclNRYieldmObjCmd)
- (NRInterpCoroutine): Replace magic values for formal argument counts
- for coroutine command implementations with #defines, for an increase
- in readability.
-
-2010-04-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclMain.c: Unnecessary TCL_STORAGE_CLASS re-definition. It
- was used for an ancient dummy reference to Tcl_LinkVar(), but that's
- already gone since 2002-05-29.
-
-2010-04-29 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompExpr.c: Slight change in the literal sharing
- * generic/tclCompile.c: mechanism to avoid shimmering of
- * generic/tclCompile.h: command names.
- * generic/tclLiteral.c:
-
-2010-04-29 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Another stab at getting the /lib,
- * library/platform/pkgIndex.tcl: /lib64 difference right for linux.
- * unix/Makefile.in: Package updated to version 1.0.7.
- * win/Makefile.in:
-
-2010-04-29 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Antarctica/Macquarie:
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/Africa/Tunis:
- * library/tzdata/America/Santiago:
- * library/tzdata/America/Argentina/San_Luis:
- * library/tzdata/Antarctica/Casey:
- * library/tzdata/Antarctica/Davis:
- * library/tzdata/Asia/Anadyr:
- * library/tzdata/Asia/Damascus:
- * library/tzdata/Asia/Dhaka:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Kamchatka:
- * library/tzdata/Asia/Karachi:
- * library/tzdata/Asia/Taipei:
- * library/tzdata/Europe/Samara:
- * library/tzdata/Pacific/Apia:
- * library/tzdata/Pacific/Easter:
- * library/tzdata/Pacific/Fiji: Olson's tzdata2010i.
-
-2010-04-29 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBinary.c (TclAppendBytesToByteArray): [Bug 2992970]: Make
- * generic/tclStringObj.c (Tcl_AppendObjToObj): an append of a byte
- array to another into an efficent operation. The problem was the (lack
- of) a proper growth management strategy for the byte array.
-
-2010-04-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/dirent2.h: Include "tcl.h", not <tcl.h>, like everywhere
- * compat/dlfcn.h: else, to ensure that the version in the Tcl
- * compat/stdlib.h: distribution is used, not some version from
- * compat/string.h: somewhere else.
- * compat/unistd.h:
-
-2010-04-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: Remove unused @MAN2TCLFLAGS@
- * win/tclWinPort.h: Move <limits.h> include from tclInt.h to
- * generic/tclInt.h: tclWinPort.h, and eliminate unneeded
- * generic/tclEnv.c: <stdlib.h>, <stdio.h> and <string.h>, which
- are already in tclInt.h
- * generic/regcustom.h: Move "tclInt.h" from regcustom.h up to
- * generic/regex.h: regex.h.
- * generic/tclAlloc.c: Unneeded <stdio.h> include.
- * generic/tclExecute.c: Fix gcc warning: comparison between signed and
- unsigned.
-
-2010-04-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h (TclIsVarDirectUnsettable): Corrected flags so that
- deletion of traces is not optimized out...
-
- * generic/tclExecute.c (ExecuteExtendedBinaryMathOp)
- (TclCompareTwoNumbers,ExecuteExtendedUnaryMathOp,TclExecuteByteCode):
- [Patch 2981677]: Move the less common arithmetic operations (i.e.,
- exponentiation and operations on non-longs) out of TEBC for a big drop
- in the overall size of the stack frame for most code. Net effect on
- speed is minimal (slightly faster overall in tclbench). Also extended
- the number of places where TRESULT handling is replaced with a jump to
- dedicated code.
-
-2010-04-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Rearrange location of an
- assignment to shorten the object code.
-
-2010-04-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIOUtil.c (Tcl_FSGetNativePath): [Bug 2992292]:
- tclIOUtil.c assignment type mismatch compiler warning
- * generic/regguts.h: If tclInt.h or tclPort.h is already
- * generic/tclBasic.c: included, don't include <limits.h>
- * generic/tclExecute.c: again. Follow-up to [Bug 2991415]:
- * generic/tclIORChan.c: tclport.h #included before limits.h
- * generic/tclIORTrans.c: See comments in [Bug 2991415]
- * generic/tclObj.c:
- * generic/tclOOInt.h:
- * generic/tclStrToD.c:
- * generic/tclTomMath.h:
- * generic/tclTomMathInterface.c:
- * generic/tclUtil.c:
- * compat/strtod.c:
- * compat/strtol.c:
-
-2010-04-27 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclLoadDl.c (FindSymbol): [Bug 2992295]: Simplified the logic
- so that the casts added in Donal Fellows's change for the same bug are
- no longer necessary.
-
-2010-04-26 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclLoadDl.c (FindSymbol): [Bug 2992295]: Added an explicit cast
- because auto-casting between function and non-function types is never
- naturally warning-free.
-
- * generic/tclStubInit.c: Add a small amount of gcc-isms (with #ifdef
- * generic/tclOOStubInit.c: guards) to ensure that warnings are issued
- when these files are older than the various *.decls files.
-
-2010-04-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Add unsupported [yieldm] command. Credit
- * generic/tclInt.h: Lars Hellstrom for the basic idea.
-
-2010-04-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Modify api of TclSpliceTailcall() to fix
- * generic/tclExecute.c: [yieldTo], which had not survived the latest
- * generic/tclInt.h: mods to tailcall. Thanks kbk for detecting
- the problem.
-
-2010-04-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixPort.h: [Bug 2991415]: tclport.h #included before
- limits.h
-
-2010-04-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclPlatDecls.h: Move TCHAR fallback typedef from tcl.h to
- * generic/tcl.h: tclPlatDecls.h (as suggested by dgp)
- * generic/tclInt.h: fix typo
- * generic/tclIOUtil.c: Eliminate various unnecessary
- * unix/tclUnixFile.c: type casts.
- * unix/tclUnixPipe.c:
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclWinLoad.c:
- * win/tclWinPipe.c:
-
-2010-04-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Use function prototypes from the FS API.
- * compat/zlib/*: Upgrade to zlib 1.2.5
-
-2010-04-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Improve commenting and
- reduce indentation for the Invocation Block.
-
-2010-04-18 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/unset.n: [Bug 2988940]: Fix typo.
-
-2010-04-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Move inclusion of <tchar.h> from
- * generic/tcl.h: tclPlatDecls.h to tclWinPort.h, where it
- * generic/tclPlatDecls.h: belongs. Add fallback in tcl.h, so TCHAR is
- available in win32 always.
-
-2010-04-15 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/try.n: [Bug 2987551]: Fix typo.
-
-2010-04-14 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Linux platform identification:
- * library/platform/pkgIndex.tcl: Check /lib64 for existence of files
- * unix/Makefile.in: matching libc* before accepting it as base
- * win/Makefile.in: directory. This can happen on weirdly installed
- 32bit systems which have an empty or partially filled /lib64 without
- an actual libc. Bumped to version 1.0.6.
-
-2010-04-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinPort.h: Fix [Patch 2986105]: conditionally defining
- * win/tclWinFile.c: strcasecmp/strncasecmp
- * win/tclWinLoad.c: Fix gcc warning: comparison of unsigned expression
- >= 0 is always true
-
-2010-04-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (TclSubstCompile): If the first token does
- not result in a *guaranteed* push of a Tcl_Obj on the stack, we must
- push an empty object. Otherwise it is possible to get to a 'concat1'
- or 'done' without enough values on the stack, resulting in a crash.
- Thanks to Joe Mistachkin for identifying a script that could trigger
- this case.
-
-2010-04-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/catch.n, doc/info.n, doc/return.n: Formatting.
-
-2010-04-06 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/Load.3: Minor corrections of formatting and cross links.
-
-2010-04-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/configure: (regenerate with autoconf-2.59)
- * unix/configure:
- * unix/installManPage: [Bug 2982540]: configure and install* script
- * unix/install-sh: files should always have LF line ending.
- * doc/Load.3: Fix signature of Tcl_LoadFile in documentation.
-
-2010-04-05 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- TIP #348 IMPLEMENTATION
-
- * generic/tclBasic.c: [Patch 2868499]: Substituted error stack
- * generic/tclCmdIL.c:
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * generic/tclResult.c:
- * doc/catch.n:
- * doc/info.n:
- * doc/return.n:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/execute.test:
- * tests/info.test:
- * tests/init.test:
- * tests/result.test:
-
-2010-04-05 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tcl.m4 (SC_ENABLE_THREADS): Flip the default for whether to
- * win/tcl.m4 (SC_ENABLE_THREADS): build in threaded mode. Part of
- * win/rules.vc: TIP #364.
-
- * unix/tclLoadDyld.c (FindSymbol): Better human-readable error message
- generation to match code in tclLoadDl.c.
-
-2010-04-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIOUtil.c, unix/tclLoadDl.c: Minor changes to enforce
- Engineering Manual style rules.
-
- * doc/FileSystem.3, doc/Load.3: Documentation for TIP#357.
-
- * macosx/tclMacOSXBundle.c (OpenResourceMap): [Bug 2981528]: Only
- define this function when HAVE_COREFOUNDATION is defined.
-
-2010-04-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls (Tcl_LoadFile): Add missing "const" in signature,
- * generic/tclIOUtil.c (Tcl_LoadFile): and some formatting fixes
- * generic/tclDecls.h: (regenerated)
-
-2010-04-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIOUtil.c (Tcl_LoadFile): Corrections to previous commit
- * unix/tclLoadDyld.c (TclpDlopen): to make it build on OSX.
-
-2010-04-02 Kevin B. Kenny <kennykb@acm.org>
-
- TIP #357 IMPLEMENTATION
- TIP #362 IMPLEMENTATION
-
- * generic/tclStrToD.c: [Bug 2952904]: Defer creation of the smallest
- floating point number until it is actually used. (This change avoids a
- bogus syslog message regarding a 'floating point software assist
- fault' on SGI systems.)
-
- * library/reg/pkgIndex.tcl: [TIP #362]: Fixed first round of bugs
- * tests/registry.test: resulting from the recent commits of
- * win/tclWinReg.c: changes in support of the referenced
- TIP.
-
- * generic/tcl.decls: [TIP #357]: First round of changes
- * generic/tclDecls.h: to export Tcl_LoadFile,
- * generic/tclIOUtil.c: Tcl_FindSymbol, and Tcl_FSUnloadFile
- * generic/tclInt.h: to the public API.
- * generic/tclLoad.c:
- * generic/tclLoadNone.c:
- * generic/tclStubInit.c:
- * tests/fileSystem.test:
- * tests/load.test:
- * tests/unload.test:
- * unix/tclLoadDl.c:
- * unix/tclLoadDyld.c:
- * unix/tclLoadNext.c:
- * unix/tclLoadOSF.c:
- * unix/tclLoadShl.c:
- * unix/tclUnixPipe.c:
- * win/Makefile.in:
- * win/tclWinLoad.c:
-
-2010-03-31 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/registry.n: Added missing documentation of TIP#362 flags.
-
- * doc/package.n: [Bug 2980210]: Document the arguments taken by
- the [package present] command correctly.
-
- * doc/Thread.3: Added some better documentation of how to create and
- use a thread using the C-level thread API, based on realization that
- no such tutorial appeared to exist.
-
-2010-03-31 Jan Nijtmans <nijtmans@users.sf.net>
-
- * test/cmdMZ.test: [FRQ 2974744]: share exception codes (ObjType?):
- * test/error.test: Revised test cases, making sure that abbreviated
- * test/proc-old.test: codes are checked resulting in an error, and
- checking for the exact error message.
-
-2010-03-30 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (ReflectClose, ReflectInput, ReflectOutput,
- (ReflectSeekWide, ReflectWatch, ReflectBlock, ReflectSetOption,
- (ReflectGetOption, ForwardProc): [Bug 2978773]: Preserve
- ReflectedChannel* structures across handler invocations, to avoid
- crashes when the handler implementation induces nested callbacks and
- destruction of the channel deep inside such a nesting.
-
-2010-03-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclObj.c (Tcl_GetCommandFromObj): [Bug 2979402]: Reorder
- the validity tests on internal rep of a "cmdName" value to avoid
- invalid reads reported by valgrind.
-
-2010-03-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIndexObj: [FRQ 2974744]: share exception codes
- * generic/tclResult.c: further optimization, making use of indexType.
- * generic/tclZlib.c: [Bug 2979399]: uninitialized value troubles
-
-2010-03-30 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #362 IMPLEMENTATION
-
- * win/tclWinReg.c: [Patch 2960976]: Apply patch from Damon Courtney to
- * tests/registry.test: allow the registry command to be told to work
- * win/Makefile.in: with both 32-bit and 64-bit registries. Bump
- * win/configure.in: version of registry package to 1.3.
- * win/makefile.bc:
- * win/makefile.vc:
- * win/configure: autoconf-2.59
-
-2010-03-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Only test for -visibility=hidden with gcc
- (Second remark in [Bug 2976508])
- * unix/configure: regen
-
-2010-03-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Fix array overrun in test format-1.12
- caught by valgrind testing.
-
-2010-03-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: [FRQ 2974744]: share exception codes
- * generic/tclResult.c: (ObjType?)
- * generic/tclCmdMZ.c:
- * generic/tclCompCmdsSZ.c:
-
-2010-03-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclExecute.c: [Bug 2976508]: Tcl HEAD fails on HP-UX
-
-2010-03-25 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixFCmd.c (TclUnixCopyFile): [Bug 2976504]: Corrected
- number of arguments to fstatfs() call.
-
- * macosx/tclMacOSXBundle.c, macosx/tclMacOSXFCmd.c:
- * macosx/tclMacOSXNotify.c: Reduce the level of ifdeffery in the
- functions of these files to improve readability. They need to be
- audited for whether complexity can be removed based on the minimum
- supported version of OSX, but that requires a real expert.
-
-2010-03-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c: [Bug 2383005]: Revise [return -errorcode] so
- * tests/result.test: that it rejects illegal non-list values.
-
-2010-03-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOInfo.c (InfoObjectMethodTypeCmd)
- (InfoClassMethodTypeCmd): Added introspection of method types so that
- it is possible to find this info out without using errors.
- * generic/tclOOMethod.c (procMethodType): Now that introspection can
- reveal the name of method types, regularize the name of normal methods
- to be the name of the definition type used to create them.
-
- * tests/async.test (async-4.*): Reduce obscurity of these tests by
- putting the bulk of the code for them inside the test body with the
- help of [apply].
-
- * generic/tclCmdMZ.c (TryPostBody, TryPostHandler): Make sure that the
- [try] command does not trap unwinding due to limits.
-
-2010-03-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: [Bug 2973361]: Revised fix for computing
- indices of script arguments to [try].
-
-2010-03-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCmdMZ.c: Make error message in "try" implementation
- * generic/tclCompCmdsSZ.c: exactly the same as the one in "return"
- * tests/error.test:
- * libtommath/mtests/mpi.c: Single "const" addition
-
-2010-03-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: [Bug 2973361]: Compute the correct integer
- values to identify the argument indices of the various script
- arguments to [try]. Passing in -1 led to invalid memory reads.
-
-2010-03-20 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/exec.n: Make it a bit clearer that there is an option to run a
- pipeline in the background.
-
- * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Lift the restriction
- * generic/tclIO.c (TclCopyChannel, CopyData): on the [fcopy] command
- * generic/tclIO.h (CopyState): that forced it to only
- copy up to 2GB per script-level callback. Now it is anything that can
- fit in a (signed) 64-bit integer. Problem identified by Frederic
- Bonnet on comp.lang.tcl. Note that individual low-level reads and
- writes are still smaller as the optimal buffer size is smaller.
-
-2010-03-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/stub16.c: Don't hide that we use the ASCII API here.
- (does someone still use that?)
- * win/tclWinPipe.c: 2 unnecessary type casts.
-
-2010-03-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (TclCompileThrowCmd): Added compilation for
- the [throw] command.
-
-2010-03-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclListObj.c: [Bug 2971669]: Prevent in overflow trouble in
- * generic/tclTestObj.c: ListObjReplace operations. Thanks to kbk for
- * tests/listObj.test: fix and test.
-
-2010-03-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmdsSZ.c (IssueTryFinallyInstructions):
- [Bug 2971921]: Corrected jump so that it doesn't skip into the middle
- of an instruction! Tightened the instruction issuing. Moved endCatch
- calls closer to their point that they guard, ensuring correct ordering
- of result values.
-
-2010-03-17 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORTrans.c (ReflectInput, ReflectOutput)
- (ReflectSeekWide): [Bug 2921116]: Added missing TclEventuallyFree
- calls for preserved ReflectedTransform* structures. Reworked
- ReflectInput to preserve the structure for its whole life, not only in
- InvokeTclMethod.
-
- * generic/tclIO.c (Tcl_GetsObj): [Bug 2921116]: Regenerate topChan,
- may have been changed by a self-modifying transformation.
-
- * tests/ioTrans/test (iortrans-4.8, iortrans-4.9, iortrans-5.11)
- (iortrans-7.4, iortrans-8.3): New test cases.
-
-2010-03-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * compat/zlib/*: Upgrade zlib to version 1.2.4.
- * win/makefile.vc:
- * unix/Makefile.in:
- * win/tclWinChan.c: Don't cast away "const" without reason.
-
-2010-03-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/makefile.vc: [Bug 2967340]: Static build was failing.
- * win/.cvsignore:
-
-2010-03-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Remove unnecessary '&' decoration for
- * generic/tclIOUtil.c: function pointers
- * win/tclWin32Dll.c: Double declaration of TclNativeDupInternalRep
- * unix/tclIOUtil.c:
- * unix/dltest/.cvsignore: Ignore *.so here
-
-2010-03-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c: [Bug 2936225]: Thanks to Alexandre Ferrieux
- * doc/refchan.n: <ferrieux@users.sourceforge.net> for debugging and
- * tests/ioCmd.test: fixing the problem. It is the write-side
- equivalent to the bug fixed 2009-08-06.
-
-2010-03-09 Don Porter <dgp@users.sourceforge.net>
-
- * library/tzdata/America/Matamoros: New locale
- * library/tzdata/America/Ojinaga: New locale
- * library/tzdata/America/Santa_Isabel: New locale
- * library/tzdata/America/Asuncion:
- * library/tzdata/America/Tijuana:
- * library/tzdata/Antarctica/Casey:
- * library/tzdata/Antarctica/Davis:
- * library/tzdata/Antarctica/Mawson:
- * library/tzdata/Asia/Dhaka:
- * library/tzdata/Pacific/Fiji:
- Olson tzdata2010c.
-
-2010-03-07 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Test that tclOO stubs are present in stub
- library
- * generic/tclOOMethod.c: Applied missing part of [Patch 2961556]
- * win/tclWinInt.h: Change all tclWinProcs signatures to use
- * win/tclWin32Dll.c: TCHAR* in stead of WCHAR*. This is meant
- * win/tclWinDde.c: as preparation to make [Enh 2965056]
- * win/tclWinFCmd.c: possible at all.
- * win/tclWinFile.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c:
-
-2010-03-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStubLib.c: Remove presence of tclTomMathStubsPtr here.
- * generic/tclTest.c: Test that tommath stubs are present in stub
- library.
-
-2010-03-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIORTrans.c (ForwardProc): [Bug 2964425]: When cleaning
- the stables, it is sometimes necessary to do more than the minimum. In
- this case, rationalizing the variables for a forwarded limit? method
- required removing an extra Tcl_DecrRefCount too.
-
- * generic/tclOO.h, generic/tclOOInt.h: [Patch 2961556]: Change TclOO
- to use the same style of function typedefs as Tcl, as this is about
- the last chance to get this right.
-
- ***POTENTIAL INCOMPATIBILITY***
- Source code that uses function typedefs from TclOO will need to update
- variables and argument definitions so that pointers to the function
- values are used instead. Binary compatibility is not affected.
-
- * generic/*.c, generic/tclInt.h, unix/*.c, macosx/*.c: Applied results
- of doing a Code Audit. Principal changes:
- * Use do { ... } while (0) in macros
- * Avoid shadowing one local variable with another
- * Use clearer 'foo.bar++;' instead of '++foo.bar;' where result not
- required (i.e., semantically equivalent); clarity is increased
- because it is bar that is incremented, not foo.
- * Follow Engineering Manual rules on spacing and declarations
-
-2010-03-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (ObjectRenamedTrace): [Bug 2962664]: Add special
- handling so that when the class of classes is deleted, so is the class
- of objects. Immediately.
-
- * generic/tclOOInt.h (ROOT_CLASS): Add new flag for specially marking
- the root class. Simpler and more robust than the previous technique.
-
-2010-03-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclGetDate.y: 3 unnecessary MODULE_SCOPE
- * generic/tclDate.c: symbols
- * generic/tclStubLib.c: Split tommath stub lib
- * generic/tclTomMathStubLib.c: in separate file.
- * win/makefile.bc:
- * win/Makefile.in:
- * win/makefile.vc:
- * win/tcl.dsp:
- * unix/Makefile.in:
- * unix/tcl.m4: Cygwin only gives warning
- * unix/configure: using -fvisibility=hidden
- * compat/strncasecmp.c: A few more const's
- * compat/strtod.c:
- * compat/strtoul.c:
-
-2010-03-03 Andreas Kupries <andreask@activestate.com>
-
- * doc/refchan.n: Followup to ChangeLog entry 2009-10-07
- (generic/tclIORChan.c). Fixed the documentation to explain that errno
- numbers are operating system dependent, and reworked the associated
- example.
-
-2010-03-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: [FRQ 2959069]: Support for -fvisibility=hidden
- * unix/configure (regenerated with autoconf-2.59)
-
-2010-03-01 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * unix/tclUnixSock.c: Refrain from a possibly lengthy reverse-DNS
- lookup on 0.0.0.0 when calling [fconfigure -sockname] on an
- universally-bound (default) server socket.
-
- * generic/tclIndexObj.c: fix [AT 86258]: special-casing of empty
- tables when generating error messages for [::tcl::prefix match].
-
-2010-02-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c: More additions of {TCL LOOKUP} error-code
- generation to various subcommands of [info] as part of long-term
- project to classify all Tcl's generated errors.
-
-2010-02-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclStubInit.c: [Bug 2959713]: Link error with gcc 4.1
-
-2010-02-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (StringFirstCmd, StringLastCmd): [Bug 2960021]:
- Only search for the needle in the haystack when the needle isn't
- larger than the haystack. Prevents an odd crash from sometimes
- happening when things get mixed up (a common programming error).
-
- * generic/tclMain.c (Tcl_Main): [Bug 801429]: Factor out the holding
- of the client-installed main loop function into thread-specific data.
-
- ***POTENTIAL INCOMPATIBILITY***
- Code that previously tried to set the main loop from another thread
- will now fail. On the other hand, there is a fairly high probability
- that such programs would have been failing before due to the lack of
- any kind of inter-thread memory barriers guarding accesses to this
- part of Tcl's state.
-
-2010-02-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c: Split this file into two pieces to make it
- * generic/tclCompCmdsSZ.c: easier to work with. It's still two very
- long files even after the split.
-
-2010-02-26 Reinhard Max <max@suse.de>
-
- * doc/safe.n: Name the installed file after the command it documents.
- Use "Safe Tcl" instead of the "Safe Base", "Safe Tcl" mixture.
-
-2010-02-26 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/Makefile.in (NATIVE_TCLSH): Added this variable to allow for
- better control of what tclsh to use for various scripts when doing
- cross compiling. An imperfect solution, but works.
-
- * unix/installManPage: Remap non-alphanumeric sequences in filenames
- to single underscores (especially colons).
-
-2010-02-26 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/zlib.test: Add tests for [Bug 2818131] which was crashing with
- mismatched zlib algorithms used in combination with gets. This issue
- has been fixed by Andreas's last commit.
-
-2010-02-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclHash.c: [FRQ 2958832]: Further speed-up of the
- * generic/tclLiteral.c: ouster-hash function.
- * generic/tclObj.c:
- * generic/tclCkalloc.c: Eliminate various unnecessary (ClientData)
- * generic/tclTest.c: type casts.
- * generic/tclTestObj.c:
- * generic/tclTestProcBodyObj.c:
- * unix/tclUnixTest.c:
- * unix/tclUnixTime.c:
- * unix/tclXtTest.c:
-
-2010-02-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (SetDictFromAny): Prevent the list<->dict
- * generic/tclListObj.c (SetListFromAny): conversion code from taking
- too many liberties. Stops loss of duplicate keys in some scenarios.
- Many thanks to Jean-Claude Wippler for finding this.
-
- * generic/tclExecute.c (TclExecuteByteCode): Reduce ifdef-fery and
- size of activation record. More variables shared across instructions
- than before.
-
- * doc/socket.n: [Bug 2957688]: Clarified that [socket -server] works
- with a command prefix. Extended example to show this in action.
-
-2010-02-22 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclZlib.c (ZlibTransformInput): [Bug 2762041]: Added a hack
- to work around the general problem, early EOF recognition based on the
- base-channel, instead of the data we have ready for reading in the
- transform. Long-term we need a proper general fix (likely tracking EOF
- on each level of the channel stack), with attendant complexity.
- Furthermore, Z_BUF_ERROR can be ignored, and must be when feeding the
- zlib code with single characters.
-
-2010-02-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixPort.h: Remove unnecessary EXTERN's, which already are
- in the global stub table.
- * unix/configure.in: Use @EXEEXT@ in stead of @EXT_SUFFIX@
- * unix/tcl.m4:
- * unix/Makefile.in: Use -DBUILD_tcl for CYGWIN
- * unix/configure: (regenerated)
- * unix/dltest/pkg*.c: Use EXTERN to control CYGWIN exported symbols
- * generic/tclCmdMZ.c: Remove some unnecessary type casts.
- * generic/tclCompCmds.c:
- * generic/tclTest.c:
- * generic/tclUtil.c:
-
-2010-02-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/regexp.test: Add test cases back ported from Jacl regexp work.
-
-2010-02-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclDate.c: Some more const tables.
- * generic/tclGetDate.y:
- * generic/regc_lex.c:
- * generic/regerror.c:
- * generic/tclStubLib.c:
- * generic/tclBasic.c: Fix [Bug 2954959] expr abs(0.0) is -0.0
- * tests/expr.test:
-
-2010-02-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileStringLenCmd): Make [string length]
- of a constant string be handled better (i.e., handle backslashes too).
-
-2010-02-19 Stuart Cassoff <stwo@users.sourceforge.net>
-
- * tcl.m4: Correct compiler/linker flags for threaded builds on
- OpenBSD.
- * configure: (regenerated).
-
-2010-02-19 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/installManPage: [Bug 2954638]: Correct behaviour of manual page
- installer. Also added armouring to check that assumptions about the
- initial state are actually valid (e.g., look for existing input file).
-
-2010-02-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclHash.c (HashStringKey): Restore these hash functions
- * generic/tclLiteral.c (HashString): to use the classic algorithm.
- * generic/tclObj.c (TclHashObjKey): Community felt normal case
- speed to be more important than resistance to malicious cases. For
- now, hashes that need to deal with the malicious case can use a custom
- hash table and install their own hash function, though that is not
- functionality exposed to the script level.
-
- * generic/tclCompCmds.c (TclCompileDictUpdateCmd): Stack depth must be
- correctly described when compiling a body to prevent crashes in some
- debugging modes.
-
-2010-02-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Change order of various struct members,
- fixing potential binary incompatibility with Tcl 8.5
-
-2010-02-16 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/configure.in, generic/tclIOUtil.c (Tcl_Stat): Updated so that
- we do not assume that all unix systems have the POSIX blkcnt_t type,
- since OpenBSD apparently does not.
-
- * generic/tclLiteral.c (HashString): Missed updating to FNV in one
- place; the literal table (a copy of the hash table code...)
-
-2010-02-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Reverted earlier rename from tcl*Stubs to
- * generic/tclBasic.c: tcl*ConstStubs, it's not necessary at all.
- * generic/tclOO.c:
- * generic/tclTomMathInterface.c:
- * generic/tclStubInit.c: (regenerated)
- * generic/tclOOStubInit.c: (regenerated)
- * generic/tclEnsemble.c:Fix signed-unsigned mismatch
- * win/tclWinInt.h: make tclWinProcs "const"
- * win/tclWin32Dll.c:
- * win/tclWinFCmd.c: Eliminate all internal Tcl_WinUtfToTChar
- * win/tclWinFile.c: and Tcl_WinTCharToUtf calls, needed
- * win/tclWinInit.c: for mslu support.
- * win/tclWinLoad.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/.cvsignore:
- * compat/unicows/readme.txt: [FRQ 2819611]: Add first part of MSLU
- * compat/unicows/license.txt: support.
- * compat/unicows/unicows.lib:
-
-2010-02-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (AllocObject, SquelchedNsFirst, ObjectRenamedTrace):
- * generic/tclNamesp.c (Tcl_DeleteNamespace): [Bug 2950259]: Revised
- the namespace deletion code to provide an additional internal callback
- that gets triggered early enough in namespace deletion to allow TclOO
- destructors to run sanely. Adjusted TclOO to take advantage of this,
- so making tearing down an object by killing its namespace appear to
- work seamlessly, which is needed for Itcl. (Note that this is not a
- feature that will ever be backported to 8.5, and it remains not a
- recommended way of deleting an object.)
-
-2010-02-13 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Divided the [switch]
- compiler into three pieces (after the model of [try]): a parser, an
- instruction-issuer for chained tests, and an instruction-issuer for
- jump tables.
-
- * generic/tclEnsemble.c: Split the ensemble engine out into its own
- file rather than keeping it mashed together with the namespace code.
-
-2010-02-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tcl.m4: Use -pipe for gcc on win32
- * win/configure: (mingw/cygwin) (regenerated)
- * win/.cvsignore: Add .lib, .exp and .res here
-
-2010-02-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/list.test: Add tests for explicit \0 in a string argument to
- the list command.
-
-2010-02-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIOCmd.c (Tcl_OpenObjCmd): [Bug 2949740]: Make sure that
- we do not try to put a NULL pipeline channel into binary mode.
-
-2010-02-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- [Bug 2826551, Patch 2948425]: Assorted regexp bugs related to -all,
- -line and -start options and newlines.
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): If -offset is given, treat it
- as the start of the line if the previous character was a newline. Fix
- nasty edge case where a zero length match would not advance the index.
- * tests/regexp.test: Add regression tests back ported from Jacl.
- Checks for a number of issues related to -line and newline handling. A
- few of tests were broken before the patch and continue to be broken,
- marked as knownBug.
-
-2010-02-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (ObjectRenamedTrace): [Bug 2949397]: Prevent
- destructors from running on the two core class objects when the whole
- interpreter is being destroyed.
-
-2010-02-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileTryCmd, IssueTryInstructions)
- (IssueTryFinallyInstructions): Added compiler for the [try] command.
- It is split into three pieces that handle the parsing of the tokens,
- the issuing of instructions for finally-free [try], and the issuing of
- instructions for [try] with finally; there are enough differences
- between the all cases that it was easier to split the code rather than
- have a single function do the whole thing.
-
-2010-02-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tools/genStubs.tcl: Remove dependency on 8.5+ idiom "in" in
- expressions.
-
-2010-02-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (Tcl_ZlibDeflate, Tcl_ZlibInflate): [Bug 2947783]:
- Make sure that the result is an unshared object before appending to it
- so that nothing crashes if it is shared (use in Tcl code was not
- affected by this, but use from C was an issue).
-
-2010-02-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclHash.c (HashStringKey): Replace Tcl's crusty old hash
- * generic/tclObj.c (TclHashObjKey): function with the algorithm
- due to Fowler, Noll and Vo. This is slightly faster (assuming the
- presence of hardware multiply) and has somewhat better distribution
- properties of the resulting hash values. Note that we only ever used
- the 32-bit version of the FNV algorithm; Tcl's core hash engine
- assumes that hash values are simple unsigned ints.
-
- ***POTENTIAL INCOMPATIBILITY***
- Code that depends on hash iteration order (especially tests) may well
- be disrupted by this. Where a definite order is required, the fix is
- usually to just sort the results after extracting them from the hash.
- Where this is insufficient, the code that has ceased working was
- always wrong and was only working by chance.
-
-2010-02-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileErrorCmd): Added compilation of the
- [error] command. No new bytecodes.
-
-2010-02-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Follow-up to earlier commit today:
- Eliminate the need for an extra Stubs Pointer for adressing
- a static stub table: Just change the exported table from
- static to MODULE_SCOPE.
- * generic/tclBasic.c
- * generic/tclOO.c
- * generic/tclTomMathInterface.c
- * generic/tcl*Decls.h (regenerated)
- * generic/tclStubInit.c (regenerated)
- * generic/tclOOStubInit.c (regenerated)
- * generic/tclTest.c (minor formatting)
-
-2010-02-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c: More consistency in errorcode generation.
-
- * generic/tclOOBasic.c (TclOO_Object_Destroy): Rewrote to be NRE-aware
- when calling destructors. Note that there is no guarantee that
- destructors will always be called in an NRE context; that's a feature
- of the 'destroy' method only.
-
- * generic/tclEncoding.c: Add 'const' to many function-internal vars
- that are never pointing to things that are written to.
-
-2010-02-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Follow-up to [2010-01-29] commit:
- prevent space within stub table function parameters if the
- parameter type is a pointer.
- * win/tclWinInt.h: Minor Formatting
- * generic/tcl.h: VOID -> void and other formatting
- * generic/tclInt.h: Minor formatting
- * generic/tclInt.decls: Change signature of TclNRInterpProcCore,
- * generic/tclOO.decls: and TclOONewProc(Instance|)MethodEx,
- * generic/tclProc.c: indicating that errorProc is a function,
- * generic/tclOOMethod.c:pointer, and other formatting
- * generic/tcl*Decls.h: (regenerated)
- * generic/tclVar.c: gcc warning(line 3703): 'pattern' may be used
- uninitialized in this function
- gcc warning(line 3788): 'matched' may be used
- uninitialized in this function
-
-2010-02-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c: Added more use of error-codes and reduced the
- stack overhead of older interfaces.
- (ArrayGetCmd): Stop silly crash when using a trivial pattern due to
- error in conversion to ensemble.
- (ArrayNamesCmd): Use the object RE interface for faster matching.
-
-2010-02-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c (ArrayUnsetCmd): More corrections.
-
-2010-02-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c: Turned the [array] command into a true ensemble.
-
- * generic/tclOO.c (AllocObject, MyDeleted): A slightly faster way to
- handle the deletion of [my] is with a standard delete callback. This
- is because it doesn't require an additional memory allocation during
- object creation. Also reduced the amount of string manipulation
- performed during object creation to further streamline memory
- handling; this is not backported to the 8.5 package as it breaks a
- number of abstractions.
-
- * generic/tclOOBasic.c (TclOO_Object_Destroy): [Bug 2944404]: Do not
- crash when a destructor deletes the object that is executing that
- destructor.
-
-2010-02-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): [Bug 2939073]: Stop the [array
- unset] command from having dangling pointer problems when an unset
- trace deletes the element that is going to be processed next. Many
- thanks to Alexandre Ferrieux for the bulk of this fix.
-
- * generic/regexec.c (ccondissect, crevdissect): [Bug 2942697]: Rework
- these functions so that certain pathological patterns are matched much
- more rapidly. Many thanks to Tom Lane for dianosing this issue and
- providing an initial patch.
-
-2010-01-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompile.c (tclInstructionTable): Bytecode instructions
- * generic/tclCompCmds.c (TclCompileUnsetCmd): to allow the [unset]
- * generic/tclExecute.c (TclExecuteByteCode): command to be compiled
- with the compiler being a complete compilation for all compile-time
- decidable uses.
-
- * generic/tclVar.c (TclPtrUnsetVar): Var reference version of the code
- to unset a variable. Required for INST_UNSET bytecodes.
-
-2010-01-29 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: [Bug 2942081]: Reverted Tcl_ThreadDataKey type change
- Changed some Tcl_CallFrame fields from "char *"
- to "void *". This saves unnecessary space on
- Cray's (and it's simply more correct).
-
- * tools/genStubs.tcl: No longer generate a space after "*" and
- immediately after a function name, so the
- format of function definitions in tcl*Decls.h
- match all other tcl*.h header files.
- * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc
- * generic/tcl.h: and GetFrameInfoValueProc to be function
- * generic/tclInt.h: definitions, not pointers, for consistency
- * generic/tclOOInt.h: with all other Tcl function definitions.
- * generic/tclIndexObj.c:
- * generic/regguts.h: CONST -> const
- * generic/tcl.decls: Formatting
- * generic/tclTomMath.decls: Formatting
- * generic/tclDecls.h: (regenerated)
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclOODecls.h:
- * generic/tclOOIntDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclTomMathDecls.h:
-
-2010-01-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOO_Object_Destroy): Move the execution of
- destructors to a point where they can produce an error. This will not
- work for all destructors, but it does mean that more failing calls of
- them will be caught.
- * generic/tclOO.c (AllocObject, MyDeletedTrace, ObjectRenamedTrace):
- (ObjectNamespaceDeleted): Stop various ways of getting at commands
- with dangling pointers to the object. Also increases the reliability
- of calling of destructors (though most destructors won't benefit; when
- an object is deleted namespace-first, its destructors are not run in a
- nice state as the namespace is partially gone).
-
-2010-01-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclOOStubInit.c: Remove double includes (which causes a
- * generic/tclOOStubLib.c: warning in CYGWIN compiles)
- * unix/.cvsignore: add confdefs.h
-
-2010-01-22 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/proc.n: [Bug 1970629]: Define a bit better what the current
- namespace of a procedure is.
-
-2010-01-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Don't use DWORD and HANDLE here.
- * generic/tclIntPlatDecls.h:
- * generic/tcl.h: Revert [2009-12-21] change, instead
- * generic/tclPort.h: resolve the CYGWIN inclusion problems by
- * win/tclWinPort.h: re-arranging the inclusions at other
- places.
- * win/tclWinError.c
- * win/tclWinPipe.c
- * win/tcl.m4: Make cygwin configuration error into
- * win/configure.in: a warning: CYGWIN compilation works
- * win/configure: although there still are test failures.
-
-2010-01-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Improve error code
- generation from some of the tailcall-related bits of TEBC.
-
-2010-01-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.h: [Bug 2910748]: NRE-enable direct eval on BC
- * generic/tclExecute.c: spoilage.
- * tests/nre.test:
-
-2010-01-19 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: [Bug 2929546]: Clarify just what [dict with] and [dict
- update] are doing with variables.
-
-2010-01-18 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CreateScriptRecord): [Bug 2918110]: Initialize
- the EventScriptRecord (esPtr) fully before handing it to
- Tcl_CreateChannelHandler for registration. Otherwise a reflected
- channel calling 'chan postevent' (== Tcl_NotifyChannel) in its
- 'watchProc' will cause the function 'TclChannelEventScriptInvoker'
- to be run on an uninitialized structure.
-
-2010-01-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclStringObj.c (Tcl_AppendFormatToObj): [Bug 2932421]: Stop
- the [format] command from causing argument objects to change their
- internal representation when not needed. Thanks to Alexandre Ferrieux
- for this fix.
-
-2010-01-13 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl: More factoring out of special cases
- * tools/tcltk-man2html-utils.tcl: so that they are described outside
- the engine file. Now there is only one real set of special cases in
- there, to handle the .SO/.OP/.SE directives.
-
-2010-01-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Fix TCL_LL_MODIFIER for Cygwin
- * generic/tclEnv.c: Fix CYGWIN compilation problems,
- * generic/tclInt.h: and remove some unnecessary
- * generic/tclPort.h: double includes.
- * generic/tclPlatDecls.h:
- * win/cat.c:
- * win/tclWinConsole.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/tclWinThrd.c:
- * win/tclWinPort.h: Put win32 includes first
- * unix/tclUnixChan.c: Forgot one CONST change
-
-2010-01-12 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl: Make the generation of the list of things
- to process the docs from simpler and more flexible. Also factored out
- the lists of special cases.
-
-2010-01-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: VC++ 6.0 doesn't have
- * win/tclWinReg.c: PDWORD_PTR
- * win/tclWinThrd.c: Fix various minor gcc warnings.
- * win/tclWinTime.c:
- * win/tclWinConsole.c: Put channel type definitions
- * win/tclWinChan.c: in static const memory
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
- * generic/tclIOGT.c:
- * generic/tclIORChan.c:
- * generic/tclIORTrans.c:
- * unix/tclUnixChan.c:
- * unix/tclUnixPipe.c:
- * unix/tclUnixSock.c:
- * unix/configure: (regenerated with autoconf 2.59)
- * tests/info.test: Make test independant from
- tcltest implementation.
-
-2010-01-10 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/namespace.test (namespace-51.17): [Bug 2898722]: Demonstrate
- that there are still bugs in the handling of resolution epochs. This
- bug is not yet fixed.
-
- * tools/tcltk-man2html.tcl: Split the man->html converter into
- * tools/tcltk-man2html-utils.tcl: two pieces for easier maintenance.
- Also made it much less verbose in its printed messages by default.
-
-2010-01-09 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl: Added basic support for building the docs
- for contributed packages into the HTML versions. Prompted by question
- on Tcler's Chat by Tom Krehbiel. Note that there remain problems in
- the documentation generated due to errors in the contributed docs.
-
-2010-01-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c (TclPathPart): [Bug 2918610]: Correct
- * tests/fileName.test (filename-14.31): inconsistency between the
- string rep and the intrep of a path value created by [file rootname].
- Thanks to Vitaly Magerya for reporting.
-
-2010-01-03 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 1636685]: Use the configuration
- for modern FreeBSD suggested by the FreeBSD porter.
-
-2010-01-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bug 2724403]: Fix leak of coroutines on
- * generic/tclCompile.h: namespace deletion. Added a test for this
- * generic/tclNamesp.c: leak, and also a test for leaks on namespace
- * tests/coroutine.test: deletion.
- * tests/namespace.test:
-
-2009-12-30 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (AliasSource): [Bug 2923613]: Make the safer
- * tests/safe.test (safe-8.9): [source] handle a [return] at the
- end of the file correctly.
-
-2009-12-30 Miguel Sofer <msofer@users.sf.net>
-
- * library/init.tcl (unknown): [Bug 2824981]: Fix infinite recursion of
- ::unknown when [set] is undefined.
-
-2009-12-29 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclHistory.c (Tcl_RecordAndEvalObj): Reduce the amount of
- allocation and deallocation of memory by caching objects in the
- interpreter assocData table.
-
- * generic/tclObj.c (Tcl_GetCommandFromObj): Rewrite the logic so that
- it does not require making assignments part way through an 'if'
- condition, which was deeply unclear.
-
- * generic/tclInterp.c (Tcl_MakeSafe): [Bug 2895741]: Make sure that
- the min() and max() functions are supported in safe interpreters.
-
-2009-12-29 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclBinary.c: [Bug 2922555]: Handle completely invalid input
- * tests/binary.test: to the decode methods.
-
-2009-12-28 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/Makefile.in (trace-shell, trace-test): [FRQ 1083288]: Added
- targets to allow easier tracing of shell and test invocations.
-
- * unix/configure.in: [Bug 942170]: Detect the st_blocks field of
- * generic/tclCmdAH.c (StoreStatData): 'struct stat' correctly.
- * generic/tclFileName.c (Tcl_GetBlocksFromStat):
- * generic/tclIOUtil.c (Tcl_Stat):
-
- * generic/tclInterp.c (TimeLimitCallback): [Bug 2891362]: Ensure that
- * tests/interp.test (interp-34.13): the granularity ticker is
- reset when we check limits because of the time limit event firing.
-
-2009-12-27 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/namespace.n (SCOPED SCRIPTS): [Bug 2921538]: Updated example to
- not be quite so ancient.
-
-2009-12-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCmdMZ.c: CONST -> const
- * generic/tclParse.c
-
-2009-12-23 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (AliasSource, AliasExeName): [Bug 2913625]: Stop
- information about paths from leaking through [info script] and [info
- nameofexecutable].
-
-2009-12-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: Install libtcl8.6.dll in bin directory
- * unix/Makefile.in:
- * unix/configure: (regenerated)
-
-2009-12-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): [Bug 2918962]: Stop crash when
- -index and -stride are used together.
-
-2009-12-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclThreadStorage.c: Fix gcc warning, using gcc-4.3.4 on
- cygwin: missing initializer
- * generic/tclOOInt.h: Prevent conflict with DUPLICATE
- definition in WINAPI's nb30.h
- * generic/rege_dfa.c: Fix macro conflict on CYGWIN: don't use
- "small".
- * generic/tcl.h: Include <winsock2.h> before <stdio.h> on
- CYGWIN
- * generic/tclPathObj.c
- * generic/tclPort.h
- * tests/env.test: Don't unset WINDIR and TERM, it has a
- special meaning on CYGWIN (both in UNIX
- and WIN32 mode!)
- * generic/tclPlatDecls.h: Include <tchar.h> through tclPlatDecls.h
- * win/tclWinPort.h: stricmp -> strcasecmp
- * win/tclWinDde.c: _wcsicmp -> wcscasecmp
- * win/tclWinFile.c
- * win/tclWinPipe.c
- * win/tclWinSock.c
- * unix/tcl.m4: Add dynamic loading support to CYGWIN
- * unix/configure (regenerated)
- * unix/Makefile.in
-
-2009-12-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bug 2917627]: Fix for bad cmd resolution by
- * tests/coroutine.test: coroutines. Thanks to schelte for finding it.
-
-2009-12-16 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (::safe::AliasGlob): Upgrade to correctly support a
- larger fraction of [glob] functionality, while being stricter about
- directory management.
-
-2009-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Fix gcc warning: ignoring return value of
- * unix/tclUnixNotify.c: "write", declared with attribute
- * unix/tclUnixPipe.c: warn_unused_result.
- * generic/tclInt.decls: CONSTify functions TclpGetUserHome and
- * generic/tclIntDecls.h:TclSetPreInitScript (TIP #27)
- * generic/tclInterp.c:
- * win/tclWinFile.c:
- * unix/tclUnixFile.c:
-
-2009-12-16 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/tm.n: [Bug 1911342]: Formatting rewrite to avoid bogus crosslink
- to the list manpage when generating HTML.
-
- * library/msgcat/msgcat.tcl (Init): [Bug 2913616]: Do not use platform
- tests that are not needed and which don't work in safe interpreters.
-
-2009-12-14 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/file.n (file tempfile): [Bug 2388866]: Note that this only ever
- creates files on the native filesystem. This is a design feature.
-
-2009-12-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Release TclPopCallFrame() from its
- * generic/tclExecute.c: tailcall-management duties
- * generic/tclNamesp.c:
-
- * generic/tclBasic.c: Moving TclBCArgumentRelease call from
- * generic/tclExecute.c: TclNRTailcallObjCmd to TEBC, so that the
- pairing of the Enter and Release calls is clearer.
-
-2009-12-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclTest.c (TestconcatobjCmd): [Bug 2895367]: Stop memory
- leak when testing. We don't need extra noise of this sort when
- tracking down real problems!
-
-2009-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclBinary.c: Fix gcc warning, using gcc-4.3.4 on cygwin
- * generic/tclCompExpr.c:warning: array subscript has type 'char'
- * generic/tclPkg.c:
- * libtommath/bn_mp_read_radix.c:
- * win/makefile.vc: [Bug 2912773]: Revert to version 1.203
- * unix/tclUnixCompat.c: Fix gcc warning: signed and unsigned type
- in conditional expression.
-
-2009-12-11 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (long-toc, cross-reference): [FRQ 2897296]:
- Added cross links to sections within manual pages.
-
-2009-12-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bug 2806407]: Full nre-enabling of coroutines
- * generic/tclExecute.c:
-
- * generic/tclBasic.c: Small cleanup
-
- * generic/tclExecute.c: Fix panic in http11.test caused by buggy
- earlier commits in coroutine management.
-
-2009-12-10 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclObj.c (TclContinuationsEnter): [Bug 2895323]: Updated
- comments to describe when the function can be entered for the same
- Tcl_Obj* multiple times. This is a continuation of the 2009-11-10
- entry where a memory leak was plugged, but where not sure if that was
- just a band-aid to paper over some other error. It isn't, this is a
- legal situation.
-
-2009-12-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Reducing the # of moving parts for coroutines
- * generic/tclExecute.c: by delegating more to tebc; eliminate the
- special coroutine CallFrame.
-
-2009-12-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c: [Bug 2901998]: Applied Alexandre Ferrieux's patch
- fixing the inconsistent buffered I/O. Tcl's I/O now flushes buffered
- output before reading, discards buffered input before writing, etc.
-
-2009-12-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Ensure right lifetime of varFrame's (objc,objv)
- for coroutines.
-
- * generic/tclExecute.c: Code regrouping
-
-2009-12-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c: Added some of the missing setting of errorcode
- values.
-
-2009-12-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclStackFree): Improved panic msg.
-
-2009-12-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Partial nre-enabling of coroutines. The
- * generic/tclExecute.c: initial call still requires its own
- * generic/tclInt.h: instance of tebc, but on resume coros can
- execute in the caller's tebc.
-
- * generic/tclExecute.c (TEBC): Silence warning about pcAdjustment.
-
-2009-12-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Make the dict opcodes
- more sparing in their use of C variables, to reduce size of TEBC
- activiation record a little bit.
-
-2009-12-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC): Grouping "slow" variables into structs,
- to reduce register pressure and help the compiler with variable
- allocation.
-
-2009-12-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Start cleaning the TEBC stables
- * generic/tclInt.h:
-
- * generic/tclCmdIL.c: [Bug 2910094]: Fix by aku
- * tests/coroutine.test:
-
- * generic/tclBasic.c: Arrange for [tailcall] to be created with the
- other builtins: was being created in a separate call, leftover from
- pre-tip days.
-
-2009-12-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStrToD.c: [Bug 2902010]: Correct conditional compile
- directives to better detect the toolchain that needs extra work for
- proper underflow treatment instead of merely detecting the MIPS
- platform.
-
-2009-12-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Patch 2910056]: Add ::tcl::unsupported::yieldTo
- * generic/tclInt.h:
-
-2009-12-07 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (TryPostBody): [Bug 2910044]: Close off memory
- leak in [try] when a variable-free handler clause is present.
-
-2009-12-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Small changes for clarity in tailcall
- * generic/tclExecute.c: and coroutine code.
- * tests/coroutine.test:
-
- * tests/tailcall.test: Remove some old unused crud; improved the
- stack depth tests.
-
- * generic/tclBasic.c: Fixed things so that you can tailcall
- * generic/tclNamesp.c: properly out of a coroutine.
- * tests/tailcall.test:
-
- * generic/tclInterp.c: Fixed tailcalls for same-interp aliases (no
- test)
-
-2009-12-03 Donal K. Fellows <dkf@users.sf.net>
-
- * library/safe.tcl (::safe::AliasEncoding): Make the safe encoding
- command behave more closely like the unsafe one (for safe ops).
- (::safe::AliasGlob): [Bug 2906841]: Clamp down on evil use of [glob]
- in safe interpreters.
- * tests/safe.test: Rewrite to use tcltest2 better.
-
-2009-12-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * tools/genStubs.tcl: Add support for win32 CALLBACK functions and
- remove obsolete "emitStubs" and "genStubs" functions.
- * win/Makefile.in: Use tcltest86.dll for all tests, and add
- .PHONY rules to preemptively stop trouble that plagued Tk from hitting
- Tcl too.
-
-2009-11-30 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: Don't use EXPORT for Tcl_InitStubs
- * win/Makefile.in: Better dependancies in case of static build.
-
-2009-11-30 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/Tcl.n: [Bug 2901433]: Improved description of expansion to
- mention that it is using list syntax.
-
-2009-11-27 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclAppInit.c (Tcl_AppInit): [Bug 2902965]: Reverted Jan's change
- that added a call to Tcl_InitStubs. The 'tclsh' and 'tcltest' programs
- are providers, not consumers of the Stubs table, and should not link
- with the Stubs library, but only with the main Tcl library. (In any
- case, the presence of Tcl_InitStubs broke the build.)
-
-2009-11-27 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/BoolObj.3, doc/Class.3, doc/CrtChannel.3, doc/DictObj.3:
- * doc/DoubleObj.3, doc/Ensemble.3, doc/Environment.3:
- * doc/FileSystem.3, doc/Hash.3, doc/IntObj.3, doc/Limit.3:
- * doc/Method.3, doc/NRE.3, doc/ObjectType.3, doc/PkgRequire.3:
- * doc/SetChanErr.3, doc/SetResult.3: [Patch 2903921]: Many small
- spelling fixes from Larry Virden.
-
- BUMP VERSION OF TCLOO TO 0.6.2. Too many people need accumulated small
- versions and bugfixes, so the version-bump removes confusion.
-
- * generic/tclOOBasic.c (TclOO_Object_LinkVar): [Bug 2903811]: Remove
- unneeded restrictions on who can usefully call this method.
-
-2009-11-26 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/Makefile.in: Add .PHONY rules and documentation to preemptively
- stop trouble that plagued Tk from hitting Tcl too, and to make the
- overall makefile easier to understand. Some reorganization too to move
- related rules closer together.
-
-2009-11-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: [Bug 2902965]: Fix stub related changes that
- * win/makefile.vc: caused tclkit build to break.
- * win/tclAppInit.c
- * unix/tcl.m4
- * unix/Makefile.in
- * unix/tclAppInit.c
- * unix/configure: (regenerated)
-
-2009-11-25 Kevin B. Kenny <kennykb@acm.org>
-
- * win/Makefile.in: Added a 'test-tcl' rule that is identical to
- 'test' except that it does not go spelunking in 'pkgs/'. (This rule
- has existed in unix/Makefile.in for some time.)
-
-2009-11-25 Stuart Cassoff <stwo@users.sf.net>
-
- * unix/configure.in: [Patch 2892871]: Remove unneeded
- * unix/tcl.m4: AC_STRUCT_TIMEZONE and use
- * unix/tclConfig.h.in: AC_CHECK_MEMBERS([struct stat.st_blksize])
- * unix/tclUnixFCmd.c: instead of AC_STRUCT_ST_BLKSIZE.
- * unix/configure: Regenerated with autoconf-2.59.
-
-2009-11-24 Andreas Kupries <andreask@activestate.com>
-
- * library/tclIndex: Manually redone the part of tclIndex dealing with
- safe.tcl and tm.tcl. This part passes the testsuite. Note that
- automatic regeneration of this part is not possible because it wrongly
- puts 'safe::Setup' on the list, and wrongly leaves out 'safe::Log'
- which is more dynamically created than the generator expects.
-
- Further note that the file "clock.tcl" is explicitly loaded by
- "init.tcl", the first time the clock command is invoked. The relevant
- code can be found at line 172ff, roughly, the definition of the
- procedure 'clock'. This means none of the procedures of this file
- belong in the tclIndex. Another indicator that automatic regeneration
- of tclIndex is ill-advised.
-
-2009-11-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (FinalizeAlloc, Tcl_NewObjectInstance):
- [Bug 2903011]: Make it an error to destroy an object in a constructor,
- and also make sure that an object is not deleted twice in the error
- case.
-
-2009-11-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/fCmd.test: [Bug 2893771]: Teach [file stat] to handle locked
- * win/tclWinFile.c: files so that [file exists] no longer lies.
-
-2009-11-23 Kevin Kenny <kennykb@acm.org>
-
- * tests/fCmd.test (fCmd-30.1): Changed registry location of the 'My
- Documents' folder to the one that's correct for Windows 2000, XP,
- Server 2003, Vista, Server 2008, and Windows 7. (See
- http://support.microsoft.com/kb/310746)
-
-2009-11-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWinDde.c: #undef STATIC_BUILD, in order to make sure
- * win/tclWinReg.c: that Xxxxx_Init is always exported even when
- * generic/tclTest.c: Tcl is built static (otherwise we cannot
- create a DLL).
- * generic/tclThreadTest.c: Make all functions static, except
- TclThread_Init.
- * tests/fCmd.test: Enable fCmd-30.1 when registry is available.
- * win/tcl.m4: Fix ${SHLIB_LD_LIBS} definition, fix conflicts
- * win/Makefile.in: Simplifications related to tcl.m4 changes.
- * win/configure.in: Between static libraries and import library on
- windows.
- * win/configure: (regenerated)
- * win/makefile.vc: Add stub library to necessary link lines.
-
-2009-11-23 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclThreadTest.c (NewTestThread): [Bug 2901803]: Further
- machinations to get NewTestThread actually to launch the thread, not
- just compile.
-
-2009-11-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclThreadTest.c (NewTestThread): [Bug 2901803]: Fix small
- error in function naming which blocked a threaded test build.
-
-2009-11-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: Create tcltest86.dll as dynamic Tcltest
- package.
- * generic/tclTest.c: Remove extraneous prototypes, follow-up to
- * generic/tclTestObj.c: [Bug 2883850]
- * tests/chanio.test: Test-cases for fixed [Bug 2849797]
- * tests/io.test:
- * tests/safe.test: Fix safe-10.1 and safe-10.4 test cases, making
- the wrong assumption that Tcltest is a static
- package.
- * generic/tclEncoding.c:[Bug 2857044]: Updated freeIntRepProc routines
- * generic/tclVar.c: so that they set the typePtr field to NULL so
- that the Tcl_Obj is not left in an
- inconsistent state.
- * unix/tcl.m4: [Patch 2883533]: tcl.m4 support for Haiku OS
- * unix/configure: autoconf-2.59
-
-2009-11-19 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclAppInit.c: [Bug 2883850, 2900542]: Repair broken build of
- * win/tclAppInit.c: the tcltest executable.
-
-2009-11-19 Donal K. Fellows <dkf@users.sf.net>
-
- * library/auto.tcl (tcl_findLibrary):
- * library/clock.tcl (MakeUniquePrefixRegexp, MakeParseCodeFromFields)
- (SetupTimeZone, ProcessPosixTimeZone): Restored the use of a literal
- * library/history.tcl (HistAdd): 'then' when following a multi-
- * library/safe.tcl (interpConfigure): line test expresssion. It's an
- * library/tm.tcl (UnknownHandler): aid to readability then.
-
-2009-11-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Make all internal initialization
- * generic/tclTest.c: routines MODULE_SCOPE
- * generic/tclTestObj.c:
- * generic/tclTestProcBodyObj.c:
- * generic/tclThreadTest.c:
- * unix/Makefile.in: Fix [Bug 2883850]: pkgIndex.tcl doesn't
- * unix/tclAppInit.c: get created with static Tcl build
- * unix/tclXtTest.c:
- * unix/tclXtNotify.c:
- * unix/tclUnixTest.c:
- * win/Makefile.in:
- * win/tcl.m4:
- * win/configure: (regenerated)
- * win/tclAppInit.c:
- * win/tclWinDde.c: Always compile with Stubs.
- * win/tclWinReg.c:
- * win/tclWinTest.c:
-
-2009-11-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/CrtChannel.3: [Bug 2849797]: Fix channel name inconsistences
- * generic/tclIORChan.c: as suggested by DKF.
- * generic/tclIO.c: Minor *** POTENTIAL INCOMPATIBILITY ***
- because Tcl_CreateChannel() and derivatives
- now sometimes ignore their "chanName"
- argument.
-
- * generic/tclAsync.c: Eliminate various gcc warnings (with -Wextra)
- * generic/tclBasic.c
- * generic/tclBinary.c
- * generic/tclCmdAH.c
- * generic/tclCmdIL.c
- * generic/tclCmdMZ.c
- * generic/tclCompile.c
- * generic/tclDate.c
- * generic/tclExecute.c
- * generic/tclDictObj.c
- * generic/tclIndexObj.c
- * generic/tclIOCmd.c
- * generic/tclIOUtil.c
- * generic/tclIORTrans.c
- * generic/tclOO.c
- * generic/tclZlib.c
- * generic/tclGetDate.y
- * win/tclWinInit.c
- * win/tclWinChan.c
- * win/tclWinConsole.c
- * win/tclWinNotify.c
- * win/tclWinReg.c
- * library/auto.tcl: Eliminate "then" keyword
- * library/clock.tcl
- * library/history.tcl
- * library/safe.tcl
- * library/tm.tcl
- * library/http/http.tcl: Eliminate unnecessary spaces
- * library/http1.0/http.tcl
- * library/msgcat/msgcat.tcl
- * library/opt/optparse.tcl
- * library/platform/platform.tcl
- * tools/tcltk-man2html.tcl
- * tools/tclZIC.tcl
- * tools/tsdPerf.c
-
-2009-11-17 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixChan.c (TtyParseMode): Partial undo of Donal's tidy-up
- from a few days ago (2009-11-9, not in ChangeLog). It seems that
- strchr is apparently a macro on AIX and reacts badly to preprocessor
- directives in its arguments.
-
-2009-11-16 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclEncoding.c: [Bug 2891556]: Fix and improve test to
- * generic/tclTest.c: detect similar manifestations in the future.
- * tests/encoding.test: Add tcltest support for finalization.
-
-2009-11-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinDde.c: Avoid gcc compiler warning by explicitly casting
- DdeCreateStringHandle argument.
-
-2009-11-12 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CopyData): [Bug 2895565]: Dropped bogosity which
- * tests/io.test: used the number of _written_ bytes or character to
- update the counters for the read bytes/characters. New test io-53.11.
- This is a forward port from the 8.5 branch.
-
-2009-11-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclClock.c (TclClockInit): Do not create [clock] support
- commands in safe interps.
-
-2009-11-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/http/http.tcl (http::geturl): [Bug 2891171]: URL checking
- too strict when using multiple question marks.
- * tests/http.test
- * library/http/pkgIndex.tcl: Bump to http 2.8.2
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2009-11-11 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclIO.c: Fix [Bug 2888099] (close discards ENOSPC error) by
- saving the errno from the first of two FlushChannel()s. Uneasy to
- test; might need specific channel drivers. Four-hands with aku.
-
-2009-11-10 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/winFCmd.test: Cleanup directories that have been set chmod
- 000. On Windows7 and Vista we really have no access and these were
- getting left behind.
- A few tests were changed to reflect the intent of the test where
- setting a directory chmod 000 should prevent any modification. This
- restriction was ignored on XP but is honoured on Vista
-
-2009-11-10 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c: Plug another leak in TCL_EVAL_DIRECT evaluation.
- Forward port from Tcl 8.5 branch, change by Don Porter.
-
- * generic/tclObj.c: [Bug 2895323]: Plug memory leak in
- TclContinuationsEnter(). Forward port from Tcl 8.5 branch, change by
- Don Porter.
-
-2009-11-09 Stuart Cassoff <stwo@users.sf.net>
-
- * win/README: [bug 2459744]: Removed outdated Msys + Mingw info.
-
-2009-11-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c (TclEvalObjEx): Moved the #280 decrement of
- refCount for the file path out of the branch after the whole
- conditional, closing a memory leak. Added clause on structure type to
- prevent seg.faulting. Forward port from valgrinding the Tcl 8.5
- branch.
-
- * tests/info.test: Resolve ambiguous resolution of variable "res".
- Forward port from 8.5
-
-2009-11-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/string.n (bytelength): Noted that this command is not a good
- thing to use, and suggested a better alternatve. Also factored out the
- description of the indices into its own section.
-
-2009-11-07 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/fCmd.test: [Bug 2891026]: Exclude tests using chmod 555
- directories on vista and win7. The current user has access denied and
- so cannot rename the directory without admin privileges.
-
-2009-11-06 Andreas Kupries <andreask@activestate.com>
-
- * library/safe.tcl (::safe::Setup): Added documentation of the
- contents of the state array. Also killed the 'InterpState' procedure
- with its upleveled variable/upvar combination, and replaced all uses
- with 'namespace upvar'.
-
-2009-11-05 Andreas Kupries <andreask@activestate.com>
-
- * library/safe.tcl: A series of patches which bring the SafeBase up to
- date with code guidelines, Tcl's features, also eliminating a number
- of inefficiencies along the way.
- (1) Changed all procedure names to be fully qualified.
- (2) Moved the procedures out of the namespace eval. Kept their
- locations. IOW, broke the namespace eval apart into small sections not
- covering the procedure definitions.
- (3) Reindented the code. Just lots of whitespace changes.
- Functionality unchanged.
- (4) Moved the multiple namespace eval's around. Command export at the
- top, everything else (var decls, argument parsing setup) at the
- bottom.
- (5) Moved the argument parsing setup into a procedure called when the
- code is loaded. Easier management of temporary data.
- (6) Replaced several uses of 'Set' with calls to the new procedure
- 'InterpState' and direct access to the per-slave state array.
- (7) Replaced the remaining uses of 'Set' and others outside of the
- path/token handling, and deleted a number of procedures related to
- state array access which are not used any longer.
- (8) Converted the path token system to cache normalized paths and path
- <-> token conversions. Removed more procedures not used any longer.
- Removed the test cases 4.3 and 4.4 from safe.test. They were testing
- the now deleted command "InterpStateName".
- (9) Changed the log command setup so that logging is compiled out
- completely when disabled (default).
- (10) Misc. cleanup. Inlined IsInterp into CheckInterp, its only user.
- Consistent 'return -code error' for error reporting. Updated to use
- modern features (lassign, in/ni, dicts). The latter are used to keep a
- reverse path -> token map and quicker check of existence.
- (11) Fixed [Bug 2854929]: Recurse into all subdirs under all TM root
- dirs and put them on the access path.
-
-2009-11-02 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Asia/Novokuznetsk: New tzdata locale for Kemerovo
- oblast', which now keeps Novosibirsk time and not Kranoyarsk time.
- * library/tzdata/Asia/Damascus: Syrian DST changes.
- * library/tzdata/Asia/Hong_Kong: Hong Kong historic DST corrections.
- Olson tzdata2009q.
-
-2009-11-02 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/object.n (DESCRIPTION): Substantive revision to make it clearer
- what the fundamental semantics of an object actually are.
-
-2009-11-01 Joe Mistachkin <joe@mistachkin.com>
-
- * doc/Cancel.3: Minor cosmetic fixes.
- * win/makefile.vc: Make htmlhelp target work again. An extra set of
- double quotes around the definition of the HTML help compiler tool
- appears to be required. Previously, there was one set of double
- quotes around the definition of the tool and one around the actual
- invocation. This led to confusion because it was the only such tool
- path to include double quotes around its invocation. Also, it was
- somewhat inflexible in the event that somebody needed to override the
- tool command to include arguments. Therefore, even though it may look
- "wrong", there are now two double quotes on either side of the tool
- path definition. This fixes the problem that currently prevents the
- htmlhelp target from building and maintains flexibility in case
- somebody needs to override it via the command line or an environment
- variable.
-
-2009-11-01 Joe English <jenglish@users.sourceforge.net>
-
- * doc/Eval.3, doc/Cancel.3: Move TIP#285 routines out of Eval.3 into
- their own manpage.
-
-2009-10-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (ExprRoundFunc): [Bug 2889593]: Correctly report
- the expected number of arguments when generating an error for round().
-
-2009-10-30 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/tcltest.test: When creating the notwritabledir we deny the
- current user access to delete the file. We must grant this right when
- we cleanup. Required on Windows 7 when the user does not automatically
- have administrator rights.
-
-2009-10-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Changed the typedef for the mp_digit type
- from:
- typedef unsigned long mp_digit;
- to:
- typedef unsigned int mp_digit;
- For 32-bit builds where "long" and "int" are two names for the same
- thing, this is no change at all. For 64-bit builds, though, this
- causes the dp[] array of an mp_int to be made up of 32-bit elements
- instead of 64-bit elements. This is a huge improvement because
- details elsewhere in the mp_int implementation cause only 28 bits of
- each element to be actually used storing number data. Without this
- change bignums are over 50% wasted space on 64-bit systems. [Bug
- 2800740].
-
- ***POTENTIAL INCOMPATIBILITY***
- For 64-bit builds, callers of routines with (mp_digit) or (mp_digit *)
- arguments *will*, and callers of routines with (mp_int *) arguments
- *may* suffer both binary and stubs incompatibilities with Tcl releases
- 8.5.0 - 8.5.7. Such possibilities should be checked, and if such
- incompatibilities are present, suitable [package require] requirements
- on the Tcl release should be put in place to keep such built code
- [load]-ing only in Tcl interps that are compatible.
-
-2009-10-29 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/dict.test: Make variable-clean and simplify tests by utilizing
- the fact that dictionaries have defined orders.
-
- * generic/tclZlib.c (TclZlibCmd): Remove accidental C99-ism which
- reportedly makes the AIX native compiler choke.
-
-2009-10-29 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (LocalizeFormat):
- * tests/clock.test (clock-67.1):
- [Bug 2819334]: Corrected a problem where '%%' followed by a letter in
- a format group could expand recursively: %%R would turn into %%H:%M:%S
-
-2009-10-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclLiteral.c: [Bug 2888044]: Fixed 2 bugs.
- * tests/info.test: First, as noted in the comments of the
- TclCleanupLiteralTable routine, since the teardown of the intrep of
- one Tcl_Obj can cause the teardown of others in the same table, the
- full table cleanup must be done with care, but the code did not
- contain the same care demanded in the comment. Second, recent
- additions to the info.test file had poor hygiene, leaving an array
- variable ::a lying around, which breaks later interp.test tests during
- a -singleproc 1 run of the test suite.
-
-2009-10-28 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/fileName.test (fileName-20.[78]): Corrected poor test
- hygiene (failure to save and restore the working directory) that
- caused these two tests to fail on Windows (and [Bug 2806250] to be
- reopened).
-
-2009-10-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 2884203]: Missing refcount on cached
- normalized path caused crashes.
-
-2009-10-27 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (ParseClockScanFormat): [Bug 2886852]: Corrected a
- problem where [clock scan] didn't load the timezone soon enough when
- processing a time format that lacked a complete date.
- * tests/clock.test (clock-66.1):
- Added a test case for the above bug.
- * library/tzdata/America/Argentina/Buenos_Aires:
- * library/tzdata/America/Argentina/Cordoba:
- * library/tzdata/America/Argentina/San_Luis:
- * library/tzdata/America/Argentina/Tucuman:
- New DST rules for Argentina. (Olson's tzdata2009p.)
-
-2009-10-26 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Remove $(PACKAGE).* and prototype from the
- `make distclean` target. Completes 2009-10-20 commit.
-
-2009-10-24 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (ProcessPosixTimeZone):
- Corrected a regression in the fix to [Bug 2207436] that caused
- [clock] to apply EU daylight saving time rules in the US.
- Thanks to Karl Lehenbauer for reporting this regression.
- * tests/clock.test (clock-52.4):
- Added a regression test for the above bug.
- * library/tzdata/Asia/Dhaka:
- * library/tzdata/Asia/Karachi:
- New DST rules for Bangladesh and Pakistan. (Olson's tzdata2009o.)
-
-2009-10-23 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (FlushChannel): Skip OutputProc for low-level
- 0-length writes. When closing pipes which have already been closed
- not skipping leads to spurious SIG_PIPE signals. Reported by
- Mikhail Teterin <mi+thun@aldan.algebra.com>.
-
-2009-10-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 2883857]: Allow
- the passing of array element names through this method.
-
-2009-10-21 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclPosixStr.c: [Bug 2882561]: Work around oddity on Haiku OS
- where SIGSEGV and SIGBUS are the same value.
-
- * generic/tclTrace.c (StringTraceProc): [Bug 2881259]: Added back cast
- to work around silly bug in MSVC's handling of auto-casting.
-
-2009-10-20 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Removed the long outdated and broken targets
- package-* that were for building Solaris packages. Appears that the
- pieces needed for these targets to function have never been present in
- the current era of Tcl development and belong completely to Tcl
- prehistory.
-
-2009-10-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIO.c: [Patch 2107634]: Revised ReadChars and
- FilterInputBytes routines to permit reads to continue up to the string
- limits of Tcl values. Before revisions, large read attempts could
- panic when as little as half the limiting value length was reached.
- Thanks to Sean Morrison and Bob Parker for their roles in the fix.
-
-2009-10-18 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclObj.c (TclDbDumpActiveObjects, TclDbInitNewObj)
- (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount, Tcl_DbIsShared):
- [Bug 2871908]: Enforce separation of concerns between the lineCLPtr
- and objThreadMap thread specific data members.
-
-2009-10-18 Joe Mistachkin <joe@mistachkin.com>
-
- * tests/thread.test (thread-4.[345]): [Bug 1565466]: Correct tests to
- save their error state before the final call to threadReap just in
- case it triggers an "invalid thread id" error. This error can occur
- if one or more of the target threads has exited prior to the attempt
- to send it an asynchronous exit command.
-
-2009-10-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c (UnsetVarStruct, TclDeleteNamespaceVars)
- (TclDeleteCompiledLocalVars, DeleteArray):
- * generic/tclTrace.c (Tcl_UntraceVar2): [Bug 2629338]: Stop traces
- that are deleted part way through (a feature used by tdom) from
- causing freed memory to be accessed.
-
-2009-10-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictIncrCmd): [Bug 2874678]: Don't leak any
- bignums when doing [dict incr] with a value.
- * tests/dict.test (dict-19.3): Memory leak detection code.
-
-2009-10-07 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclObj.c: [Bug 2871908]: Plug memory leaks of objThreadMap
- and lineCLPtr hashtables. Also make the names of the continuation
- line information initialization and finalization functions more
- consistent. Patch supplied by Joe Mistachkin <joe@mistachkin.com>.
-
- * generic/tclIORChan.c (ErrnoReturn): Replace hardwired constant 11
- with proper errno #define, EAGAIN. What was I thinking? The BSD's have
- a different errno assignment and break with the hardwired number.
- Reported by emiliano on the chat.
-
-2009-10-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c (SlaveEval): Agressive stomping of internal reps
- was added as part of the NRE patch of 2008-07-13. This doesn't appear
- to actually be needed, and it hurts quite a bit when large lists lose
- their intreps and require reparsing. Thanks to Ashok Nadkarni for
- reporting the problem.
-
- * generic/tclTomMathInt.h (new): Public header tclTomMath.h had
- * generic/tclTomMath.h: dependence on private headers, breaking use
- * generic/tommath.h: by extensions [Bug 1941434].
-
-2009-10-05 Andreas Kupries <andreask@activestate.com>
-
- * library/safe.tcl (AliasGlob): Fixed conversion of catch to
- try/finally, it had an 'on ok msg' branch missing, causing a silent
- error immediately, and bogus glob results, breaking search for Tcl
- modules.
-
-2009-10-04 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXBundle.c: [Bug 2569449]: Workaround CF memory
- * unix/tclUnixInit.c: managment bug in Mac OS X 10.4 &
- earlier.
-
-2009-10-02 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Cairo:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Karachi:
- * library/tzdata/Pacific/Apia: Olson's tzdata2009n.
-
-2009-09-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclDictObj.c: [Bug 2857044]: Updated freeIntRepProc
- * generic/tclExecute.c: routines so that they set the typePtr
- * generic/tclIO.c: field to NULL so that the Tcl_Obj is
- * generic/tclIndexObj.c: not left in an inconsistent state.
- * generic/tclInt.h:
- * generic/tclListObj.c:
- * generic/tclNamesp.c:
- * generic/tclOOCall.c:
- * generic/tclObj.c:
- * generic/tclPathObj.c:
- * generic/tclProc.c:
- * generic/tclRegexp.c:
- * generic/tclStringObj.c:
-
- * generic/tclAlloc.c: Cleaned up various routines in the
- * generic/tclCkalloc.c: call stacks for memory allocation to
- * generic/tclInt.h: guarantee that any size values computed
- * generic/tclThreadAlloc.c: are within the domains of the routines
- they get passed to. [Bugs 2557696 and 2557796].
-
-2009-09-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: Replaced TclProcessReturn() calls with
- * tests/error.test: Tcl_SetReturnOptions() calls as a simple fix
- for [Bug 2855247]. Thanks to Anton Kovalenko for the report and fix.
- Additional fixes for other failures demonstrated by new tests.
-
-2009-09-27 Don Porter <dgp@users.sourceforge.net>
-
- * tests/error.test (error-15.8.*): Coverage tests illustrating
- flaws in the propagation of return options by [try].
-
-2009-09-26 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclooConfig.sh, win/tclooConfig.sh: [Bug 2026844]: Added dummy
- versions of tclooConfig.sh that make it easier to build extensions
- against both Tcl8.5+TclOO-standalone and Tcl8.6.
-
-2009-09-24 Don Porter <dgp@users.sourceforge.net>
-
- TIP #356 IMPLEMENTATION
-
- * generic/tcl.decls: Promote internal routine TclNRSubstObj()
- * generic/tclCmdMZ.c: to public Tcl_NRSubstObj(). Still needs docs.
- * generic/tclCompile.c:
- * generic/tclInt.h:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2009-09-23 Miguel Sofer <msofer@users.sf.net>
-
- * doc/namespace.n: the description of [namespace unknown] failed
- to mention [namespace path]: fixed. Thx emiliano.
-
-2009-09-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/regexp.test: Added check for error message from
- unbalanced [] in regexp. Added additional simple test cases
- of basic regsub command.
-
-2009-09-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Correct botch in the conversion of
- Tcl_SubstObj(). Thanks to Kevin Kenny for detection and report.
-
-2009-09-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Re-implement Tcl_SubstObj() as a simple
- * generic/tclParse.c: wrapper around TclNRSubstObj(). This has
- * tests/basic.test: the effect of caching compiled bytecode in
- * tests/parse.test: the value to be substituted. Note that
- Tcl_SubstObj() now exists only for extensions. Tcl itself no longer
- makes any use of it. Note also that TclSubstTokens() is now reachable
- only by Tcl_EvalEx() and Tcl_ParseVar() so tests aiming to test its
- functioning needed adjustment to still have the intended effect.
-
-2009-09-16 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclObj.c: Extended ::tcl::unsupported::representation.
-
-2009-09-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Completed the NR-enabling of [subst].
- * generic/tclCmdMZ.c: [Bug 2314561].
- * generic/tclCompCmds.c:
- * generic/tclCompile.c:
- * generic/tclInt.h:
- * tests/coroutine.test:
- * tests/parse.test:
-
-2009-09-11 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/http.test: Added in cleaning up of http tokens for each test
- to reduce amount of global-variable pollution.
-
-2009-09-10 Donal K. Fellows <dkf@users.sf.net>
-
- * library/http/http.tcl (http::Event): [Bug 2849860]: Handle charset
- names in double quotes; some servers like generating them like that.
-
-2009-09-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c: [Bug 2850901]: Corrected line counting error
- * tests/into.test: in multi-command script substitutions.
-
-2009-09-07 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclExecute.c: Fix potential uninitialized variable use and
- * generic/tclFCmd.c: null dereference flagged by clang static
- * generic/tclProc.c: analyzer.
- * generic/tclTimer.c:
- * generic/tclUtf.c:
-
- * generic/tclExecute.c: Silence false positives from clang static
- * generic/tclIO.c: analyzer about potential null dereference.
- * generic/tclScan.c:
- * generic/tclCompExpr.c:
-
-2009-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileSubstCmd): [Bug 2314561]:
- * generic/tclBasic.c: Added a bytecode compiler routine for the
- * generic/tclCmdMZ.c: [subst] command. This is a partial solution to
- * generic/tclCompile.c: the need to NR-enable [subst] since bytecode
- * generic/tclCompile.h: execution is already NR-enabled. Two new
- * generic/tclExecute.c: bytecode instructions, INST_NOP and
- * generic/tclInt.h: INST_RETURN_CODE_BRANCH were added to support
- * generic/tclParse.c: the new routine. INST_RETURN_CODE_BRANCH is
- * tests/basic.test: likely to be useful in any future effort to
- * tests/info.test: add a bytecode compiler routine for [try].
- * tests/parse.test:
-
-2009-09-03 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/LinkVar.3: [Bug 2844962]: Added documentation of issues relating
- to use of this API in a multi-threaded environment.
-
-2009-09-01 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORTrans.c (ReflectInput): Remove error response to
- 0-result from method 'limit?' of transformations. Return the number of
- copied bytes instead, which is possibly nothing. The latter then
- triggers EOF handling in the higher layers, making the 0-result of
- limit? the way to inject artificial EOF's into the data stream.
-
-2009-09-01 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Bump to tcltest 2.3.2 after revision
- * library/tcltest/pkgIndex.tcl: to verbose error message.
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2009-08-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [Bug 2845535]: A few more string
- overflow cases in [format].
-
-2009-08-25 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard)
- (Tcl_EvalEx, TclEvalEx, TclAdvanceContinuations, TclNREvalObjEx):
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines):
- * generic/tclCompCmds.c (*):
- * generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv)
- (TclFreeCompileEnv, TclCompileScript, TclCompileTokens):
- * generic/tclCompile.h (CompileEnv):
- * generic/tclInt.h (ContLineLoc, Interp):
- * generic/tclObj.c (ThreadSpecificData, ContLineLocFree)
- (TclThreadFinalizeObjects, TclInitObjSubsystem, TclContinuationsEnter,
- (TclContinuationsEnterDerived, TclContinuationsCopy, TclFreeObj)
- (TclContinuationsGet):
- * generic/tclParse.c (TclSubstTokens, Tcl_SubstObj):
- * generic/tclProc.c (TclCreateProc):
- * generic/tclVar.c (TclPtrSetVar):
- * tests/info.test (info-30.0-24):
-
- Extended the parser, compiler, and execution engine with code and
- attendant data structures tracking the position of continuation lines
- which are not visible in the resulting script Tcl_Obj*'s, to properly
- account for them while counting lines for #280.
-
-2009-08-24 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: Annotate Tcl_Panic as noreturn for clang static
- analyzer in PURIFY builds, replacing preprocessor/assert technique.
-
- * macosx/tclMacOSXNotify.c: Fix multiple issues with nested event loops
- when CoreFoundation notifier is running in embedded mode. (Fixes
- problems in TkAqua Cocoa reported by Youness Alaoui on tcl-mac)
-
-2009-08-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c: Correct regression in [Bug 2837800] fix.
- * tests/fileName.test:
-
-2009-08-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c: [Bug 2837800]: Correct the result produced by
- [glob */test] when * matches something like ~foo.
-
- * generic/tclPathObj.c: [Bug 2806250]: Prevent the storage of strings
- starting with ~ in the "tail" part (normPathPtr field) of the path
- intrep when PATHFLAGS != 0. This establishes the assumptions relied
- on elsewhere that the name stored there is a relative path. Also
- refactored to make an AppendPath() routine instead of the cut/paste
- stanzas that were littered throughout.
-
-2009-08-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (TclNRIfObjCmd): [Bug 2823276]: Make [if]
- NRE-safe on all arguments when interpreted.
- (Tcl_LsortObjCmd): Close off memory leak.
-
-2009-08-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (TclNRForObjCmd, etc.): [Bug 2823276]: Make [for]
- and [while] into NRE-safe commands, even when interpreted.
-
-2009-08-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 2837800]: Added NULL check to prevent
- * tests/fileName.test: crashes during [glob].
-
-2009-08-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/dltest/pkge.c: const addition
- * unix/tclUnixThrd.c: Use <pthread.h> in stead of "pthread.h"
- * win/tclWinDde.c: Eliminate some more gcc warnings
- * win/tclWinReg.c:
- * generic/tclInt.h: Change ForIterData, make it const-safe.
- * generic/tclCmdAH.c:
-
-2009-08-12 Don Porter <dgp@users.sourceforge.net>
-
- TIP #353 IMPLEMENTATION
-
- * doc/NRE.3: New public routine Tcl_NRExprObj() permits
- * generic/tcl.decls: extension commands to evaluate Tcl expressions
- * generic/tclBasic.c: in NR-enabled command procedures.
- * generic/tclCmdAH.c:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * tests/expr.test:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2009-08-06 Andreas Kupries <andreask@activestate.com>
-
- * doc/refchan.n [Bug 2827000]: Extended the implementation of
- * generic/tclIORChan.c: reflective channels (TIP 219, method
- * tests/ioCmd.test: 'read'), enabling handlers to signal EAGAIN to
- indicate 'no data, but not at EOF either', and other system
- errors. Updated documentation, extended testsuite (New test cases
- iocmd*-23.{9,10}).
-
-2009-08-02 Miguel Sofer <msofer@users.sf.net>
-
- * tests/coroutine.test: fix testfile cleanup
-
-2009-08-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclObj.c (Tcl_RepresentationCmd): Added an unsupported
- command for reporting the representation of an object. Result string
- is deliberately a bit obstructive so that people are not encouraged to
- make code that depends on it; it's a debugging tool only!
-
- * unix/tclUnixFCmd.c (GetOwnerAttribute, SetOwnerAttribute)
- (GetGroupAttribute, SetGroupAttribute): [Bug 1942222]: Stop calling
- * unix/tclUnixFile.c (TclpGetUserHome): endpwent() and endgrent();
- they've been unnecessary for ages.
-
-2009-08-02 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tclWin32Dll.c: Eliminate TclWinResetInterfaceEncodings, since it
- * win/tclWinInit.c: does exactly the same as TclWinEncodingsCleanup,
- * win/tclWinInt.h: make sure that tclWinProcs and
- tclWinTCharEncoding are always set and reset
- concurrently.
- * win/tclWinFCmd.c: Correct check for win95
-
-2009-07-31 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [Bug 2830354]: Corrected failure to
- * tests/format.test: grow buffer when format spec request
- large width floating point values. Thanks to Clemens Misch.
-
-2009-07-26 Donal K. Fellows <dkf@users.sf.net>
-
- * library/auto.tcl (tcl_findLibrary, auto_mkindex):
- * library/package.tcl (pkg_mkIndex, tclPkgUnknown, MacOSXPkgUnknown):
- * library/safe.tcl (interpAddToAccessPath, interpDelete, AliasGlob):
- (AliasSource, AliasLoad, AliasEncoding):
- * library/tm.tcl (UnknownHandler): Simplify by swapping some [catch]
- gymnastics for use of [try].
-
-2009-07-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tools/genStubs.tcl: Forced LF translation when generating .h's to
- avoid spurious diffs when regenerating on a Windows box.
-
-2009-07-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: [Bug 2827066]: msys build --enable-symbols broken
- * win/tcl.m4: And modified the same for unicows.dll, as a
- * win/configure: preparation for [Enh 2819611].
-
-2009-07-25 Donal K. Fellows <dkf@users.sf.net>
-
- * library/history.tcl (history): Reworked the history mechanism in
- terms of ensembles, rather than the ad hoc ensemble-lite mechanism
- used previously.
-
-2009-07-24 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/self.n (self class): [Bug 2704302]: Add some text to make it
- clearer how to get the name of the current object's class.
-
-2009-07-23 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (Tcl_GetChannelHandle): [Bug 2826248]: Do not crash
- * generic/tclPipe.c (FileForRedirect): for getHandleProc == NULL, this
- is allowed. Provide a nice error message in the bypass area. Updated
- caller to check the bypass for a mesage. Bug reported by Andy
- Sonnenburg <andy22286@users.sourceforge.net>
-
-2009-07-23 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclNotify.c: [Bug 2820349]: Ensure that queued events are
- freed once processed.
-
-2009-07-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * macosx/tclMacOSXFCmd.c: CONST -> const
- * generic/tclGetDate.y:
- * generic/tclDate.c:
- * generic/tclLiteral.c: (char *) cast in ckfree call
- * generic/tclPanic.c: [Feature Request 2814786]: remove TclpPanic
- * generic/tclInt.h
- * unix/tclUnixPort.h
- * win/tclWinPort.h
-
-2009-07-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclEvent.c: [Bug 2001201 again]: Refined the 20090617 patch
- on [exit] streamlining, so that it now correctly calls thread exit
- handlers for the calling thread, including <Destroy> bindings in Tk.
-
-2009-07-21 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Asia/Dhaka:
- * library/tzdata/Indian/Mauritius: Olson's tzdata2009k.
-
-2009-07-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (StringIsCmd): Reorganize so that [string is] is
- more efficient when parsing things that are correct, at a cost of
- making the empty string test slightly more costly. With this, the cost
- of doing [string is integer -strict $x] matches [catch {expr {$x+0}}]
- in the successful case, and greatly outstrips it in the failing case.
-
-2009-07-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.decls, generic/tclOO.c (Tcl_GetObjectName): Expose a
- function for efficiently returning the current name of an object.
-
-2009-07-18 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: Define NDEBUG in optimized (non-symbols) build to
- disable NRE assert()s and threaded allocator range checks.
-
-2009-07-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBinary.c: Removed unused variables.
- * generic/tclCmdIL.c:
- * generic/tclCompile.c:
- * generic/tclExecute.c:
- * generic/tclHash.c:
- * generic/tclIOUtil.c:
- * generic/tclVar.c:
-
- * generic/tclBasic.c: Silence compiler warnings about ClientData.
- * generic/tclProc.c:
-
- * generic/tclScan.c: Typo in ACCEPT_NAN configuration.
-
- * generic/tclStrToD.c: [Bug 2819200]: Set floating point control
- register on MIPS systems so that the gradual underflow expected by Tcl
- is in effect.
-
-2009-07-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h (Namespace): Added machinery to allow
- * generic/tclNamesp.c (many functions): reduction of memory used
- * generic/tclResolve.c (BumpCmdRefEpochs): by namespaces. Currently
- #ifdef'ed out because of compatibility concerns.
-
- * generic/tclInt.decls: Added four functions for better integration
- with itcl-ng.
-
-2009-07-14 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclInt.h (TclNRSwitchObjCmd):
- * generic/tclBasic.c (builtInCmds):
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd):
- * tests/switch.test (switch-15.1):
- [Bug 2821401]: Make non-bytecoded [switch] command aware of NRE.
-
-2009-07-13 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex)
- (TclCleanupByteCode, TclCompileScript):
- * generic/tclExecute.c (TclCompileObj, TclExecuteByteCode):
- * tclCompile.h (ExtCmdLoc):
- * tclInt.h (ExtIndex, CFWordBC, CmdFrame):
- * tclBasic.c (DeleteInterpProc, TclArgumentBCEnter)
- (TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT)
- (RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd):
- * generic/tclCmdAH.c (TclNRForObjCmd, TclNRForIterCallback,
- (ForNextCallback):
- * generic/tclCmdMZ.c (TclNRWhileObjCmd):
-
- Extended the bytecode compiler initialization to recognize the
- compilation of whole files (NRE enabled 'source' command) and switch
- to the counting of absolute lines in that case.
-
- Further extended the bytecode compiler to track the start line in the
- generated information, and modified the bytecode execution to
- recompile an object if the location as per the calling context doesn't
- match the location saved in the bytecode. This part could be optimized
- more by using more memory to keep all possibilities which occur
- around, or by just adjusting the location information instead of a
- total recompile.
-
- Reworked the handling of literal command arguments in bytecode to be
- saved (compiler) and used (execution) per command (See the
- TCL_INVOKE_STK* instructions), and not per the whole bytecode. This,
- and the previous change remove the problems with location data caused
- by literal sharing (across whole files, but also proc bodies).
- Simplified the associated datastructures (ExtIndex is gone, as is the
- function EnterCmdWordIndex).
-
- The last change causes the hashtable 'lineLABCPtr' to be state which
- has to be kept per coroutine, like the CmdFrame stack. Reworked the
- coroutine support code to create, delete and switch the information as
- needed. Further reworked the tailcall command as well, it has to pop
- its own arguments when run in a bytecode context to keep a proper
- stack in 'lineLABCPtr'.
-
- Fixed the mishandling of line information in the NRE-enabled 'for' and
- 'while' commands introduced when both were made to share their
- iteration callbacks without taking into account that the loop body is
- found in different words of the command. Introduced a separate data
- structure to hold all the callback information, as we went over the
- limit of 4 direct client-data values for NRE callbacks.
-
- The above fixes [Bug 1605269].
-
-2009-07-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (StringIndexCmd, StringEqualCmd, StringCmpCmd):
- * generic/tclExecute.c (TclExecuteByteCode): [Bug 2637173]: Factor out
- * generic/tclInt.h (TclIsPureByteArray): the code to determine if
- * generic/tclUtil.c (TclStringMatchObj): it is safe to work with
- byte arrays directly, so that we get the check correct _once_.
-
- * generic/tclOOCall.c (TclOOGetCallContext): [Bug 1895546]: Changed
- * generic/tclOO.c (TclOOObjectCmdCore): the way that the cache is
- managed so that when itcl does cunning things, those cunning things
- can be cached properly.
-
-2009-07-11 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/vwait.n: Substantially increased the discussion of issues and
- work-arounds relating to nested vwaits, following discussion on the
- tcl-core mailing list on the topic.
-
-2009-07-10 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/zlib.test: ZlibTransformClose may be called with a NULL
- * generic/tclZlib.c: interpreter during finalization and
- Tcl_SetChannelError requires a list. Added some tests to ensure error
- propagation from the zlib library to the interp.
-
-2009-07-09 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/zlib.test: [Bug 2818131]: Added tests and fixed a typo that
- broke [zlib push] for deflate format.
-
-2009-07-09 Donal K. Fellows <dkf@users.sf.net>
-
- * compat/mkstemp.c (mkstemp): [Bug 2819227]: Use rand() for random
- numbers as it is more portable.
-
-2009-07-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibTransformWatch): Correct the handling of
- events so that channel transforms work with things like an asynch
- [chan copy]. Problem reported by Pat Thoyts.
-
-2009-07-01 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinInt.h: [Bug 2806622]: Handle the GetUserName API call
- * win/tclWin32Dll.c: via the tclWinProcs indirection structure. This
- * win/tclWinInit.c: fixes a problem obtaining the username when the
- USERNAME environment variable is unset.
-
-2009-06-30 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: Add assert macros for clang static
- * generic/tclPanic.c: analyzer and redefine Tcl_Panic to
- * generic/tclStubInit.c: assert after panic in clang PURIFY
- builds.
-
- * generic/tclCmdIL.c: Add clang assert for false positive
- from static analyzer.
-
-2009-06-26 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl-Common.xcconfig: Update projects for Xcode 3.1 and
- * macosx/Tcl.xcode/*: 3.2, standardize on gcc 4.2, remove
- * macosx/Tcl.xcodeproj/*: obsolete configurations and pre-Xcode
- * macosx/Tcl.pbproj/* (removed): project.
-
- * macosx/README: Update project docs, cleanup.
-
- * unix/Makefile.in: Update dist target for project
- changes.
-
-2009-06-24 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/oo.test (oo-19.1): [Bug 2811598]: Make more resilient.
-
-2009-06-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/http11.test: [Bug 2811492]: Clean up procs after testing.
-
-2009-06-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCkalloc.c (MemoryCmd): [Bug 988703]:
- * generic/tclObj.c (ObjData, TclFinalizeThreadObjects): Add mechanism
- for discovering what Tcl_Objs are allocated when built for memory
- debugging. Developed by Joe Mistachkin.
-
-2009-06-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclEvent.c: Applied a patch by George Peter Staplin
- drastically reducing the ambition of [exit] wrt finalization, and
- thus solving many multi-thread teardown issues. [Bugs 2001201,
- 486399, and possibly 597575, 990457, 1437595, 2750491]
-
-2009-06-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: sprintf() -> Tcl_ObjPrintf() conversion.
-
-2009-06-15 Reinhard Max <max@suse.de>
-
- * unix/tclUnixPort.h: Move all socket-related code from tclUnixChan.c
- * unix/tclUnixChan.c: to tclUnixSock.c.
- * unix/tclUnixSock.c:
-
-2009-06-15 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (make-man-pages): [Patch 557486]: Apply
- last remaining meaningful part of this patch, a clean up of some
- closing tags.
-
-2009-06-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: [Bug 2802881]: The value stashed in
- * generic/tclProc.c: iPtr->compiledProcPtr when compiling a proc
- * tests/execute.test: survives too long. We only need it there long
- enough for the right TclInitCompileEnv() call to re-stash it into
- envPtr->procPtr. Once that is done, the CompileEnv controls. If we
- let the value of iPtr->compiledProcPtr linger, though, then any other
- bytecode compile operation that takes place will also have its
- CompileEnv initialized with it, and that's not correct. The value is
- meant to control the compile of the proc body only, not other compile
- tasks that happen along. Thanks to Carlos Tasada for discovering and
- reporting the problem.
-
-2009-06-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [Bug 2801413]: Revised [format] to not
- overflow the integer calculations computing the length of the %ll
- formats of really big integers. Also added protections so that
- [format]s that would produce results overflowing the maximum string
- length of Tcl values throw a normal Tcl error instead of a panic.
-
- * generic/tclStringObj.c: [Bug 2803109]: Corrected failures to
- deal with the "pure unicode" representation of an empty string.
- Thanks to Julian Noble for reporting the problem.
-
-2006-06-09 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclGetDate.y: Fixed a thread safety bug in the generated
- * library/clock.tcl: Bison parser (needed a %pure-parser
- * tests/clock.test: declaration to avoid static variables).
- Discovered that the %pure-parser declaration
- allowed for returning the Bison error message
- to the Tcl caller in the event of a syntax
- error, so did so.
- * generic/tclDate.c: bison 2.3
-
-2006-06-08 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Asia/Dhaka: New DST rule for Bangladesh. (Olson's
- tzdata2009i.)
-
-2009-06-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/copy.n: Fix error in example spotted by Venkat Iyer.
-
-2009-06-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Replace dynamically-initialized table with a
- table of static constants in the lookup table for exponent operator
- computations that fit in a 64 bit integer result.
-
- * generic/tclExecute.c: [Bug 2798543]: Corrected implementations and
- selection logic of the INST_EXPON instruction.
-
-2009-06-01 Don Porter <dgp@users.sourceforge.net>
-
- * tests/expr.test: [Bug 2798543]: Added many tests demonstrating
- the broken cases.
-
-009-05-30 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Cairo:
- * library/tzdata/Asia/Amman: Olson's tzdata2009h.
-
-2009-05-29 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Fixed handling of cpu ia64,
- * library/platform/pkgIndex.tcl: taking ia64_32 into account
- * unix/Makefile.in: now. Bumped version to 1.0.5. Updated the
- * win/Makefile.in: installation commands.
-
-2009-05-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/expr.n: Fixed documentation of the right-associativity of
- the ** operator. (spotted by kbk)
-
-2009-05-14 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOInfo.c (InfoObjectNsCmd): Added introspection mechanism
- for finding out what an object's namespace is. Experience suggests
- that it is just too useful to be able to do without it.
-
-2009-05-12 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/vwait.n: Added more words to make it clear just how bad it is to
- nest [vwait]s.
-
- * compat/mkstemp.c: Add more headers to make this file build on IRIX
- 6.5. Thanks to Larry McVoy for this.
-
-2009-05-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (TclNRNewObjectInstance): [Bug 2414858]: Add a
- * generic/tclBasic.c (TclPushTailcallPoint): marker to the stack of
- NRE callbacks at the right point so that tailcall works correctly in a
- constructor.
-
- * tests/exec.test (cat): [Bug 2788468]: Adjust the scripted version of
- cat so that it does not perform transformations on the data it is
- working with, making it more like the standard Unix 'cat' program.
-
-2009-05-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclObj.c (Tcl_GetCommandFromObj): [Bug 2785893]: Ensure that
- a command in a deleted namespace can't be found through a cached name.
-
- * generic/tclBasic.c: Let coroutines start with a much smaller
- * generic/tclCompile.h: stack: 200 words (previously was 2000, the
- * generic/tclExecute.c: same as interps).
-
-2009-05-07 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/env.test (printenvScript, env-4.3, env-4.5): [Bug 1513659]:
- * tests/exec.test (exec-2.6): These tests had subtle dependencies on
- being on platforms that were either ISO 8859-1 or UTF-8. Stabilized
- the results by forcing the encoding.
-
-2009-05-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: [Bug 2582327]: Improve overflow error message
- from [string repeat].
-
- * tests/interp.test: interp-20.50 test for Bug 2486550.
-
-2009-05-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (InitFoundation, AllocObject, AllocClass):
- * generic/tclOODefineCmds.c (InitDefineContext): Make sure that when
- support namespaces are deleted, nothing bad can subsequently happen.
- Issue spotted by Don Porter.
-
-2009-05-03 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/Tcl.n: [Bug 2538432]: Clarified exact treatment of ${arr(idx)}
- form of variable substitution. This is not a change of behavior, just
- an improved description of the current situation.
-
-2009-04-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclObjInvoke): [Bug 2486550]: Make sure that a
- null objProc is not used, use Tcl_NRCallObjProc instead.
-
-2009-05-01 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/configure.in Fix 64-bit detection for zlib on Win64
- * win/configure (regenerated)
-
-2009-04-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tcl.m4, unix/configure (SC_CONFIG_CFLAGS): harden the check to
- add _r to CC on AIX with threads.
-
-2009-04-27 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/concat.n (EXAMPLES): [Bug 2780680]: Rewrote so that the spacing
- of result messages is correct. (The exact way they were wrong was
- different when rendered through groff or as HTML, but it was still
- wrong both ways.)
-
-2009-04-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIndexObj.c: Reset internal INTERP_ALTERNATE_WRONG_ARGS
- * generic/tclIOCmd.c: flag inside the Tcl_WrongNumArgs function,
- so the caller no longer has to do the reset.
-
-2009-04-24 Stuart Cassoff <stwo@users.sf.net>
-
- * unix/Makefile.in: [Patch 2769530]: Don't chmod/exec installManPage.
-
-2009-04-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: [Bug 2715421]: Removed spurious newline added
- * tests/http11.test: after POST and added tests to detect excess
- * tests/httpd11.tcl: bytes being POSTed.
- * library/http/pkgIndex.tcl:
- * makefiles: package version now 2.8.1
-
-2009-04-15 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n, doc/close.n: Tidy up documentation of TIP #332.
-
-2009-04-14 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/Asia/Karachi: Updated rules for Pakistan Summer
- Time (Olson's tzdata2009f)
-
-2009-04-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (InvokeForwardMethod): Clarify the resolution
- behaviour of the name of the command that is forwarded to: it's now
- resolved using the object's namespace as context, which is much more
- useful than the previous (somewhat random) behaviour of using the
- caller's current namespace.
-
-2009-04-10 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: Improved HTTP/1.1 support and added
- * library/http/pkgIndex.tcl: specific HTTP/1.1 testing to ensure
- * tests/http11.test: we handle chunked+gzip for the various
- * tests/httpd11.test: modes (normal, -channel and -handler)
- * makefiles: package version set to 2.8.0
-
-2009-04-10 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixChan.c: TclUnixWaitForFile(): use FD_* macros
- * macosx/tclMacOSXNotify.c: to manipulate select masks (Cassoff).
- [FRQ 1960647] [Bug 3486554]
-
- * unix/tclLoadDyld.c: Use RTLD_GLOBAL instead of RTLD_LOCAL.
- [Bug 1961211]
-
- * macosx/tclMacOSXNotify.c: revise CoreFoundation notifier to allow
- embedding into applications that
- already have a CFRunLoop running and
- want to run the tcl event loop via
- Tcl_ServiceModeHook(TCL_SERVICE_ALL).
-
- * macosx/tclMacOSXNotify.c: add CFRunLoop based Tcl_Sleep() and
- * unix/tclUnixChan.c: TclUnixWaitForFile() implementations
- * unix/tclUnixEvent.c: and disable select() based ones in
- CoreFoundation builds.
-
- * unix/tclUnixNotify.c: simplify, sync with tclMacOSXNotify.c.
-
- * generic/tclInt.decls: add TclMacOSXNotifierAddRunLoopMode()
- * generic/tclIntPlatDecls.h: internal API, regen.
- * generic/tclStubInit.c:
-
- * unix/configure.in (Darwin): use Darwin SUSv3 extensions if
- available; remove /Network locations
- from default tcl package search path
- (NFS mounted locations and thus slow).
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * macosx/tclMacOSXBundle.c: on Mac OS X 10.4 and later, replace
- deprecated NSModule API by dlfcn API.
-
-2009-04-10 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/StringObj.3: [Bug 2089279]: Corrected example so that it works
- on 64-bit machines as well.
-
-2009-04-10 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/http.test: [Bug 26245326]: Added specific check for problem
- * tests/httpd: (return incomplete HTTP response header).
-
-2009-04-08 Kevin B. Kenny <kennykb@acm.org>
-
- * tools/tclZIC.tcl: Always emit files with Unix line termination.
- * library/tzdata: Olson's tzdata2009e
-
-2009-04-09 Don Porter <dgp@users.sourceforge.net>
-
- * library/http/http.tcl: [Bug 26245326]: Handle incomplete
- lines in the "connecting" state. Thanks to Sergei Golovan.
-
-2009-04-08 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Extended the darwin sections to add
- * library/platform/pkgIndex.tcl: a kernel version number to the
- * unix/Makefile.in: identifier for anything from Leopard (10.5) on up.
- * win/Makefile.in: Extended patterns for same. Extended cpu
- * doc/platform.n: recognition for 64bit Tcl running on a 32bit kernel
- on a 64bit processor (By Daniel Steffen). Bumped version to 1.0.4.
- Updated Makefiles.
-
-2009-04-08 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: [Bug 2570363]: Converted [eval]s (some
- * library/tcltest/pkgIndex.tcl: unsafe!) to {*} in tcltest package.
- * unix/Makefile.in: => tcltest 2.3.1
- * win/Makefile.in:
-
-2009-04-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Correction so that value of
- TCL_GROWTH_MIN_ALLOC is everywhere expressed in bytes as comment
- claims.
-
-2009-04-04 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/vwait.n: [Bug 1910136]: Extend description and examples to make
- it clearer just how this command interprets variable names.
-
-2009-03-30 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Alloc.3: [Bug 2556263]: Size argument is "unsigned int".
-
-2009-03-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c (TclPathPart): [Bug 2710920]: TclPathPart()
- * tests/fileName.test: was computing the wrong results for both [file
- dirname] and [file tail] on "path" arguments with the PATHFLAGS != 0
- intrep and with an empty string for the "joined-on" part.
-
-2009-03-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/tclsh.1: Bring doc and tools in line with
- * tools/installData.tcl: https://wiki.tcl-lang.org/page/exec+magic
- * tools/str2c
- * tools/tcltk-man2html.tcl
-
-2009-03-25 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/coroutine.n: [Bug 2152285]: Added basic documentation for the
- coroutine and yield commands.
-
-2009-03-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOOSelfObjCmd): [Bug 2704302]: Make 'self
- class' better defined in the context of objects that change class.
-
- * generic/tclVar.c (Tcl_UpvarObjCmd): [Bug 2673163] (ferrieux)
- * generic/tclProc.c (TclObjGetFrame): Make the upvar command more able
- to handle its officially documented syntax.
-
-2009-03-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: [Bug 2502037]: NR-enable the handling of unknown
- commands.
-
-2009-03-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Fixed "leaks" in aliases, imports and
- * generic/tclInt.h: ensembles. Only remaining known leak is in
- * generic/tclInterp.c: ensemble unknown dispatch (as it not
- * generic/tclNamesp.c: NR-enabled)
- * tests/tailcall.test:
-
- * tclInt.h: comments
-
- * tests/tailcall.test: Added tests to show that [tailcall] does not
- currently always execute in constant space: interp-alias, ns-imports
- and ensembles "leak" as of this commit.
-
- * tests/nre.test: [foreach] has been NR-enabled for a while, the test
- was marked 'knownBug': unmark it.
-
- * generic/tclBasic.c: Fix for (among others) [Bug 2699087]
- * generic/tclCmdAH.c: Tailcalls now perform properly even from
- * generic/tclExecute.c: within [eval]ed scripts.
- * generic/tclInt.h: More tests missing, as well as proper
- exploration and testing of the interaction with "redirectors" like
- interp-alias (suspect that it does not happen in constant space)
- and pure-eval commands.
-
- * generic/tclExecute.c: Proper fix for [Bug 2415422]. Reenabled
- * tests/nre.test: the failing assertion that was disabled on
- 2008-12-18: the assertion is correct, the fault was in the
- management of expansions.
-
- * generic/tclExecute.c: Fix both test and code for tailcall
- * tests/tailcall.test: from within a compiled [eval] body.
-
- * tests/tailcall.test: Slightly improved tests
-
-2009-03-20 Don Porter <dgp@users.sourceforge.net>
-
- * tests/stringObj.test: [Bug 2597185]: Test stringObj-6.9
- checks that Tcl_AppendStringsToObj() no longer crashes when operating
- on a pure unicode value.
-
- * generic/tclExecute.c (INST_CONCAT1): [Bug 2669109]: Panic when
- appends overflow the max length of a Tcl value.
-
-2009-03-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tcl.h:
- * generic/tclInt.h:
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall
- implementation, ::unsupported::atProcExit is (temporarily?) gone. The
- new approach is much simpler, and also closer to being correct. This
- commit fixes [Bug 2649975] and [Bug 2695587].
-
- * tests/coroutine.test: Moved the tests to their own files,
- * tests/tailcall.test: removed the unsupported.test. Added
- * tests/unsupported.test: tests for the fixed bugs.
-
-2009-03-19 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/tailcall.n: Added documentation for tailcall command.
-
-2009-03-18 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinFile.c (TclpObjNormalizePath): [Bug 2688184]:
- Corrected Tcl_Obj leak. Thanks to Joe Mistachkin for detection and
- patch.
-
- * generic/tclVar.c (TclLookupSimpleVar): [Bug 2689307]: Shift
- all calls to Tcl_SetErrorCode() out of TclLookupSimpleVar and onto its
- callers, where control with TCL_LEAVE_ERR_MSG flag is more easily
- handled.
-
-2009-03-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (TryPostBody): [Bug 2688063]: Extract information
- from list before getting rid of last reference to it.
-
-2009-03-15 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclThread.c: [Bug 2687952]: Modify fix for TSD leak to match
- * generic/tclThreadStorage.c: Tcl 8.5 (and prior) allocation semantics
-
-2009-03-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclThreadStorage.c (TSDTableDelete): [Bug 2687952]: Ensure
- * generic/tclThread.c (Tcl_GetThreadData): that structures in
- Tcl's TSD system are all freed. Use the correct matching allocator.
-
- * generic/tclPosixStr.c (Tcl_SignalId,Tcl_SignalMsg): [Patch 1513655]:
- Added support for SIGINFO, which is present on BSD platforms.
-
-2009-03-14 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tcl.pc.in (new file): [Patch 2243948] (hat0)
- * unix/configure.in, unix/Makefile.in: Added support for reporting
- Tcl's public build configuration via the pkg-config system. TEA is
- still the official mechanism though, in part because pkg-config is not
- universally supported across all Tcl's supported platforms.
-
-2009-03-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclNRCoroutineObjCmd): fix Tcl_Obj leak.
- Diagnosis and fix thanks to GPS.
-
-2009-03-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (Tcl_TryObjCmd, TclNRTryObjCmd): Moved the
- implementation of [try] from Tcl code into C. Still lacks a bytecode
- version, but should be better than what was before.
-
-2009-03-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (TclZlibCmd): Checksums are defined to be unsigned
- 32-bit integers, use Tcl_WideInt to pass to scripts. [Bug 2662434]
- (ZlibStreamCmd, ChanGetOption): A few other related corrections.
-
-2009-02-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls: [Bug 218977]: Tcl_DbCkfree needs return value
- * generic/tclCkalloc.c
- * generic/tclDecls.h: (regenerated)
- * generic/tclInt.decls: don't use CONST84/CONST86 here
- * generic/tclCompile.h: don't use CONST86 here, comment fixing.
- * generic/tclIO.h: don't use CONST86 here, comment fixing.
- * generic/tclIntDecls.h (regenerated)
-
-2009-02-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c (TclStringMatchObj): [Bug 2637173]: Revised
- the branching on the strObj->typePtr so that untyped values get
- converted to the "string" type and pass through the Unicode matcher.
- [Bug 2613766]: Also added checks to only perform "bytearray"
- optimization on pure bytearray values.
-
- * generic/tclCmdMZ.c: Since Tcl_GetCharLength() has its own
- * generic/tclExecute.c: optimizations for the tclByteArrayType, stop
- having the callers do them.
-
-2009-02-24 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/clock.n, doc/fblocked.n, doc/format.n, doc/lsort.n,
- * doc/pkgMkIndex.n, doc/regsub.n, doc/scan.n, doc/tclvars.n:
- General minor documentation improvements.
-
- * library/http/http.tcl (geturl, Eof): Added support for 8.6's built
- in zlib routines.
-
-2009-02-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/lrange.test: Revert commits of 2008-07-23. Those were speed
- * tests/binary.test: tests, that are inherently brittle.
-
-2009-02-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Several revisions to the shimmering
- patterns between Unicode and UTF string reps. Most notably the
- call: objPtr = Tcl_NewUnicodeObj(...,0); followed by a loop of calls:
- Tcl_AppendUnicodeToObj(objPtr, u, n); will now grow and append to
- the Unicode representation. Before this commit, the sequence would
- convert each append to UTF and perform the append to the UTF rep.
- This is puzzling and likely a bug. The performance of [string map]
- is significantly improved by this change (according to the MAP
- collection of benchmarks in tclbench). Just in case there was some
- wisdom in the old ways that I missed, I left in the ability to restore
- the old patterns with a #define COMPAT 1 at the top of the file.
-
-2009-02-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: [Bug 2571597]: Fixed mistaken logic in
- * tests/fileName.test: TclFSGetPathType() that assumed (not
- "absolute") => "relative". This is a false assumption on Windows,
- where "volumerelative" is another possibility.
-
-2009-02-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Simplify the logic of the
- Tcl_*SetObjLength() routines.
-
- * generic/tclStringObj.c: Rewrite GrowStringBuffer() so that it
- has parallel structure with GrowUnicodeBuffer(). The revision permits
- allocation attempts to continue all the way up to failure, with no
- gap. It also directly manipulates the String and Tcl_Obj internals
- instead of inefficiently operating via Tcl_*SetObjLength() with all of
- its extra protections and underdocumented special cases.
-
- * generic/tclStringObj.c: Another round of simplification on
- the allocation macros.
-
-2009-02-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tcl.m4, win/configure: Check if cl groks _WIN64 already to
- avoid CC manipulation that can screw up later configure checks.
- Use 'd'ebug runtime in 64-bit builds.
-
-2009-02-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Pare back the length of the unicode
- array in a non-extended String struct to one Tcl_UniChar, meant to
- hold the terminating NUL character. Non-empty unicode strings are
- then stored by extending the String struct by stringPtr->maxChars
- additional slots in that array with sizeof(Tcl_UniChar) bytes per
- slot. This revision makes the allocation macros much simpler.
-
- * generic/tclStringObj.c: Factor out common GrowUnicodeBuffer()
- and solve overflow and growth algorithm fallbacks in it.
-
- * generic/tclStringObj.c: Factor out common GrowStringBuffer().
-
- * generic/tclStringObj.c: Convert Tcl_AppendStringsToObj into
- * tests/stringObj.test: a radically simpler implementation
- where we just loop over calls to Tcl_AppendToObj. This fixes [Bug
- 2597185]. It also creates a *** POTENTIAL INCOMPATIBILITY *** in
- that T_ASTO can now allocate more space than is strictly required,
- like all the other Tcl_Append* routines. The incompatibility was
- detected by test stringObj-6.5, which I've updated to reflect the
- new behavior.
-
- * generic/tclStringObj.c: Revise buffer growth implementation
- in ExtendStringRepWithUnicode. Use cheap checks to determine that
- no reallocation is necessary without cost of computing the precise
- number of bytes needed. Also make use of the string growth algortihm
- in the case of repeated appends.
-
-2009-02-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclZlib.c: Hack needed for official zlib1.dll build.
- * win/configure.in: fix [Feature Request 2605263] use official
- * win/Makefile.in: zlib build.
- * win/configure: (regenerated)
- * compat/zlib/zdll.lib: new files
- * compat/zlib/zlib1.dll:
-
- * win/Makefile.in: [Bug 2605232]: tdbc doesn't build when Tcl is
- compiled with --disable-shared.
-
-2009-02-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [Bug 2603158]: Added protections from
- * generic/tclTestObj.c: invalid memory accesses when we append
- * tests/stringObj.test: (some part of) a Tcl_Obj to itself.
- Added the appendself and appendself2 subcommands to the
- [teststringobj] testing command and added tests to the test suite.
-
- * generic/tclStringObj.c: Factor out duplicate code from
- Tcl_AppendObjToObj.
-
- * generic/tclStringObj.c: Replace the 'size_t uallocated' field
- of the String struct, storing the number of bytes allocated to store
- the Tcl_UniChar array, with an 'int maxChars' field, storing the
- number of Tcl_UniChars that may be stored in the allocated space.
- This reduces memory requirement a small bit, and makes some range
- checks simpler to code.
- * generic/tclTestObj.c: Replace the [teststringobj ualloc] testing
- * tests/stringObj.test: command with [teststringobj maxchars] and
- update the tests.
-
- * generic/tclStringObj.c: Removed limitation in
- Tcl_AppendObjToObj where the char length of the result was only
- computed if the appended string was all single byte characters.
- This limitation was in place to dodge a bug in Tcl_GetUniChar.
- With that bug gone, we can take advantage of always recording the
- length of append results when we know it.
-
-2009-02-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Revisions so that we avoid creating
- the strange representation of an empty string with
- objPtr->bytes == NULL and stringPtr->hasUnicode == 0. Instead in
- the situations where that was being created, create a traditional
- two-legged stork representation (objPtr->bytes = tclEmptyStringRep
- and stringPtr->hasUnicode = 1). In the situations where the strange
- rep was treated differently, continue to do so by testing
- stringPtr->numChars == 0 to detect it. These changes make the code
- more conventional so easier for new maintainers to pick up. Also
- sets up further simplifications.
-
- * generic/tclTestObj.c: Revise updates to [teststringobj] so we don't
- get blocked by MODULE_SCOPE limits.
-
-2009-02-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Rewrites of the routines
- Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetUnicodeFromObj,
- Tcl_GetRange, and TclStringObjReverse to use the new macro, and
- to more simply and clearly split the cases depending on whether
- a valid unicode rep is present or needs to be created.
- New utility routine UnicodeLength(), to compute the length of unicode
- buffer arguments when no length is passed in, with built-in
- overflow protection included. Update three callers to use it.
-
- * generic/tclInt.h: New macro TclNumUtfChars meant to be a faster
- replacement for a full Tcl_NumUtfChars() call when the string has all
- single-byte characters.
-
- * generic/tclStringObj.c: Simplified Tcl_GetCharLength by
- * generic/tclTestObj.c: removing code that did nothing.
- Added early returns from Tcl_*SetObjLength when the desired length
- is already present; adapted test command to the change.
-
- * generic/tclStringObj.c: Re-implemented AppendUtfToUnicodeRep
- so that we no longer pass through Tcl_DStrings which have their own
- sets of problems when lengths overflow the int range. Now AUTUR and
- FillUnicodeRep share a common core routine.
-
-2009-02-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOODefineCmds.c (TclOOGetDefineCmdContext): Use the
- correct field in the Interp structure for retrieving the frame to get
- the context object so that people can extend [oo::define] without deep
- shenanigans. Bug found by Federico Ferri.
-
-2009-02-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Re-implemented AppendUnicodeToUtfRep
- so that we no longer pass through Tcl_DStrings which have their own
- sets of problems when lengths overflow the int range. Now AUTUR and
- UpdateStringOfString share a common core routine.
-
- * generic/tclStringObj.c: Changed type of the 'allocated' field
- * generic/tclTestObj.c: of the String struct (and the
- TestString counterpart) from size_t to int since only int values are
- ever stored in it.
-
-2009-02-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclEncoding.c: Eliminate some unnessary type casts
- * generic/tclEvent.c: some internal const decorations
- * generic/tclExecute.c: spacing
- * generic/tclIndexObj.c:
- * generic/tclInterp.c:
- * generic/tclIO.c:
- * generic/tclIOCmd.c:
- * generic/tclIORChan.c:
- * generic/tclIOUtil.c:
- * generic/tclListObj.c:
- * generic/tclLiteral.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclOOBasic.c:
- * generic/tclPathObj.c:
- * generic/tclPkg.c:
- * generic/tclProc.c:
- * generic/tclRegexp.c:
- * generic/tclScan.c:
- * generic/tclStringObj.c:
- * generic/tclTest.c:
- * generic/tclTestProcBodyObj.c:
- * generic/tclThread.c:
- * generic/tclThreadTest.c:
- * generic/tclTimer.c:
- * generic/tclTrace.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
- * generic/tclStubInit.c: (regenerated)
-
-2009-02-10 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when
- using the native CC.
- * unix/configure: (autoconf-2.59)
-
-2009-02-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclObj.c (Tcl_GetString): Added comments and validity
- checks following the call to an UpdateStringProc.
-
- * generic/tclStringObj.c: Reduce code duplication in Tcl_GetUnicode*.
- Restrict AppendUtfToUtfRep to non-negative length appends.
- Convert all Tcl_InvalidateStringRep() calls into macros.
- Simplify Tcl_AttemptSetObjLength by removing unreachable code.
- Simplify SetStringFromAny() by removing unreachable and duplicate code.
- Simplify Tcl_SetObjLength by removing unreachable code.
- Removed handling of (objPtr->bytes != NULL) from UpdateStringOfString,
- which is only called when objPtr->bytes is NULL.
-
-2009-02-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCompile.c: [Bug 2555129]: const compiler warning (as
- error) in tclCompile.c
-
-2009-02-07 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (TclZlibCmd): [Bug 2573172]: Ensure that when
- invalid subcommand name is given, the list of valid subcommands is
- produced. This gives a better experience when using the command
- interactively.
-
-2009-02-05 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclInterp.c: [Bug 2544618]: Fix argument checking for
- [interp cancel].
- * unix/Makefile.in: Fix build issue with zlib on FreeBSD (and possibly
- other platforms).
-
-2009-02-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (StringIndexCmd, StringRangeCmd, StringLenCmd):
- Simplify the implementation of some commands now that the underlying
- string API knows more about bytearrays.
-
- * generic/tclExecute.c (TclExecuteByteCode): [Bug 2568434]: Make sure
- that INST_CONCAT1 will not lose string reps wrongly.
-
- * generic/tclStringObj.c (Tcl_AppendObjToObj): Special-case the
- appending of one bytearray to another, which can be extremely rapid.
- Part of scheme to address [Bug 1665628] by making the basic string
- operations more efficient on byte arrays.
- (Tcl_GetCharLength, Tcl_GetUniChar, Tcl_GetRange): More special casing
- work for bytearrays.
-
-2009-02-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: [Bug 2561794]: Added overflow protections to
- the AppendUtfToUtfRep routine to either avoid invalid arguments and
- crashes, or to replace them with controlled panics.
-
- * generic/tclCmdMZ.c: [Bug 2561746]: Prevent crashes due to int
- overflow of the length of the result of [string repeat].
-
-2009-02-03 Jan Nijtmans <nijtmans@users.sf.net>
-
- * macosx/tclMacOSXFCmd.c: Eliminate some unnessary type casts
- * unix/tclLoadDyld.c: some internal const decorations
- * unix/tclUnixCompat.c: spacing
- * unix/tclUnixFCmd.c
- * unix/tclUnixFile.c
- * win/tclWinDde.c
- * win/tclWinFCmd.c
- * win/tclWinInit.c
- * win/tclWinLoad.c
- * win/tclWinPipe.c
- * win/tclWinReg.c
- * win/tclWinTest.c
- * generic/tclBasic.c
- * generic/tclBinary.c
- * generic/tclCmdAH.c
- * generic/tclCmdIL.c
- * generic/tclCmdMZ.c
- * generic/tclCompCmds.c
- * generic/tclDictObj.c
-
-2009-02-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclObj.c (tclCmdNameType): [Bug 2558422]: Corrected the type
- of this structure so that extensions that write it (yuk!) will still
- be able to function correctly.
-
-2009-02-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c (SetUnicodeObj): [Bug 2561488]:
- Corrected failure of Tcl_SetUnicodeObj() to panic on a shared object.
- Also factored out common code to reduce duplication.
-
- * generic/tclObj.c (Tcl_GetStringFromObj): Reduce code duplication.
-
-2009-02-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c: Reverted the conversion of [interp] into an
- * tests/interp.test: ensemble. Such conversion is not necessary
- * tests/nre.test: (or even all that helpful) in the NRE-enabling
- of [interp invokehidden], and it has other implications -- including
- significant forkage of the 8.5 and 8.6 implementations -- that are
- better off avoided if there's no gain.
-
- * generic/tclStringObj.c (STRING_NOMEM): [Bug 2494093]: Add missing
- cast of NULL to (char *) that upsets some compilers.
-
- * generic/tclStringObj.c (Tcl_(Attempt)SetObjLength): [Bug 2553906]:
- Added protections against callers asking for negative lengths. It is
- likely when this happens that an integer overflow is to blame.
-
-2009-02-01 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Allow nmake flags such as -a (rebuild all) to pass
- down to the pkgs targets, too.
-
-2009-01-30 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n: [Bug 1216074]: Added another extended example.
-
- * doc/refchan.n: Added an example of how to build a scripted channel.
-
-2009-01-29 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/stringObj.test: [Bug 2006888]: Remove non-ASCII chars from
- non-comment locations in the file, making it work more reliably in
- locales with a non-Latin-1 default encoding.
-
- * generic/tclNamesp.c (Tcl_FindCommand): [Bug 2519474]: Ensure that
- the path is not searched when the TCL_NAMESPACE_ONLY flag is given.
-
- * generic/tclOODecls.h (Tcl_OOInitStubs): [Bug 2537839]: Make the
- declaration of this macro work correctly in the non-stub case.
-
-2009-01-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c: Convert the [interp] command into a
- * tests/interp.test: [namespace ensemble]. Work in progress
- * tests/nre.test: to NRE-enable the [interp invokehidden]
- subcommand.
-
-2009-01-29 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (TclMakeEnsemble): [Bug 2529117]: Make this
- function behave more sensibly when presented with a fully-qualified
- name, rather than doing strange stuff.
-
-2009-01-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (TclInvokeObjectCommand): Made this understand
- what to do if it ends up being used on a command with no objProc; that
- shouldn't happen, but...
-
- * generic/tclNamesp.c (TclMakeEnsemble): [Bug 2529157]: Made this
- understand NRE command implementations better.
- * generic/tclDictObj.c (DictForCmd): Eliminate unnecessary command
- implementation.
-
-2009-01-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOODefineCmds.c (Tcl_ClassSetConstructor):
- [Bug 2531577]: Ensure that caches of constructor chains are cleared
- when the constructor is changed.
-
-2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclInt.h: [Bug 1028264]: WSACleanup() too early.
- * generic/tclEvent.c: The fix introduces "late exit handlers" for
- * win/tclWinSock.c: similar late process-wide cleanups.
-
-2009-01-26 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * win/tclWinSock.c: [Bug 2446662]: Resync Win behavior on RST with
- that of unix (EOF).
-
-2009-01-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ChanClose): [Bug 2536400]: Only generate error
- messages in the interpreter when the thread is not being closed down.
-
-2009-01-23 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/zlib.n: Added a note that 'zlib push' is reversed by 'chan pop'.
-
-2009-01-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCompile.h: CONSTify TclPrintInstruction (TIP #27)
- * generic/tclCompile.c
- * generic/tclInt.h: CONSTify TclpNativeJoinPath (TIP #27)
- * generic/tclFileName.c
- * generic/tcl.decls: {unix win} is equivalent to {generic}
- * generic/tclInt.decls
- * generic/tclDecls.h: (regenerated)
- * generic/tclIntDecls.h
- * generic/tclGetDate.y: Single internal const decoration.
- * generic/tclDate.c:
-
-2009-01-22 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tcl.m4: Corrected a typo ($(SHLIB_VERSION) should be
- ${SHLIB_VERSION}).
- * unix/configure: Autoconf 2.59
-
-2009-01-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (ReflectClose): [Bug 2458202]:
- * generic/tclIORTrans.c (ReflectClose): Closing a channel may supply
- NULL for the 'interp'. Test for finalization needs to be different,
- and one place has to pull the interp out of the channel instead.
-
-2009-01-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: New fix for [Bug 2494093] replaces the
- flawed attempt committed 2009-01-09.
-
-2009-01-19 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/Makefile.in: [Patch 907924]:Added a CONFIG_INSTALL_DIR
- * unix/tcl.m4: parameter so that distributors can control where
- tclConfig.sh goes. Made the installation of 'ldAix' conditional upon
- actually being on an AIX system. Allowed for downstream packagers to
- customize SHLIB_VERSION on BSD-derived systems. Thanks to Stuart
- Cassoff for his help.
- * unix/configure: Autoconf 2.59
-
-2009-01-19 David Gravereaux <davygrvy@pobox.com>
-
- * win/build.vc.bat: Improved tools detection and error message
- * win/makefile.vc: Reorganized the $(TCLOBJ) file list into separate
- parts for easier maintenance. Matched all sources built using -GL to
- both $(lib) and $(link) to use -LTCG and avoid a warning message.
- Addressed the over-building nature of the htmlhelp target by moving
- from a pseudo target to a real target dependent on the entire docs/
- directory contents.
- * win/nmakehlp.c: Removed -g option and GrepForDefine() func as it
- isn't being used anymore. The -V option method is much better.
-
-2009-01-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump patchlevel to 8.6b1.1 to distinguish
- * library/init.tcl: CVS snapshots from the 8.6b1 and 8.6b2 releases
- * unix/configure.in: and to deal with the fact that the 8.6b1
- * win/configure.in: version of init.tcl will not [source] in the
- HEAD version of Tcl.
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2009-01-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Reverted most
- of the substance of my 2009-01-12 commit. NULLing the objProc field of
- a Command when deleting it is important so that tests for certain
- classes of commands don't return false positives when applied to
- deleted command tokens. Overall change is now just replacement of a
- false comment with a true one.
-
-2009-01-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tcl.m4: [Bug 2502365]: Building of head on HPUX is broken when
- using the native CC.
- * unix/configure (autoconf-2.59)
-
-2009-01-13 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (Tcl_ThrowObjCmd): Move implementation of [throw]
- * library/init.tcl (throw): to C from Tcl.
-
-2009-01-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken): One consequence of
- the NRE rewrite is that there are now situations where a NULL objProc
- field in a Command struct is perfectly normal. Removed an outdated
- comment in Tcl_DeleteCommandFromToken that claimed we use
- cmdPtr->objPtr==NULL as a test of command validity. In fact we use
- cmdPtr->flags&CMD_IS_DELETED to perform that test. Also removed the
- setting to NULL, since any extension following the advice of the old
- comment is going to be broken by NRE anyway, and needs to shift to
- flag-based testing (or stop intruding into such internal matters).
- Part of [Bug 2486550].
-
-2009-01-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c (STRING_SIZE): [Bug 2494093]: Corrected
- failure to limit memory allocation requests to the sizes that can be
- supported by Tcl's memory allocation routines.
-
-2009-01-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (NamespaceEnsembleCmd): [Bug 1558654]: Error out
- when someone gives wrong # of args to [namespace ensemble create].
-
-2009-01-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c (STRING_UALLOC): [Bug 2494093]: Added missing
- parens required to get correct results out of things like
- STRING_UALLOC(num + append).
-
-2009-01-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c, generic/tclIndexObj.c, generic/tclListObj.c,
- * generic/tclObj.c, generic/tclStrToD.c, generic/tclUtil.c,
- * generic/tclVar.c: Generate errorcodes for the error cases which
- approximate to "I can't interpret that string as one of those" and
- "You gave me the wrong number of arguments".
-
-2009-01-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: [Tk Bug 2491235]: Added more examples.
-
- * tests/oo.test (oo-22.1): Adjusted test to be less dependent on the
- specifics of how [info frame] reports general frame information, and
- instead to focus on what methods add to it; that's really what the
- test is about anyway.
-
-2009-01-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/stringObj.test: Revise tests that demand a NULL Tcl_ObjType
- in certain values to construct those values with [testdstring] so
- there's no lack of robustness depending on the shimmer history of
- shared literals.
-
-2009-01-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictIncrCmd): Corrected twiddling in internals
- of dictionaries so that literals can't get destroyed.
-
- * tests/expr.test: [Bug 2006879]: Eliminate non-ASCII char.
-
- * generic/tclOOInfo.c (InfoObjectMethodsCmd,InfoClassMethodsCmd):
- [Bug 2489836]: Only delete pointers that were actually allocated!
-
- * generic/tclOO.c (TclNRNewObjectInstance, Tcl_NewObjectInstance):
- [Bug 2481109]: Perform search for existing commands in right context.
-
-2009-01-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (TclNRSourceObjCmd): [Bug 2412068]: Make
- * generic/tclIOUtil.c (TclNREvalFile): implementation of the
- [source] command be NRE enabled so that [yield] inside a script
- sourced in a coroutine can work.
-
-2009-01-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c: Tidy up spacing and code style.
-
-2009-01-03 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (tcl::clock::add): Fixed error message formatting
- in the case where [clock add] is presented with a bad switch.
- * tests/clock.test (clock-65.1) Added a test case for the above
- problem [Bug 2481670].
-
-2009-01-02 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the
- compatibility version of mkstemp() on IRIX.
- * unix/configure.in, unix/Makefile.in (mkstemp.o):
- * compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility
- implementation of the mkstemp() function, which is apparently needed
- on some platforms.
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2008 IN "ChangeLog.2008" ***
- *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" ***
- *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" ***
- *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" ***
- *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.1999 b/ChangeLog.1999
deleted file mode 100644
index e736dee..0000000
--- a/ChangeLog.1999
+++ /dev/null
@@ -1,2634 +0,0 @@
-1999-12-22 Jeff Hobbs <hobbs@scriptics.com>
-
- * changes: updated changes file
- * tools/tclSplash.bmp: updated to show 8.3
-
-1999-12-21 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * generic/tcl.h:
- * mac/README:
- * unix/configure.in:
- * tools/tcl.wse.in:
- * win/README.binary:
- * win/configure.in: updated to patch level 8.3b1
-
- * unix/Makefile.in: added -srcdir=... for 'make html'
-
- * doc/Hash.3: fixed reference to ckfree [Bug 3912]
- * doc/RegExp.3: fixed calling params for Tcl_RegExecFromObj
- * doc/open.n: fixed minor formatting errors
- * doc/string.n: fixed minor formatting errors
-
- * doc/lsort.n: added -unique docs
- * tests/cmdIL.test:
- * generic/tclCmdIL.c: added -unique option to lsort
-
- * generic/tclThreadTest.c: changed thread ids to longs [Bug 3902]
-
- * mac/tclMacOSA.c: fixed applescript for I18N [Bug 3644]
-
- * win/mkd.bat:
- * win/rmd.bat: removed necessity of tag.txt [Bug 3874]
-
- * win/tclWinThrd.c: changed CreateThread to _beginthreadex and
- ExitThread to _endthreadex
-
-1999-12-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/glob.n:
- * tests/fileName.test:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclEncoding.c:
- * generic/tclFileName.c:
- * mac/tclMacFile.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: enhanced the glob command with the new options
- -types -path -directory and -join. Deprecated TclpMatchFiles with
- TclpMatchFilesTypes, extended TclGlob and TclDoGlob and added
- GlobTypeData structure. [Bug 2363]
-
-1999-12-10 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/var.test:
- * generic/tclCompile.c: fixed problem where setting to {} array would
- intermittently not work. [Bug 3339] (Fontaine)
-
- * generic/tclCmdMZ.c:
- * generic/tclExecute.c: optimized INST_TRY_CVT_TO_NUMERIC to recognize
- boolean objects. [Bug 2815] (Spjuth)
-
- * tests/info.test:
- * tests/parseOld.test:
- * generic/tclCmdAH.c:
- * generic/tclProc.c: changed Tcl_UplevelObjCmd (uplevel) and
- Tcl_EvalObjCmd (eval) to use TCL_EVAL_DIRECT in the single arg case as
- well, to take advantage of potential pure list input optimization.
- This means that it won't get byte compiled though, which should be
- acceptable.
- * generic/tclBasic.c: made Tcl_EvalObjEx pure list object aware in the
- TCL_EVAL_DIRECT case for efficiency.
- * generic/tclUtil.c: made Tcl_ConcatObj pure list object aware, and
- return a list object in that case [Bug 2098 2257]
-
- * generic/tclMain.c: changed Tcl_Main to not constantly reuse the
- commandPtr object (interactive case) as it could be shared. (Fellows)
-
- * unix/configure.in:
- * unix/tcl.m4:
- * unix/tclUnixPipe.c: removed checking for compatible vfork function
- and use of the vfork function. Modern VM systems rarely suffer any
- performance degradation when fork is used, and it solves multiple
- problems with vfork. Users that still want vfork can add -Dfork=vfork
- to the compile flags. [Bug 942 2228 1312]
-
-1999-12-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/aclocal.m4: made it just include tcl.m4
-
- * doc/exec.n:
- * doc/open.n:
- * win/tclWin32Dll.c:
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
- * win/tclWinInit.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c: removed all code that supported Win32s. It was no
- longer officially supported, and likely didn't work anyway.
- * win/makefile.vc: removed 16 bit stuff, cleaned up.
-
- * win/tcl16.rc:
- * win/tclWin16.c:
- * win/winDumpExts.c: these files have been removed from the source
- tree (no longer necessary to build)
-
-1999-12-07 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/io.test: removed 'knownBug' tests that were for unsupported0,
- which is now fcopy (that already has tests)
-
- * mac/tclMacPort.h: added utime.h include
-
- * generic/tclDate.c:
- * unix/Makefile.in: fixed make gendate to swap const with CONST so it
- uses the Tcl defined CONST type [Bug 3521]
-
- * generic/tclIO.c: removed panic that could occur in FlushChannel when
- a "blocking" channel would receive EAGAIN, instead treating it the
- same as non-blocking. [Bug 3773]
-
- * generic/tclUtil.c: fixed Tcl_ScanCountedElement to not step beyond
- the end of the counted string. [Bug 3336]
-
-1999-12-03 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/load.n: added note about NT's buggy handling of './' with
- LoadLibrary
-
- * library/http2.1/http.tcl: fixed error handling in http::Event. [Bug
- 3752]
-
- * tests/env.test: removed knownBug limitation from working test
- * tests/all.tcl: ensured that ::tcltest::testsDirectory would be set
- to an absolute path
-
- * tests/expr-old.test:
- * tests/parseExpr.test:
- * tests/string.test:
- * generic/tclGet.c:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * generic/tclParseExpr.c:
- * generic/tclUtil.c:
- * generic/tclExecute.c: added TclCheckBadOctal routine to enhance
- error message checking for when users use invalid octal numbers (like
- 08), as well as replumbed the Expr*Funcs with a new VerifyExprObjType
- to simplify type handling. [Bug 2467]
-
- * tests/expr.test:
- * generic/tclCompile.c: fixed 'bad code length' error for 'expr +
- {[incr]}' case, with new test case [Bug 3736] and seg fault on 'expr
- + {[error]}' (different cause) that was caused by a correct
- optimization that didn't correctly track how it was modifying the
- source string in the opt. The optimization was removed, which means
- that:
- expr 1 + {[string length abc]}
- will be not be compiled inline as before, but this should be written:
- expr {1 + [string length abc]}
- which will be compiled inline for speed. This prevents:
- expr 1 + {[mindless error]}
- from seg faulting, and only affects optimizations for degenerate cases
- [Bug 3737]
-
-1999-12-01 Scott Redman <redman@scriptics.com>
-
- * generic/tcl.decls:
- * generic/tclMain.c:
- * unix/tclAppInit.c:
- * win/tclAppInit.c: Added two new internal functions,
- TclSetStartupScriptFileName() and TclGetStartupScriptFileName() and
- added hooks into the main() code for supporting TclPro and other "big"
- shells more easily without requiring a copy of the main() code.
-
- * generic/tclEncoding.c:
- * generic/tclEvent.c: Moved encoding-related startup code from
- tclEvent.c into the more appropriate tclEncoding.c.
-
-1999-11-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIO.c: fix from Kupries for Tcl_UnstackChannel that
- correctly handles resetting translation and encoding.
-
- * generic/tclLoad.c: #def'd out the unloading of DLLs at finalize time
- for Unix in TclFinalizeLoad. [Bug 2560 3373] Should be parametrized
- to allow for user to specify unload or not.
-
- * win/tclWinTime.c: fixed handling of %Z on NT for time zones that
- don't have DST.
-
-1999-11-29 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/dde1.1/pkgIndex.tcl:
- * library/reg1.0/pkgIndex.tcl: added supported for debugged versions
- of the libraries
-
- * unix/tclUnixPipe.c: fixed PipeBlockModeProc to properly set
- isNonBlocking flag on pipe. [Bug 1356 710]
- removed spurious fcntl call from PipeBlockModeProc
-
- * tests/scan.test:
- * generic/tclScan.c: fixed scan where %[..] didn't match anything and
- added test case. [Bug 3700]
-
-1999-11-24 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/open.n:
- * win/tclWinSerial.c: adopted patch from Schroedter to handle
- fconfigure $sock -lasterror on Windows. [RFE 3368]
-
- * generic/tclCmdIL.c: made SORTMODE_INTEGER work with Longs [Bug 3652]
-
-1999-11-23 Scott Stanton <stanton@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Fixed bug where tcltest output went
- to stdout instead of the specified output file in some cases.
-
-1999-11-19 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclProc.c: backed out change from 1999-11-18 as it could
- affect return string from upvar as well.
-
- * tools/tcl.wse.in: added tcltest1.0 library to distribution list
-
- * doc/http.n:
- * library/http2.1/http.tcl:
- * library/http2.1/pkgIndex.tcl: updated http package to 2.2
-
-1999-11-18 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tcl.m4: added defined for _THREAD_SAFE in --enable-threads
- case; added check for pthread_mutex_init in libc; in AIX case, with
- --enable-threads ${CC}_r is used; fixed flags when using gcc on SCO
-
- * generic/tclProc.c: corrected error reporting for default case at the
- global level for uplevel command.
-
- * generic/tclIOSock.c: changed int to size_t type for len in
- TclSockMinimumBuffers.
-
- * generic/tclCkalloc.c: fixed Tcl_DbCkfree to return a value on NULL
- input. [Bug 3400]
-
- * generic/tclStringObj.c: fixed support for passing in negative length
- to Tcl_SetUnicodeObj, et al handling routines. [Bug 3380]
-
- * doc/scan.n:
- * tests/scan.test:
- * generic/tclScan.c: finished support for inline scan by supporting
- XPG identifiers.
-
- * doc/http.n:
- * library/http2.1/http.tcl: added register and unregister commands to
- http:: package (better support for tls/SSL), as well as -type argument
- to http::geturl. [RFE 2617]
-
- * generic/tclBasic.c: removed extra decr of numLevels in Tcl_EvalObjEx
- that could cause seg fault. (mjansen@wendt.de)
-
- * generic/tclEvent.c: fixed possible lack of MutexUnlock in
- Tcl_DeleteExitHandler. [Bug 3545]
-
- * unix/tcl.m4: Added better pthreads library check and inclusion of
- _THREAD_SAFE in --enable-threads case
- Added support for gcc config on SCO
-
- * doc/glob.n: added note about ..../ glob behavior on Win9*
- * doc/tcltest.n: fixed minor example errors. [Bug 3551]
-
-1999-11-17 Brent Welch <welch@scriptics.com>
-
- * library/http2.1/http.tcl: Correctly fixed the -timeout problem
- mentioned in the 10-29 change. Also added error handling for failed
- writes on the socket during the protocol.
-
-1999-11-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/open.n: corrected docs for 'a' open mode.
-
- * generic/tclIOUtil.c: changed Tcl_Alloc to ckalloc
-
- * generic/tclInt.h:
- * generic/tclObj.c: rolled back changes from 1999-10-29
- Purify noted new leaks with that code
-
- * generic/tclParse.c: added code in Tcl_ParseBraces to test for
- possible unbalanced open brace in a comment
-
- * library/init.tcl: removed the installed binary directory from the
- auto_path variable
-
- * tools/tcl.wse.in: updated to 8.3a1, fixed install of twind.tcl and
- koi8-r.enc files
-
- * unix/tcl.m4: added recognition of pthreads library for AIX
-
-1999-10-29 Brent Welch <welch@scriptics.com>
-
- * generic/tclInt.h: Modified the TclNewObj and TclDecrRefCount in two
- ways. First, in the case of TCL_THREADS, we do not use the special
- Tcl_Obj allocator because that is a source of lock contention. Second,
- general code cleanup to eliminate duplicated code. In particular,
- TclDecrRefCount now uses TclFreeObj instead of duplicating that code,
- so it is now identical to Tcl_DecrRefCount.
-
- * generic/tclObj.c: Changed Tcl_NewObj so it uses the TclNewObj macro
- instead of duplicating the code. Adjusted TclFreeObj so it understands
- the TCL_THREADS case described above.
-
- * library/http2.1/http.tcl: Fixed a bug in the handling of the
- state(status) variable when the -timeout flag is specified. Previously
- it was possible to leave the status undefined instead of empty, which
- caused errors in http::status
-
-1999-10-28 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/aclocal.m4: made it just include tcl.m4
-
- * library/tcltest1.0/tcltest.tcl: updated makeFile to return full
- pathname of file created
-
- * generic/tclStringObj.c: fixed Tcl_AppendStringsToObjVA so it only
- iterates once over the va_list (avoiding a memcpy of it, which is not
- portable).
-
- * generic/tclEnv.c: fixed possible ABR error in environ array
-
- * tests/scan.test:
- * generic/tclScan.c: added support for use of inline scan, XPG3
- currently not included
-
- * tests/incr.test:
- * tests/set.test:
- * generic/tclCompCmds.c: fixed improper bytecode handling of 'eval
- {set array($unknownvar) 5}' (also for incr). [Bug 3184]
-
- * win/tclWinTest.c: added testvolumetype command, as atime is
- completely ignored for Windows FAT file systems
- * win/tclWinPort.h: added sys/utime.h to includes
- * unix/tclUnixPort.h: added utime.h to includes
- * doc/file.n:
- * tests/cmdAH.test:
- * generic/tclCmdAH.c: added time arguments to atime and mtime file
- command methods (support 'touch' functionality)
-
-1999-10-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tclUnixNotfy.c: fixed event/io threading problems by making
- triggerPipe non-blocking. [Bug 2792]
-
- * library/tcltest1.0/tcltest.tcl:
- * generic/tclThreadTest.c: fixed mem leaks in threads
-
- * generic/tclResult.c: fixed Tcl_AppendResultVA so it only iterates
- once over the va_list (avoiding a memcpy of it, which is not
- portable).
-
- * generic/regc_color.c: fixed mem leak and assertion, from HS
-
- * generic/tclCompile.c: removed savedChar trick that appeared to be
- causing a segv when the literal table was released
-
- * tests/string.test:
- * generic/tclCmdMZ.c: fixed [string index] to return ByteArrayObj when
- indexing into one (test case string-5.16). [Bug 2871]
-
- * library/http2.1/http.tcl: protected gets with catch. [Bug 2665]
-
-1999-10-19 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * doc/tcltest.n:
- * library/tcltest1.0/tcltest.tcl: Removed the extra return at the end
- of the tcltest.tcl file, added version information about tcl.
-
- Applied patches sent in by Andreas Kupries to add helper procs for
- debug output, add 3 new flags (-testsdir, -load, -loadfile), and
- internally refactors common code for dealing with paths into separate
- procedures. [Bug 2838, 2842]
-
- Merged code from core-8-2-1 branch that changes the checks for the
- value of tcl_interactive to also incorporate a check for the existence
- of the variable.
-
- * tests/autoMkindex.test:
- * tests/pkgMkIndex.test: Explicitly cd to ::tcltest::testsDirectory at
- the beginning of the test run
-
- * tests/basic.test: Use version information defined in tcltest instead
- of hard-coded version number
-
- * tests/socket.test: package require tcltest before attempting to use
- variable defined in tcltest namespace
-
- * tests/unixInit.test:
- * tests/unixNotfy.test: Added explicit exits needed to avoid problems
- when the tests area run in wish.
-
-1999-10-12 Jim Ingham <jingham@scriptics.com>
-
- * mac/tclMacLoad.c: Stupid bug - we converted the filename to
- external, but used the unconverted version.
- * mac/tclMacFCmd.c: Fix a merge error in the bug fix for [Bug 2869]
-
-1999-10-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/regc_color.c:
- * generic/regc_cvec.c:
- * generic/regc_lex.c:
- * generic/regc_locale.c:
- * generic/regcomp.c:
- * generic/regcustom.h:
- * generic/regerrs.h:
- * generic/regex.h:
- * generic/regexec.c:
- * generic/regguts.h:
- * generic/tclRegexp.c:
- * generic/tclTest.c:
- * tests/reg.test: updated to Henry Spencer's new regexp engine
- (mid-Sept 99). Should greatly reduce stack space reqs.
-
- * library/tcltest1.0/pkgIndex.tcl: fixed procs in pkgIndex.tcl file
-
- * generic/tclEnv.c: fixed mem leak with putenv and DStrings
- * doc/Encoding.3: corrected docs
- * tests/basic.test: updated test cases for 8.3
- * tests/encoding.test: fixed test case that change system encoding to
- a double-byte one (this causes a bogus mem read error for purify)
- * unix/Makefile.in: purify has to use -best-effort to instrument
- * unix/tclAppInit.c: identified potential mem leak when compiling
- tcltest (not critical)
- * unix/tclUnixPipe.c: fixed mem leak in TclpCreateProcess when doing
- alloc between vfork and execvp.
- * unix/tclUnixTest.c: fixed mem leak in findexecutable test command
-
-1999-10-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * {win,mac,unix,tools,}/README:
- * win/README.binary:
- * win/makefile.vc:
- * {win,unix}/configure.in:
- * generic/tcl.h:
- * library/init.tcl: updated to 8.3a1 from 8.2.0.
-
- * library/http2.1/http.tcl: fixed possible use of global c var.
-
- * win/tclWinReg.c: fixed registry command to properly 'get'
- HKEY_PERFORMANCE_DATA root key data. Needs more work.
-
- * generic/tclNamesp.c:
- * generic/tclVar.c:
- * generic/tclCmdIL.c: fixed comment typos
-
- * mac/tclMacFCmd.c: fixed filename stuff to support UTF-8. [Bug 2869]
-
- * win/tclWinSerial.c: changed SerialSetOptionProc to return TCL_OK by
- default. (patch from Rolf Schroedter)
-
-1999-09-21 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Applied patches sent in by Andreas
- Kupries to fix typos in comments and ::tcltest::grep, fix hook
- redefinition problems, and change "string compare" to "string equal".
- [Bug 2836, 2837, 2839, 2840]
-
-1999-09-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/env.test:
- * unix/Makefile.in: added support for AIX LIBPATH env var. [Bug 2793]
- removed second definition of INCLUDE_INSTALL_DIR (the one that
- referenced @includedir@) [Bug 2805]
- * unix/dltest/Makefile.in: added -lc to LIBS. [Bug 2794]
-
-1999-09-16 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/timer.test: changed after delay in timer test 6.29 from 1 to
- 10. [Bug 2796]
-
- * tests/pkg.test:
- * generic/tclPkg.c: fixed package version check to disallow 1.2..3
- [Bug 2539]
-
- * unix/Makefile.in: fixed gendate target - this never worked since RCS
- was intro'd.
- * generic/tclGetDate.y: updated to reflect previous changes to
- tclDate.c (leap year calc) and added CEST and UCT time zone
- recognition. Fixed 4 missing UCHAR() casts. [Bug 2717, 954, 1245,
- 1249]
-
- * generic/tclCkalloc.c: changed Tcl_DumpActiveMemory to really dump to
- stderr and close it [Bug 725] and changed Tcl_Ckrealloc and
- Tcl_Ckfree to not bomb when NULL was passed in [Bug 1719] and changed
- Tcl_Alloc, et al to not panic when a alloc request for zero came
- through and NULL was returned (valid on AIX, Tru64) [Bug 2795, etc]
-
- * tests/clock.test:
- * doc/clock.n:
- * generic/tclClock.c: added -milliseconds switch to clock clicks to
- guarantee that the return value of clicks is in the millisecs
- granularity. [Bug 2682, 1332]
-
-1999-09-15 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIOCmd.c: fixed potential core dump in conjunction with
- stacked channels with result obj manipulation in Tcl_ReadChars. [Bug
- 2623]
-
- * tests/format.test:
- * generic/tclCmdAH.c: fixed translation of %0#s in format. [Bug 2605]
-
- * doc/msgcat.n: fixed \\ bug in example. [Bug 2548]
-
- * unix/tcl.m4:
- * unix/aclocal.m4: added fix for FreeBSD-[1-2] recognition [Bug 2070]
- and fix for IRIX SHLIB_LB_LIBS. [Bug 2610]
-
- * doc/array.n:
- * tests/var.test:
- * tests/set.test:
- * generic/tclVar.c: added an array unset operation, with docs and
- tests. Variation of [Bug 1775]. Added fix in TclArraySet to check
- when trying to set in a non-existent namespace. [Bug 2613]
-
-1999-09-14 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/linsert.test:
- * doc/linsert.n:
- * generic/tclCmdIL.c: fixed end-int interpretation of linsert to
- correctly calculate value for end, added test and docs. [Bug 2693]
-
- * doc/regexp.n:
- * doc/regsub.n:
- * tests/regexp.test:
- * generic/tclCmdMZ.c: add -start switch to regexp and regsub with docs
- and tests
-
- * doc/switch.n: added proper use of comments to example.
- * generic/tclCmdMZ.c: changed switch to complain when an error occurs
- that seems to be due to a misplaced comment.
-
- * generic/tclCmdMZ.c: fixed illegal ref for \[0-9] substitutions in
- regsub. [Bug 2723]
-
- * generic/tclCmdMZ.c: changed [string equal] to return an Int type
- object (was a Boolean)
-
-1999-09-01 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Process command-line arguments only
- ::tcltest doesn't have a child namespace (requires that command-line
- args are processed in that namespace)
-
-1999-09-01 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclParseExpr.c: changed '"' to '\"' to make FreeBSD happy.
- [Bug 2625]
- * generic/tclProc.c: moved static buf to better location and changed
- static msg that would overflow in ProcessProcResultCode [Bug 2483]
- and added Tcl_DStringFree to Tcl_ProcObjCmd. Also reworked size of
- static buffers.
- * tests/stringObj.test: added test 9.11
- * generic/tclStringObj.c: changed Tcl_AppendObjToObj to properly
- handle the 1-byte dest and mixed src case where both had had Unicode
- string len checks made on them. [Bug 2678]
- * unix/aclocal.m4:
- * unix/tcl.m4: adjusted fix from 8-21 to add -bnoentry to the AIX-*
- case and readjusted the range
-
-1999-08-31 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl:
- * doc/tcltest.n:
- * tests/README: Modified testConstraints variable so that it isn't
- unset every time ::tcltest::initConstraints is called and cleaned up
- documentation in the README file and the man page.
-
-1999-08-27 Jennifer Hom <jenn@scriptics.com>
-
- * tests/env.test:
- * tests/exec.test:
- * tests/io.test:
- * tests/event.test:
- * tests/tcltest.test: Added 'exit' calls to scripts that the tests
- themselves write, and removed accidental checkin of knownBugThreaded
- constraints for Solaris and Linux.
-
- * library/tcltest1.0/tcltest.tcl: Modified tcltest so that variables
- are only initialized to their default values if they did not
- previously exist.
-
-1999-08-26 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Added a -args flag that sets a
- variable named ::tcltest::parameters based on whatever's being sent in
- as the argument to the -args flag.
-
-1999-08-23 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test: Added additional tests for -tmpdir, marked all
- tests that use exec as unixOrPc.
-
- * tests/encoding.test:
- * tests/interp.test:
- * tests/macFCmd.test:
- * tests/parseOld.test:
- * tests/regexp.test: Applied patches from Jim Ingham to add encoding
- to a Mac only interp test, change an error message in macFCmd.tet, put
- a comment in parseOld.test, fix tests using the testencoding path
- command, and put unixOrPc constraints on tests that use exec.
-
-1999-08-21 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/aclocal.m4: Changed AIX-4.[2-9] check to AIX-4.[1-9] [Bug 1909]
-
-1999-08-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclPosixStr.c: fixed typo. [Bug 2592]
-
- * doc/*: fixed various nroff bugs in man pages. [Bug 2503 2588]
-
-1999-08-19 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/README.binary: fixed version info and some typos. [Bug 2561]
-
- * doc/interp.n: updated list of commands available in a safe
- interpreter. [Bug 2526]
-
- * generic/tclIO.c: changed Tcl_GetChannelNames* to use style guide
- headers (pleases HP cc)
-
-1999-08-18 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/Eval.3: fixed doc on input args. [Bug 2114]
-
- * doc/OpenFileChnl.3:
- * doc/file.n:
- * tests/cmdAH.test:
- * tclIO.c:
- * tclCmdAH.c: added "file channels ?pattern?" tcl command, with
- associated Tcl_GetChannelNames and Tcl_GetChannelNamesEx public C APIs
- (added to tcl.decls as well), with docs and tests.
-
- * tests/expr.test:
- * generic/tclCompile.c: add TCL_TOKEN_VARIABLE to the part types that
- cause differed compilation for exprs, to correct the expr
- double-evaluation problem for vars. Added test cases. Related to [Bug
- 732]
-
- * unix/Makefile.in: changed the dependency structure so that install-*
- is dependent on * (ie - install-binaries is dependent on binaries).
-
- * library/auto.tcl:
- * library/init.tcl:
- * library/ldAout.tcl:
- * library/package.tcl:
- * library/safe.tcl:
- * library/word.tcl:
- * library/http2.1/http.tcl:
- * library/msgcat1.0/msgcat.tcl: updated libraries to better Tcl style
- guide (no more string comparisons with == or !=, spacing changes).
-
-1999-08-05 Jim Ingham <jingham@cygnus.com>
-
- * mac/tclMacProjects.sea.hqx: Rearrange the projects so that the build
- directory is separate from the sources. Much more convenient!
-
-1999-08-13 Scott Redman <redman@scriptics.com>
-
- * /: 8.2.0 tagged for final release
-
-1999-08-12 Scott Stanton <stanton@scriptics.com>
-
- * win/Makefile.in: Added COMPILE_DEBUG_FLAGS macro to make it easier
- to turn on compiler tracing.
-
- * tests/parse.test:
- * generic/tclParse.c: Fixed bug in Tcl_EvalEx where the termOffset was
- not being updated in cases where the evaluation returned a non TCL_OK
- error code. [Bug 2535]
-
-1999-08-12 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSerial.c: Applied patch from Petteri Kettunen to remove
- compiler warning.
-
-1999-08-10 Scott Redman <redman@scriptics.com>
-
- * generic/tclAlloc.c:
- * generic/tclCmdIL.c:
- * generic/tclIO.c:
- * generic/tclThread.c:
- * win/tclWinThrd.c:
- * unix/tclUnixThrd.c: Fixed Brent's changes so that they work on
- Windows (and he fixed the bug in the Unix thread implementation).
-
-1999-08-09 Brent Welch <welch@scriptics.com>
-
- * generic/tcl.decls:
- * generic/tclAlloc.c:
- * generic/tclCkalloc.c:
- * generic/tclCmdIL.c:
- * generic/tclDecls.h:
- * generic/tclIO.c:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclVar.c:
- * mac/tclMacThrd.c:
- * unix/tclUnixThrd.c:
- * win/tclWinThrd.c: Added use of Tcl_GetAllocMutex to tclAlloc.c and
- tclCkalloc.c so they can be linked against alternate thread packages.
- Added Tcl_GetChannelNames to tclIO.c. Added TclVarTraceExists hook so
- "info exists" triggers read traces exactly like it did in Tcl 7.6.
- Stubs table changes to reflect new internal and external APIs.
-
-1999-08-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/string.test: added largest_int proc to adapt for >32 bit
- machines and int overflow testing.
- * tests/tcltest.test: fixed minor error in 8.2 result (from dgp)
-
- * doc/Object.3: clarified Tcl_DecrRefCount docs. [Bug 1952]
- * doc/array.n: clarified array pattern docs. [Bug 1330]
- * doc/clock.n: fixed clock docs. [Bug 693]
- * doc/lindex.n: clarified to account for new end-int behavior.
- * doc/string.n: fixed formatting errors. [Bug 2188 2189]
- * doc/tclvars.n: fixed doc error. [Bug 2042]
- * library/init.tcl: fixed path handling in auto_execok (it could miss
- including the normal path on some Windows machines). [Bug 1276]
-
-1999-08-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/tclvars.n: Made it clear that tcl_pkgPath was not set for
- Windows (already mentioned in init.tcl). [Bug 2455]
- * generic/tclLiteral.c: fixed reference to bytes that might not be
- null terminated (using objPtr->bytes, which is). [Bug 2496]
- * library/http2.1/http.tcl: Made use of "i" in init section use local
- var and start at 0 (was 1). [Bug 2502]
-
-1999-08-04 Scott Stanton <stanton@scriptics.com>
-
- * tests/reg.test: Added test for REG_EXPECT bug fixed by Henry's
- patch.
-
- * generic/regc_nfa.c:
- * generic/regcomp.c:
- * generic/rege_dfa.c:
- * generic/regexec.c:
- * generic/regguts.h: Applied patches supplied by Henry Spencer to
- greatly enhance the performance of certain classes of regular
- expressions. [Bug 2440, 2447]
-
-1999-08-03 Scott Redman <redman@scriptics.com>
-
- * win/tclWinInt.h: Remove function declarations in header that was
- moved to tclInt.decls file in previous changes.
-
-1999-08-02 Scott Redman <redman@scriptics.com>
-
- * unix/configure.in:
- * win/configure.in: Change beta level to b2.
-
- * generic/tcl.h:
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclInt.h:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclRegexp.h:
- * generic/tclStubInit.c: Move some exported public and internal
- functions to the stub tables. Removed functions that are in the stub
- tables (from this and previous changes) from the original header
- files.
-
-1999-08-01 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSock.c: Added comment block to SocketThread() function.
- Added code to avoid calling TerminateThread(), but instead to send a
- message to the socket event window to tell it to terminate its thread.
-
-1999-07-30 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Exit with non-zero status if there
- were problems with the way the test suite was started (e.g. wrong #
- arguments).
-
-1999-07-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclInt.decls: added declaractions necessary for the Tcl test
- code to work wth stubs. [Bug 2445]
-
-1999-07-30 Scott Redman <redman@scriptics.com>
-
- * win/tclWinPipe.c:
- * win/Makefile.in: Fixing launching of 16-bit apps on Win9x from wish.
- The command line was primed with tclpip82.dll, but it was ignored.
- Fixed that, then fixed the gmake makefile to build tclpip82.dll as an
- executable.
-
- * win/tclWinSock.c: Applied small patch to get thread-specific data
- after initializing the socket driver.
-
- * unix/tclUnixThrd.c: Applied patch to fix threads on Irix 6.5. Patch
- from James Dennett. [Bug 2450]
-
- * tests/info.test: Enable test for tclParse.c change (info complete).
-
-1999-07-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * tclIO.c: added fix for Kupries' trf patch. [Bug 2386]
-
- * tclParse.c: fixed bug in info complete regarding nested square
- brackets. [Bug 2382, 2466]
-
-1999-07-29 Scott Redman <redman@scriptics.com>
-
- * win/tclWinChan.c: Allow tcl to open CON and NUL, even for std
- channels. Checking for bad/unusable std channels was moved to Tk since
- its only purpose was to check whether to use the Tk Console Window for
- the std channels. [Bug 2393 2392 2209 2458]
-
- * unix/mkLinks.tcl: Applied patch to avoid linking pack.n to
- pack-old.n. Patch from Don Porter. [Bug 2469]
-
- * doc/Encoding.n: Applied patch to fix typo in .SH NAME line. Patch
- from Don Porter. [Bug 2451]
-
- * win/tclWinSock.c: Free Win32 Event handles when destroying the
- socket helper thread.
-
-1999-07-28 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Fixed the condition under which
- ::tcltest::PrintError had an infinite loop problem and added a test
- case for it. Added an optional argument to ::tcltest::getMatchingFiles
- telling it where to search for test files.
-
-1999-07-27 Scott Redman <redman@scriptics.com>
-
- * tools/tclSplash.bmp: Updated Windows installer bitmap to ready
- Tcl/Tk Version 8.2.
-
-1999-07-26 Scott Redman <redman@scriptics.com>
-
- * tests/tcltest.test: Need to close the new core file, there seems to
- be a hang in threaded WinNT if the file isn't closed. Open issue, need
- to fix that hang.
-
- * tests/httpold.test: Add time delay in response from Http server so
- that test cases can properly detect timeout conditions with threads
- enabled on multi-CPU WinNT.
-
- * tests/winFCmd.test: Test case winFcmd-1.33 was looking for
- c:\windows, which may not exist. Instead, create a new directory on
- c:\ and use it for the test.
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c: Fix terminating helper threads by holding any
- mutexes from the primary thread while waiting for the helper thread to
- terminate. Without these changes, the test suite hangs on WinNT with 2
- CPUs and threads enabled. Open issue, seems to be a sporadic hang on
- dual CPU systems still (very rare).
-
-1999-07-26 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl:
- * doc/tcltest.n: Cleaned up code in ::tcltest::PrintError, revised
- documentation, and added tests for the tcltest package.
-
-1999-07-23 Scott Redman <redman@scriptics.com>
-
- * tests/info.test:
- * generic/tclParse.c: Removed patch for info command, breaks test
- cases on Unix. Patch was bad and needs to be redone properly. [Bug
- 2382]
-
-1999-07-22 Scott Redman <redman@scriptics.com>
-
- * Changed version to 8.2b2.
-
- * win/tclWinSock.c: Fixed hang with threads enabled, fixed semaphores
- with threads disabled.
-
- * win/safe.test: Fixed safe-6.3 with threads enabled.
-
- * win/Makefile.in: Fixed calling of tcltest to fix safe.test failures
- due to path TCL_LIBRARY path.
-
- * win/tclWinPort.h: Block out include of sys/*.h in order to build
- extensions with MetroWerks compiler for Win32. [Bug 2385]
-
- * generic/tclCmdMZ.c:
- * generic/tclIO.c: Fix ANSI-style prototypes based on patch from
- Ulrich Ring. [Bug 2391]
-
- * unix/Makefile.in: Need to make install-sh executable before calling
- (with chmod +x). [Bug 2413]
-
- * tests/var.test:
- * generic/tclVar.c: Fixed bug that caused a seg. fault when using
- "array set a(b) {}", which is a bad array name anyway. Now the "array
- set" command will return an error in this case. Added test case and
- fixed existing test. [Bug 2427]
-
-1999-07-21 Scott Redman <redman@scriptics.com>
-
- * tests/info.test:
- * generic/tclParse.c: Applied patch to fix "info complete" for the
- string {[a [b]}. Patch from Peter Spjuth. [Bug 2382]
-
- * doc/Utf.3:
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclUtf.c: Changed function declarations in
- non-platform-specific public APIs to use "unsigned long" instead of
- "size_t", which may not be defined on certain compilers (rather than
- include sys/types.h, which may not exist).
-
- * unix/Makefile.in: Added the Windows configure script to the
- distribution file list, already shipping configure.in and the .m4
- files, but needed the configure script itself.
-
- * win/makefile.vc: Changed version number of DDE package in VC++
- makefile to use 1.1 instead of 1.0.
-
- * doc/open.n: Added documentation of \\.\comX notation for opening
- serial ports on Windows (alternative to comX:).
-
- * tests/ioCmd.test:
- * doc/open.n:
- * win/tclWinSerial.c: Applied patch from Rolf Schroedter to add
- -pollinterval option to fconfigure to modify the maxblocktime used in
- the fileevent polling. Added documentation and fixed the test case as
- well.
-
- * win/tclWinSock.c: Modified 8.1.0 version of the Win32 socket driver
- to move the handling of the socket event window in a separate thread.
- It also turned out that Win95 & Win98 were, in some cases, getting
- multiple FD_ACCEPTs but only handling one. Added a count for the
- FD_ACCEPT to take care of this. Tested on NT4 SP3, NT4 SP4, Win95, and
- Win98. [Bug 2178 2256 2259 2329 2323 2355]
-
-1999-07-21 Jerry Peek <jpeek@scriptics.com>
-
- * README: Small tweaks to clean up typos and wording.
-
-1999-07-20 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * generic/tclInitScript.h:
- * unix/tclUnixInit.c: merged code with 8.0.5. We now use an
- intermediate global tcl var "tclDefaultLibrary" to keep the
- "tcl_library" var from being set by the default value in the Makefile.
- Also fixed a bug in which caused the value of TCL_LIBRARY env var to
- be ignored.
- * unix/tclWinInit.c: just updated some comments.
-
-1999-07-19 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * library/http2.1/http.tcl: updated -useragent text to say version
- 2.1.
-
-1999-07-16 Scott Redman <redman@scriptics.com>
-
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclStubInit.c: Add Tcl_SetNotifier to stub table. [Bug 2364]
-
- * unix/aclocal.m4:
- * unix/tcl.m4: Add check for Alpha/Linux to correct the IEEE floating
- flag to the compiler, should be -mieee. Patch from Don Porter.
-
- * tools/tcl.hpj.in: Change version number of .cnt file referenced in
- .HPJ file.
-
-1999-07-15 Scott Redman <redman@scriptics.com>
-
- * tools/tcl.wse.in: Fixed naming of target files for Windows.
-
-1999-07-14 Jerry Peek <jpeek@scriptics.com>
-
- * doc/re_syntax.n: Deleted sentence as suggested by Scott S.
-
-1999-07-12 Jerry Peek <jpeek@scriptics.com>
-
- * doc/re_syntax.n: Removed two notes to myself (oops), cleaned up
- wording, fixed changebars, made two examples easier to read.
-
-1999-07-11 Scott Redman <redman@scriptics.com>
-
- * win/makefile.vc: Since the makefile.vc should continue to work while
- we're working out bugs/issues in the new TEA-style
- autoconf/configure/gmake build mechanism for Windows, the version
- numbers of the Tcl libraries need to remain in sync. Modified the
- version numbers in the makefile to reflect the change to 8.2b1.
-
-1999-07-09 Scott Redman <redman@scriptics.com>
-
- * win/configure.in: Eval DLLSUFFIX, LIBSUFFIX, and EXESUFFIX in the
- configure script so that substitutions get expanded before being
- placed in the Makefile. The "d" portion for debug libraries and DLLs
- was not being set properly.
-
-1999-07-08 Scott Stanton <stanton@scriptics.com>
-
- * tests/string.test:
- * generic/tclCmdMZ.c: Fixed bug in string range bounds checking code.
-
-1999-07-08 Jennifer Hom <jenn@scriptics.com>
-
- * doc/tcltest.n:
- * library/tcltest1.0/tcltest.tcl: Removed -asidefromdir and
- -relateddir flags, removed unused ::tcltest::dotests proc, cleaned up
- implementation of core file checking, and fixed the code that checks
- for 1-letter flag abbreviations.
-
-1999-07-08 Scott Stanton <stanton@scriptics.com>
-
- * win/Makefile.in: Added tcltest target so runtest works properly.
- Added missing names to the clean/distclean targets.
-
- * tests/reg.test:
- * generic/rege_dfa.c: Applied fix supplied by Henry Spencer for bug in
- DFA state caching under lookahead conditions. [Bug 2318]
-
-1999-07-07 Scott Stanton <stanton@scriptics.com>
-
- * doc/fconfigure.n: Clarified default buffering behavior for the
- standard channels. [Bug 2335]
-
-1999-07-06 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSerial.c: New implementation of serial port driver from
- Rolf Shroedter (Rolf.Schroedter@dlr.de) that allows more than one byte
- to be read from the port. Implemented using polling instead of
- threads, there is a max. 10ms latency between checking the port for
- file events. [Bug 1980 2217]
-
-1999-07-06 Brent Welch <welch@scriptics.com>
-
- * library/http2.0/http.tcl: Fixed the -timeout option so it handles
- timeouts that occur during connection attempts to hosts that are down
- (the only case that really matters!)
-
-1999-07-03 Brent Welch <welch@scriptics.com>
-
- * doc/ChnlStack.3:
- * generic/tcl.decls:
- * generic/tclIO.c: Added a new variant of the "Trf patch" from Andreas
- Kupres that adds new C APIs Tcl_StackChannel, Tcl_UnstackChannel, and
- Tcl_GetStackedChannel.
-
-1999-07-03 Brent Welch <welch@scriptics.com>
-
- * generic/tclNotify.c:
- * unix/tclUnixNotfy.c:
- * unix/tclXtTest.c:
- * unix/tclXtNotify.c:
- * win/tclWinNotify.c:
- * mac/tclMacNotify.c: Added Tcl_SetNotifier and the associated hook
- points in the notifiers to be able to replace the notifier calls at
- runtime. The Xt notifier and test program use this hook.
-
-1999-07-03 Brent Welch <welch@scriptics.com>
-
- * generic/tclParse.c: Changed parsing of variable names to allow empty
- array names. Now "$(foo)" is a variable reference! Previous you had to
- use something like $::(foo), which is slower. This change is requested
- by Jean-Luc Fontaine for his STOOOP package.
-
-1999-07-01 Scott Redman <redman@scriptics.com>
-
- * generic/tclCmdAH.c:
- * generic/tclFCmd.c: Call TclStat instead of TclpStat in order to
- allow Tcl_Stat hooks to work properly.
-
-1999-06-29 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/pkgIndex.tcl:
- * library/tcltest1.0/tcltest.tcl:
- * doc/tcltest.n:
- * tests/all.tcl: Added -preservecore, -limitconstraints, -help, -file,
- -notfile, -relateddir and -asidefromdir flags to the tcltest package
- along with exported proc ::tcltest::getMatchingFiles. The
- documentation was modified to match and all.tcl was modified to use
- the new functionality instead of implementing -file itself.
-
-1999-06-28 Scott Redman <redman@scriptics.com>
-
- * generic/tclIndexObj.c:
- * doc/GetIndex.3:
- * tests/binary.test:
- * tests/winDde.test: Applied patch from Peter Hardie (with changes) to
- fix problem with Tcl_GetIndexFromObj() when the key being passed is
- the empty string. It used to match "" and return TCL_OK, but it should
- have returned TCL_ERROR instead. Added test case to "binary" and "dde"
- commands to check the behavior. Added documentation note as well.
-
-1999-06-26 Scott Redman <redman@scriptics.com>
-
- * win/tclWinDde.c: Applied patch from Peter Hardie to add poke command
- to dde. Also rev'd version of dde package to 1.1. [Bug 1738]
-
-1999-06-25 Jennifer Hom <jenn@scriptics.com>
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * library/tcltest1.0/pkgIndex.tcl:
- * library/tcltest1.0/tcltest.tcl:
- * library/tcltest1.0: Added initial implementation of the Tcl test
- harness package. This package was based on the defs.tcl file that was
- part of the tests directory. Reversed the way that tests were
- evaluated to fix a problem with false passes.
-
- * doc/tcltest.n: Added documentation for the tcltest package.
-
- * tests/README:
- * tests/defs.tcl:
- * tests/all.tcl: Modified all test files (tests/*.test) and all.tcl to
- use the new tcltest package and removed references to the defs.tcl
- file. Modified the README file to point to the man page for tcltest.
-
-1999-06-25 Scott Stanton <stanton@scriptics.com>
-
- * tests/reg.test:
- * generic/regexec.c: Fixed bugs in non-greedy quantifiers.
-
-1999-06-23 Jerry Peek <jpeek@scriptics.com>
-
- * doc/re_syntax.n:
- * doc/switch.n:
- * doc/lsearch.n:
- * doc/RegExp.3:
- * doc/regexp.n:
- * doc/regsub.n: Moved information about syntax of 8.1 regular
- expressions from regexp(n) manpage into new re_syntax(n) page. Added
- pointers from other manpages to new re_syntax(n) page.
-
-1999-06-23 Scott Stanton <stanton@scriptics.com>
-
- * unix/Makefile.in: Changed install-doc to install-man.
-
- * tools/uniParse.tcl:
- * tools/uniClass.tcl:
- * tools/README:
- * tests/string.test:
- * generic/regc_locale.c:
- * generic/tclUniData.c:
- * generic/tclUtf.c:
- * doc/string.n: Updated Unicode character tables to reflect latest
- Unicode 2.1 data. Also rationalized "regexp" and "string is"
- definitions of character classes.
-
-1999-06-21 Scott Stanton <stanton@scriptics.com>
-
- * unix/tclUnixThrd.c (TclpThreadCreate): Fixed memory leak where
- thread attributes were not being released. [Bug 2254]
-
-1999-06-17 Scott Stanton <stanton@scriptics.com>
-
- * tests/regexp.test:
- * generic/tclCmdMZ.c:
- * generic/tclCmdIL.c: Changed to use new regexp interfaces. Added
- -expanded, -line, -linestop, and -lineanchor switches to regsub.
-
- * doc/RegExp.3: Documented the new regexp interfaces and the
- compile/execute flags.
-
- * generic/tclTest.c:
- * generic/tclRegexp.h:
- * generic/tclRegexp.c:
- * generic/tcl.h:
- * generic/tcl.decls: Renamed Tcl_RegExpMatchObj to Tcl_RegExpExecObj
- and added a new Tcl_RegExpMatchObj that is equivalent to
- Tcl_RegExpMatch. Added public macros for the regexp compile/execute
- flags. Changed to store either an object pointer or a string pointer
- in the TclRegexp structure. Changed to avoid adding a reference to the
- object or copying the string.
-
- * generic/regcomp.c: lint
-
- * tests/reg.test:
- * generic/regex.h:
- * generic/regc_lex.c: Added REG_BOSONLY flag to allow Expect to
- iterate through a string an only find matches that start at the
- current position within the string.
-
-1999-06-16 Michael Thomas <wart@scriptics.com>
-
- * unix/configure.in:
- * unix/Makefile.in:
- * unix/tcl.m4:
- * unix/aclocal.m4: Numerous build changes to make Tcl conform to the
- proposed TEA spec
-
-1999-06-16 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * generic/tclVar.c (Tcl_VariableObjCmd): fixed premature increment in
- loop that was causing out-of-bounds reads on array "varName".
-
-1999-06-16 Scott Stanton <stanton@scriptics.com>
-
- * tests/execute.test:
- * generic/tclExecute.c (TclExecuteByteCode): Fixed crash caused by a
- bug in INST_LOAD_SCALAR1 where the scalar index was read as a signed 1
- byte value instead of unsigned. [Bug 2243]
-
-1999-06-14 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * doc/StringObj.3
- * test/stringObj.test
- * unix/Makefile.in
- * win/Makefile.in
- * win/makefile.vc
- * generic/tclStringObj.c:
- Merged String and Unicode object types. Added new functions to the
- puplic API: Tcl_NewUnicodeObj, Tcl_SetUnicodeObj, Tcl_GetUnicode,
- Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange,
- Tcl_AppendUnicodeToObj.
-
-1999-06-09 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclUnicodeObj.c: Lots of cleanup and simplification. Fixed
- several memory bugs. Added TclAppendUnicodeToObj.
-
- * generic/tclInt.h: Added declarations for various Unicode string
- functions.
-
- * generic/tclRegexp.c:
- * generic/tclCmdMZ.c: Changed to use new Unicode string interfaces for
- better performance.
-
- * generic/tclRegexp.h:
- * generic/tclRegexp.c:
- * generic/tcl.h:
- * generic/tcl.decls: Added Tcl_RegExpMatchObj and Tcl_RegExpGetInfo
- calls to access lower level regexp API. These features are needed by
- Expect. This is a preliminary implementation pending final review and
- cleanup.
-
- * generic/tclCmdMZ.c:
- * tests/string.test: Fixed bug where string map failed on null strings
-
- * generic/regexec.c:
- * unix/tclUnixNotfy.c: lint
-
- * tools/genStubs.tcl: Changed to always write output in LF mode.
-
-1999-06-08 Scott Stanton <stanton@scriptics.com>
-
- * win/tclWinSock.c: Rolled back to the 8.1.0 implementation because of
- serious problems with the new driver. Basically no incoming socket
- connections would be reported to a server port. The 8.1.1 code needs
- to be redesigned and fixed correctly.
-
-1999-06-07 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * tests/string.test:
- * generic/tclVar.c (Tcl_SetVar2Ex):
- * generic/tclStringObj.c (Tcl_AppendObjToObj):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): optimized the string index,
- string length, string range, and append command in cases where the
- object's internal rep is a bytearray. Objects with other internal reps
- are converted to have the new unicode internal rep.
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/Makefile.vc:
- * tests/unicode.test:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * generic/tclUnicodeObj.c: added a new object type to store the
- unicode representation of a string.
-
- * generic/tclTestObj.c: added the objtype option to the testobj
- command. This option returns the name of the type of internal rep an
- object has.
-
-1999-06-04 Scott Stanton <stanton@scriptics.com>
-
- * win/configure.in:
- * win/Makefile.in: Windows build now handles static/dynamic
- debug/nodebug builds and supports the standard targets using Cygwin
- user tools plus GNU make and autoconf.
-
-1999-06-03 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * tests/string.test: Fixed bug where string equal/compare -nocase
- reported wrong result on null strings. [Bug 2138]
-
-1999-06-02 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclUtf.c (Tcl_UtfNcasecmp): Fixed incorrect computation of
- relative ordering. [Bug 2135]
-
-1999-06-01 Scott Stanton <stanton@scriptics.com>
-
- * unix/configure.in: Fixed various small configure.in patches
- submitted by Jan Nijtmans. [Bug 2121]
-
- * tests/reg.test:
- * generic/regc_color.c:
- * generic/regc_cvec.c:
- * generic/regc_lex.c:
- * generic/regc_locale.c:
- * generic/regc_nfa.c:
- * generic/regcomp.c:
- * generic/regcustom.h:
- * generic/rege_dfa.c:
- * generic/regerror.c:
- * generic/regerrs.h:
- * generic/regex.h:
- * generic/regexec.c:
- * generic/regfree.c:
- * generic/regfronts.c:
- * generic/regguts.h:
- * generic/tclCmdMZ.c:
- * generic/tclRegexp.c:
- * generic/tclRegexp.h:
- * generic/tclTest.c: Applied Henry Spencer's latest regexp patches
- that fix an infinite loop bug and add support for testing whether a
- string could match with additional input. [Bug 2117]
-
-1999-05-28 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclObj.c: Changed to eliminate use of isupper/tolower in
- favor of the Unicode versions.
-
- * win/Makefile.in:
- * win/configure.in: Added preliminary TEA implementation.
-
- * win/tclWinDde.c: Fixed bug where dde calls were being passed an
- invalid dde handle because Initialize had not been called. [Bug 2124]
-
-1999-05-26 Scott Redman <redman@scriptic.com>
-
- * generic/tclThreadTest.c: Fixed race condition in testthread code
- that showed up in the WinNT test suite intermittently.
-
- * win/tclWinSock.c: Fixed a hang in the WinNT socket driver, wake up
- the socket thread every 100ms to check for events on the sockets that
- did not wake up the thread (race condition).
-
-1999-05-24 Scott Stanton <stanton@scriptics.com>
-
- * tools/genStubs.tcl: Changed to allow a list of platforms instead of
- just one at a time.
-
- * generic/tcl.decls:
- * generic/tclCmdMZ.c:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclPort.h:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c: Various header file related changes and other
- lint to try to get the Mac builds working.
-
-1999-05-21 Scott Redman <redman@scriptics.com>
-
- * win/tclWinPipe.c: Fix bug when launching command.com on Win95/98.
- Need to wait for the procInfo.hProcess of the process that was
- created, not the hProcess of the current process. [Bug 2105]
-
-1999-05-20 Scott Redman <redman@scriptics.com>
-
- * library/init.tcl: Add the directory where the executable is, and the
- ../lib directory relative to that, to the auto_path variable.
-
-1999-05-19 Scott Stanton <stanton@scriptics.com>
-
- Merged in various changes submitted by Jeff Hobbs:
-
- * generic/tcl.decls:
- * generic/tclUtf.c: Added Tcl_UniCharIs* functions for control, graph,
- print, and punct classes.
-
- * generic/tclUtil.c:
- * doc/StrMatch.3: Added Tcl_StringCaseMatch() implementation to
- support case-insensitive globbing.
-
- * doc/string.n:
- * unix/mkLinks:
- * tests/string.test:
- * generic/tclCmdMZ.c: Added additional character class tests, added
- -nocase switch to "string match", changed string first/last to use
- offsets.
-
-1999-05-19 Scott Redman <redman@scriptics.com>
-
- * generic/tcl.h: Add extern "C" block around entire header file for
- C++ compilers to fix linkage issues. Submitted by Don Porter and Paul
- Duffin.
-
- * generic/tclRegexp.c: Fix bug when the regexp cache is empty and an
- empty pattern is used in regexp ( such as {} or "" ).
-
-1999-05-18 Scott Stanton <stanton@scriptics.com>
-
- * win/tclWinChan.c: Modified initialization code to avoid inherenting
- closed or invalid channels. If the standard input is anything other
- than a console, file, serial port, or pipe, then we fall back to the
- standard Tk window console.
-
-1999-05-14 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclCmdAH.c (Tcl_ForObjCmd): Fixed crash caused by failure to
- reset the result before evaluating the test expression.
-
-1999-05-14 Bryan Surles <surles@scriptics.com>
-
- * generic/tclBasic.c (Tcl_CreateInterp): Added introspection variable
- for threaded interps. If the interp was compiled with threads enabled,
- the tcl_platform(threaded) variable will exist.
-
-1999-05-14 Scott Redman <redman@scriptics.com>
-
- * generic/tclDate.c: Applied patch to fix 100-year and 400-year
- boundaries in leap year code, from Isaac Hollander. [Bug 2066]
-
-1999-05-13 Scott Stanton <stanton@scriptics.com>
-
- * unix/Makefile.in:
- * unix/tclAppInit.c: Minor cleanup related to Xt notifier.
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Tcl now looks for an
- encoding subfield in the LANG/LC_ALL variables in cases where the
- locale is not found in the locale table. Ensure that setlocale() is
- called at least once so X11 will initialize properly. Also, forces the
- LC_NUMERIC locale to be "C" so numeric processing in scripts is not
- affected by the current locale setting. [Bug 1989]
-
- * generic/tclRegexp.c: Increased per-thread regexp cache to 30 slots.
- This seems to be about the right number for larger applications like
- exmh. [Bug 1063]
-
-1999-05-12 Scott Stanton <stanton@scriptics.com>
-
- * doc/tclsh.1: Updated references to rc script names to accurately
- reflect the platform differences on Windows.
-
- * tests/regexp.test:
- * generic/tclInt.h:
- * generic/tclBasic.c:
- * generic/tclRegexp.h:
- * generic/tclRegexp.c: Replaced the per-interpreter regexp cache with
- a per-thread cache. Changed the Regexp object to take advantage of
- this extra cache. Added a reference count to the TclRegexp type so
- regexps can be shared by multiple objects. Removed the per-interp
- regexp cache from the interpreter. Now regexps can be used with no
- need for an interpreter. [Bug 1063]
-
- * win/tclWinInit.c (TclpSetVariables): Avoid calling GetUserName if
- the value can be determined from the USERNAME environment variable.
- GetUserName is very slow.
-
-1999-05-07 Scott Stanton <stanton@scriptics.com>
-
- * win/winDumpExts.c:
- * win/makefile.vc: Removed incorrect patch. [Bug 1998]
-
- * generic/tcl.decls: Replaced const with CONST.
-
- * generic/tclResult.c (Tcl_AppendResultVA):
- * generic/tclStringObj.c (Tcl_AppendStringsToObjVA): Fixed to copy
- arglist using memcpy instead of assignment so it works properly on
- OS/390. [Bug 1997]
-
- * generic/tclLoadNone.c: Updated to use current interfaces, added
- TclpUnloadFile. [Bug 2003]
-
- * win/winDumpExts.c:
- * win/makefile.vc: Changed to emit library name in defs file. [Bug
- 1998]
-
- * unix/configure.in: Added fix for OS/390. [Bug 1976]
-
-1999-05-06 Scott Stanton <stanton@scriptics.com>
-
- * tests/string.test:
- * generic/tclCmdMZ.c:
- * doc/string.n: Fixed bug in string equal/compare code when using
- -length option. Cleaned up docs a bit more.
-
- * tests/http.test: Unset "data" array before running tests to avoid
- failures due to previous tests.
-
- * doc/string.n:
- * tests/cmdIL.test:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/ioCmd.test:
- * tests/lindex.test:
- * tests/linsert.test:
- * tests/lrange.test:
- * tests/lreplace.test:
- * tests/string.test:
- * tests/cmdIL.test:
- * generic/tclUtil.c:
- * generic/tclCmdMZ.c: Replaced "string icompare/iequal" with -nocase
- and -length switches to "string compare/equal". Added a -nocase option
- to "string map". Changed index syntax to allow integer or
- end?-integer? instead of a full expression. This is much simpler with
- safeTcl scripts since it avoids double substitution issues.
-
- * doc/Utf.3:
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tclUtf.c:
- * generic/tcl.decls: Added Tcl_UtfNcmp and Tcl_UtfNcasecmp.
-
-1999-05-05 Scott Stanton <stanton@scriptics.com>
-
- * win/makefile.vc: Added encoding directory to install-libraries
- target.
-
-1999-05-03 Scott Stanton <stanton@scriptics.com>
-
- * doc/string.n:
- * tests/cmdMZ.test:
- * tests/string.test:
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Changed "string length" to
- avoid regenerating the string rep of a ByteArray object.
-
- * tests/cmdIL.test:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/lindex.test:
- * tests/linsert.test:
- * tests/lrange.test:
- * tests/lreplace.test:
- * tests/string.test:
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * generic/tclUtil.c (TclGetIntForIndex): Applied Jeff Hobbs's string
- patch which includes the following changes [Bug 1845]:
- - string compare now takes optional length arg (for strncmp behavior)
- - added string equal (just a few lines of code blended in with string
- compare)
- - added string icompare/iequal for case-insensitive comparisons
- - string index's index can now be ?end[+-]?expression
- I made this change in the private TclGetIntForIndex, which means
- that the list commands also benefit, as well as string range, et al.
- - added [string repeat string count]
- Repeats given string number of times
- - added string replace, string equiv to lreplace
- (quasi opposite of string range):
- string replace first last ?string?
- Example of use, replacing end of string with ... should the string
- be more than 16 chars long:
- string replace $string 16 end "..."
- This just returns the string len < 16, so it will only affect the
- long strings.
- - added optional first and last args to string to*
- This allows you to just affect certain regions of a string with the
- command (like just capping the first letter). I found the original
- totitle to be too draconian to be useful.
- - added [string map charMap string]
- where charMap is a {from to from to} list that equates to what one
- might get from [array get]. Each and can be multiple chars (or none
- at all). For Tcl/CGI users, this is a MAJOR speed booster.
-
- * generic/tclParse.c (Tcl_ParseCommand): Changed to avoid modifying
- eval'ed strings that are already null terminated. [Bug 1793]
-
- * tests/binary.test:
- * generic/tclBinary.c (DupByteArrayInternalRep): Fixed bug where type
- was not being set in duplicated object. [Bug 1975, 2047]
-
-1999-04-30 Scott Stanton <stanton@scriptics.com>
-
- * Changed version to 8.1.1.
-
-1999-04-30 Scott Stanton <stanton@scriptics.com>
-
- * Merged changes from 8.1.0 branch:
-
- * generic/tclParse.c: Fixed memory leak in CommandComplete.
-
- * generic/tclPlatDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntDecls.h:
- * generic/tclDecls.h:
- * tools/genStubs.tcl: Added 'extern "C" {}' block around the stub
- table pointer declaration so the stub library can be used from C++.
- [Bug 1934]
-
- * Lots of documentation and other release engineering fixes.
-
-1999-04-28 Scott Stanton <stanton@scriptics.com>
-
- * mac/tclMacResource.c:
- * generic/tclListObj.c:
- * generic/tclObj.c:
- * generic/tclStringObj.c: Changed to avoid freeing the string
- representation before freeing the internal rep. This helps with
- debugging since the string rep will still be valid when the free proc
- is invoked.
-
-1999-04-27 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclLiteral.c (TclHideLiteral): Fixed so hidden literals get
- duplicated to avoid accidental sharing in the global object table.
-
-1999-04-23 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclStubInit.c:
- * tools/genStubs.tcl: Changed to avoid the need for forward
- declarations in stub initializers.
-
-1999-04-23 Scott Stanton <stanton@scriptics.com>
-
- * library/encoding/koi8-r.enc:
- * tools/encoding/koi8-r.txt: Added support for the koi8-r Cyrillic
- encoding. [Bug 1771]
-
-1999-04-22 Scott Stanton <stanton@scriptics.com>
-
- * win/tclWinFCmd.c:
- * win/tclWin32Dll.c: Changed uses of "try" to "__try", since that is
- the actual keyword. This eliminates the need for some -D flags from
- the makefile.
-
- * generic/tclPort.h: Added include of tcl.h since it defines various
- Windows macros that are needed before deciding which platform porting
- file to use.
-
- * generic/tclEvent.c: lint
-
- * win/tclWinInit.c (TclpInitPlatform): Added call to TclWinInit when
- building a static library since DllMain will not be invoked. This
- could break old code that explicitly called TclWinInit, but should be
- simpler in the long run.
-
-1999-04-22 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclInt.h:
- * generic/tclInt.decls:
- * generic/tclCompile.c: Added TclSetByteCodeFromAny that takes a hook
- procedure to invoke after compilation but before the byte codes are
- emitted. This makes it possible to do postprocessing on the compiled
- byte codes before the ByteCode is generated.
-
- * generic/tclLiteral.c: Added TclHideLiteral and TclAddLiteralObj to
- make it possible to create local unshared literal objects.
-
- * win/tclWinInit.c:
- * unix/tclUnixInit.c: Changed initial search path to match that
- found used by tcl_findLibrary.
-
-1999-04-22 Scott Redman <redman@scriptics.com>
-
- * win/tclWinPort.h:
- * win/tclWinSock.c: Added code to use WinSock 2.0 API on NT to avoid
- creating a window to handle sockets. API not available on Win95 and
- needs to be fixed on Win98, until then continue to use the older
- (window-based) scheme on those two OSes.
-
-1999-04-15 Scott Stanton <stanton@scriptics.com>
-
- * Merged 8.1 back into the main trunk
-
-1999-04-13 Scott Stanton <stanton@scriptics.com>
-
- * library/encoding/gb2312.enc:
- * library/encoding/euc-cn.enc:
- * tools/encoding/gb2312.txt:
- * tools/encoding/cp950.txt:
- * tools/encoding/Makefile: Restored the double byte definition of
- GB2312 and added the EUC-CN encoding. EUC-CN is a variant of GB2312
- that shifts the characters into bytes with the high bit set and
- includes ASCII as a subset. [Bug 632]
-
-1999-04-13 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSock.c: Apply patch to allow write access to a socket if
- FD_WRITE is sent but FD_CONNECT is not. Some strange problem with
- either Win32 or a socket driver. [Bug 1664 1776]
-
-1999-04-09 Scott Redman <redman@scriptics.com>
-
- * unix/tclUnixNotfy.c: Fixed notifier deadlock situation when the pipe
- used to talk back notifier thread is filled with data. When calling
- the write() function to feed data down that pipe, unlock the
- notifierMutex to allow the notifier to wake up again. Found as a
- result of the focus.test for Tk hanging. [Bug 1700]
-
-1999-04-06 Scott Stanton <stanton@scriptics.com>
-
- * tests/unixNotfy.test: Fixed hang in tests when built with thread
- support.
-
- * tests/httpold.test: Fixed broken test that didn't wait long enough
- for events to arrive.
-
- * tests/unixInit.test: Fixed race condition in test.
-
- * tests/unixInit.test:
- * tests/fileName.test: Minor test nits.
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Fixed bad initial
- encoding string.
-
-1999-04-06 Bryan Surles <surles@scriptics.com>
-
- * generic/tclVar.c:
- * generic/tclEnv.c: Moved the "array set" C level code into a common
- routine (TclArraySet). The TclSetupEnv routine now uses this API to
- create an env array w/ no elements.
-
- * generic/tclEnv.c:
- * generic/tclWinInit.h:
- * generic/tclUnixInit.h:
- * generic/tclInt.h: Made the Env module I18N compliant. Changed the
- FindVariable routine to TclpFindVariable, that now does a case
- insensitive string comparison on Windows, and not on UNIX. [Bug 1299,
- 1500]
-
-1999-04-05 Scott Stanton <stanton@scriptics.com>
-
- * tests/io.test: Minor test cleanup.
-
- * generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make it
- easier to compile on Digital-unix. [Bug 1659]
-
- * unix/configure.in:
- * unix/tclUnixPort.h: Applied patch for OS/390 to handle lack of
- sys/param.h. [Bug 1725]
-
- * unix/configure.in: Fixed BSD/OS 4.* configuration to support shared
- libraries properly. [Bug 1730]
-
-1999-04-05 Scott Redman <redman@scriptics.com>
-
- * win/tclWinDde.c: decrease timeout value for DDE calls to 30k. [Bug
- 1639]
-
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclUtil.c: Added more functions to the Tcl stubs table,
- including all Tcl_ functions not already in it (except Cmd functions)
- and Tcl_GetCwd() and Tcl_Chdir() (new functions).
-
- * tests/safe.test:
- * doc/safe.n:
- * generic/tclBasic.c:
- * library/safe.tcl: The encoding command is not safe as-is, so create
- a safe alias to mask out the "encoding system <name>" but allow all
- other uses including "encoding system". Added test cases and updated
- the man page for Safe Tcl.
-
-1999-04-05 Scott Stanton <stanton@scriptics.com>
-
- * tests/winTime.test:
- * win/tclWinTime.c: Fixed crash in clock command that occurred when
- manipulating negative time values in timezones east of GMT. [Bug
- 1142, 1458]
-
- * tests/platform.test:
- * tests/fileName.test: Fixed broken tests.
-
- * generic/tclFileName.c: Moved global regexps into thread local
- storage.
-
- * tests/socket.test: Changed so tests don't reuse sockets, since
- Windows is slow to release sockets.
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c: Fixed race condition where background threads
- were terminated while they still held a lock in the notifier.
-
-1999-04-02 Scott Stanton <stanton@scriptics.com>
-
- * tests/http.test: Fixed bad test initialization code.
-
- * generic/tclThreadTest.c (ThreadExitProc): Fixed bug where static
- memory was being returned instead of a dynamically allocated result in
- error cases.
-
-1999-04-02 Scott Redman <redman@scriptics.com>
-
- * doc/dde.n:
- * tools/tcl.wse.in:
- * win/makefile.vc:
- * win/pkgIndex.tcl:
- * win/tclWinDde.c: Add new DDE package, code removed from Tk now
- separated into its own package. Changed DDE-based send code into "dde
- eval" command. Can be loaded into tclsh (not just wish). Windows only.
-
-1999-04-02 Scott Stanton <stanton@scriptics.com>
-
- * tests/expr.test:
- * tests/for-old.test:
- * tests/for.test:
- * tests/foreach.test:
- * tests/format.test:
- * tests/httpold.test:
- * tests/if.test:
- * tests/init.test:
- * tests/interp.test:
- * tests/while.test: Added some tests for known bugs (marked with
- knownBug constraint), and cleaned up a few bad tests.
-
- * generic/regc_locale.c:
- * generic/regcustom.h:
- * generic/tcl.decls:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclInt.h:
- * generic/tclRegexp.c:
- * generic/tclScan.c:
- * generic/tclTest.c:
- * generic/tclUtf.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c: Made various Unicode utility functions public. The
- following functions were made public and added to the stubs table:
- Tcl_UtfToUniCharDString, Tcl_UniCharToUtfDString,
- Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharIsAlnum,
- Tcl_UniCharIsAlpha, Tcl_UniCharIsDigit, Tcl_UniCharIsLower,
- Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar
-
-1999-04-01 Scott Stanton <stanton@scriptics.com>
-
- * tests/registry.test:
- * win/tclWinReg.c: Internationalized the registry code. It now uses
- Unicode interfaces on NT. [Bug 1197]
-
- * tests/parse.test:
- * generic/tclParse.c: Fixed crash due to multiple frees in parser
- during error cleanup when parsing commands with more tokens than will
- fit in the static area of the parse structure. [Bug 1681]
-
- * generic/tclInt.h: Removed duplicate declarations.
-
- * generic/tclInt.decls:
- * generic/tcl.decls: Added Tcl_WinUtfToTChar and Tcl_WinTCharToUtf to
- the tclPlat table.
-
-1999-04-01 Scott Redman <redman@scriptics.com>
-
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/StubInit.c:
- * tools/genStubs.tcl:
- * unix/Makefile.in:
- * win/makefile.vc: Applied patch from Jan Nijtmans to fix Ultrix
- multiple symbol definition problem. Now, even Tcl includes a copy of
- the Tcl stub library. Also fixed TCL_MEM_DEBUG mode (for Tk).
-
-1999-03-31 Scott Redman <redman@scriptics.com>
-
- * win/tclWinConsole.c: WinNT has a bug when reading a single character
- from the console. Rewrote the code for the console to read an entire
- line at a time using the reader thread.
-
-1999-03-30 Scott Stanton <stanton@scriptics.com>
-
- * unix/Makefile.in: Removed trailing backslash that broke the "depend"
- target.
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Changed to avoid
- calling setlocale(). We now look directly at env(LANG) and
- env(LC_CTYPE) instead. [Bug 1636]
-
- * generic/tclFileName.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: Removed CONST from Tcl_JoinPath and
- Tcl_TranslateFileName because it changes the signature of Tcl_JoinPath
- in an incompatible manner.
-
- * generic/tclInt.h:
- * generic/tclLoad.c (TclFinalizeLoad):
- * generic/tclEvent.c (Tcl_Finalize): Defer unloading of loadable
- modules until all exit handlers have been invoked. [Bug 998, 1273,
- 1573, 1593]
-
-1999-03-29 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclFileName.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: Added CONST to Tcl_JoinPath and
- Tcl_TranslateFileName.
-
-1999-03-29 Scott Redman <redman@scriptics.com>
-
- * tools/genStubs.tcl:
- * unix/configure.in:
- * unix/Makefile.in:
- * win/makefile.vc:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/tclIntDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclIntPlatDecls.h: Removed the stub functions and changed
- the stub macros to just use the name without params. Pass &tclStubs
- into the interp (don't use tclStubsPtr because of collisions with the
- stubs on Solaris).
-
-1999-03-27 Scott Redman <redman@scriptics.com>
-
- * win/makefile.bc: Removed makefile for Borland compiler, no longer
- supported.
-
-1999-03-26 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSerial.c:
- * win/tclWinConsole.c:
- * win/tclWinPipe.c: Don't close the Win32 handle for a channel if it's
- a stdio handle (GetStdHandle()) during shutdown of a thread to prevent
- it from destroying the stdio of other threads.
-
-1999-03-26 Suresh Ankolekar <suresh@scriptics.com>
-
- * unix/configure.in: --nameble-shared is now the default and build Tcl
- as a shared library; specify --disable-shared to build a static Tcl
- library and shell.
-
-1999-03-25 Scott Stanton <stanton@scriptics.com>
-
- * tests/interp.test:
- * generic/tclInterp.c (AliasObjCmd): Changed so aliases are invoked at
- current scope in the target interpreter instead of at the global
- scope. This was an incompatibility introduced in 8.1 that is being
- removed. [Bug 1153, 1556]
-
- * library/encoding/big5.enc:
- * library/encoding/gb2312.enc:
- * tools/encoding/big5.enc:
- * tools/encoding/gb2312.enc: Added ASCII to big5 and gb2312 encodings.
- [Bug 632]
-
- * generic/tclPkg.c (Tcl_PkgRequireEx): Fixed broken clientData
- initialization in package code.
-
- * unix/Makefile.in (dist): Added tcl.decls and tclInt.decls to source
- distribution. [Bug 1571]
-
- * doc/Thread.3: Updated documentation of Tcl_MutexLock to indicate
- that the recursive locking behavior is undefined. On Windows, it does
- not block, on Unix it deadlocks. [Bug 1275]
-
-1999-03-24 Scott Stanton <stanton@scriptics.com>
-
- * tests/execute.test:
- * generic/tclExecute.c (TclExecuteByteCode): Fixed expression code
- that incorrectly returned floating point values for integers if the
- internal rep happened to be a double. Now we check to see if the
- object has a string rep that looks like an integer before using the
- double internal rep. [Bug 1516]
-
-1999-03-24 Scott Redman <redman@scriptics.com>
-
- * generic/tclAlloc.c:
- * generic/tclEncoding.c:
- * generic/tclProc.c:
- * unix/tclUnixTime.c:
- * win/tclWinSerial.c: Fixed compilation warnings/errors for VC++ 5.0
- and 6.0 and HP-UX native compiler without -Aa or -Ae. [Bug 1323 1518
- 1324 1583 1585 1586]
-
- * win/tclWinSock.c: Make sockets thread-safe on Windows. The current
- implementation uses windows to handle events on the socket, one for
- each thread (thread local storage). Previously, there was only one
- window shared between threads, which didn't work. [Bug 1326]
-
-1999-03-23 Scott Stanton <stanton@scriptics.com>
-
- * tools/tcl.wse: Fixed file association to look in the right place for
- the wish icon. [Bug 1544]
-
- * tests/winNotify.test:
- * tests/ioCmd.test:
- * tests/event.test: Changed to use new style conditionals.
-
- * tests/encoding.test: Fixed nonportable test.
-
- * unix/dltest/configure.in:
- * unix/dltest/Makefile.in: Added missing DBGX macros. [Bug 1564]
-
- * tests/winNotify.test:
- * mac/tclMacNotify.c:
- * win/tclWinNotify.c:
- * unix/tclUnixNotfy.c:
- * generic/tclNotify.c: Added a new Tcl_ServiceModeHook interface that
- is invoked whenever the service mode changes. This is needed to allow
- the Windows notifier to create a communication window the first time
- Tcl is about to enter an external modal event loop instead of at
- startup time. This will avoid the various problems that people have
- been seeing where the system hangs when tclsh is running outside of
- the event loop. [Bug 783]
-
- * generic/tclInt.h:
- * generic/tcl.decls: Renamed TclpAlertNotifier back to
- Tcl_AlertNotifier since it is part of the public notifier driver API.
-
-1999-03-23 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSerial.c: Fixed problem with fileevent on the serial port
- and nonblocking mode. Gets no longer hangs, fileevents fire whenever
- there is any character data on the port.
-
- * tests/winConsole.test:
- * win/tclWinConsole.c: Fixed problem with fileevents and gets from a
- console stdin. Previously, fileevents were firing before an entire
- line was available for reading, which meant that when you did a gets
- or read, it blocked (even in nonblocking mode). Now, it should work
- the same as Unix: fileevents fire when an entire line is ready, and
- gets and read do not block in non-blocking mode. Added an interactive
- test case to check for this.
-
-1999-03-22 Scott Stanton <stanton@scriptics.com>
-
- * tests/reg.test:
- * generic/regc_color.c: Applied regexp bug fix from Henry Spencer.
-
-1999-03-19 Scott Redman <redman@scriptics.com>
-
- * generic/tclCmdIL.c: Fixed the initialization of an array so that the
- Sun 5.0 C compiler wouldn't complain.
-
- * unix/configure.in: Added support for --enable-64bit. For now, this
- is only supported on Solaris 7 64bit (SunOS 5.7) using the Sun
- compiler (not gcc).
-
-1999-03-18 Scott Stanton <stanton@scriptics.com>
-
- * win/tclWinChan.c (TclpOpenFileChannel, Tcl_MakeFileChannel): Changed
- to only test for console or comm handles when the type is
- FILE_TYPE_CHAR to avoid useless tests on simple files. Also reordered
- tests so consoles are tested first as this is more common.
-
- * win/makefile.vc: Regularized usage of mkd and rmd and rm.
-
- * library/encoding/shiftjis.enc:
- * tools/encoding/shiftjis.txt: Missing/incorrect characters in
- shift-jis table. [Bug 1008, 1526]
-
- * generic/tclInt.decls:
- * generic/tcl.decls: Eliminated use of "string" and "list" from
- argument lists to avoid conflicts with C++ STL. [Bug 1181]
-
- * win/tclWinFile.c (TclpMatchFiles): Changed to ignore the
- FS_CASE_IS_PRESERVED bit and always return exactly what we get from
- the system.
-
-1999-03-17 Scott Stanton <stanton@GASPODE>
-
- * win/README.binary:
- * win/README:
- * unix/configure.in:
- * generic/tcl.h:
- * README: Updated version to 8.1b3.
-
-1999-03-14 Scott Stanton <stanton@GASPODE>
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c: Changed so channel drivers wait for the
- reader/writer threads to exit before returning during a close
- operation. This ensures that the main thread is the last thread to
- exit, so the process return value is set properly.
-
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntPlatStubs.c:
- * generic/tclIntStubs.c:
- * generic/tclPlatDecls.h:
- * generic/tclPlatStubs.c:
- * generic/tclStubInit.c:
- * generic/tclStubs.c: Fixed bad eol characters.
-
- * generic/tclInt.decls: Changed "const" to "CONST" in declarations for
- better portability.
-
- * generic/tcl.decls: Renamed panic and panicVA to Tcl_Panic and
- Tcl_PanicVA in the stub files.
-
- * generic/tclInterp.c (Tcl_MakeSafe): Remove tcl_platform(user) from
- safe interps.
-
-1999-03-11 Scott Stanton <stanton@GASPODE>
-
- * unix/Makefile.in:
- * unix/configure.in: Include compat files in the stub library in
- addition to the main library. Compat files are now built for dynamic
- use in all cases.
-
- * generic/tcl.h: Changed magic number so it doesn't match the plus
- patch, at Jan's request.
-
- * unix/tclConfig.sh.in:
- * unix/dltest/Makefile.in:
- * unix/dltest/configure.in:
- * unix/dltest/pkga.c:
- * unix/dltest/pkgb.c:
- * unix/dltest/pkgc.c:
- * unix/dltest/pkgd.c:
- * unix/dltest/pkge.c:
- * unix/dltest/pkgf.c: Changed package tests to build against the stubs
- library.
-
-1999-03-10 Scott Stanton <stanton@GASPODE>
-
- * generic/tcl.h:
- * generic/tcl.decls: Changed Tcl_ReleaseType from an enum to macros so
- it can be used in .rc files. Added Tcl_GetString.
-
- * mac/tclMacNotify.c:
- * generic/tclNotify.c:
- * generic/tclInt.h:
- * win/tclWinNotify.c:
- * generic/tcl.h: Renamed Tcl_AlertNotifier to TclpAlertNotifier.
-
- * generic/tclInt.decls: Added TclWinAddProcess to make it possible for
- expect to use Tcl_WaitForPid(). This patch is from Gordon Chaffee.
-
- * mac/tclMacPort.h:
- * win/tclWinInit.c:
- * unix/tclUnixPort.h:
- * generic/tclAsync.c: Added TclpAsyncMark to fix bug in async handling
- on Windows where async events don't wake up the event loop. This patch
- comes from Gordon Chaffee.
-
- * generic/tcl.decls: Fixed declarations of reserved slots.
-
-1999-03-10 Scott Redman <redman@scriptic.com>
-
- * generic/tclCompile.h: Ensure that the ByteCode struct is binary
- compatible with the version in 8.0.6.
-
- * generic/tcl.h:
- * generic/tclBasic.c: Add Tcl_GetVersion() function to the public C
- API to allow programs to check the version number of the Tcl library
- at runtime. Also added an enum to clarify the release level (alpha,
- beta, final).
-
-1999-03-09 Scott Stanton <stanton@GASPODE>
-
- * Integrated changes from Tcl 8.0 including:
- stubs mechanism
- configure patches from Jan Nijtmans
- rename of panic to Tcl_Panic
-
-1999-03-08 Lee Bernhard <lfb@scriptics.com>
-
- * win/tclWin32Dll.c: Removed Dll instance from thread-local storage.
-
-1999-03-08 Scott Stanton <stanton@GASPODE>
-
- * generic/tcl.h: Moved Tcl_Mutex, etc. macros above the inclusion of
- tclDecls.h to avoid macro conflicts.
-
- * generic/tclInt.h:
- * generic/regc_color.c:
- * generic/regcomp.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdAH.c:
- * generic/tclIOCmd.c:
- * generic/tclParse.c:
- * generic/tclStringObj.c:
- * unix/tclUnixNotfy.c: Cleaned up various compiler warnings,
- eliminated UCHAR bugs.
-
- * unix/tclUnixNotfy.c:
- * unix/tclUnixThrd.c:
- * generic/tclThreadTest.c:
- * mac/tclMacThrd.c: Changed TclpCondition*() to Tcl_Condition*().
-
- * INTEGRATED PATCHES FROM 8.0.6:
-
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntPlatStubs.c:
- * generic/tclIntStubs.c:
- * generic/tclPlatDecls.h:
- * generic/tclPlatStubs.c:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c:
- * generic/tclStubs.c:
- * tools/genStubs.tcl:
- * unix/configure.in:
- * unix/Makefile.in:
- * unix/tclConfig.sh.in:
- * win/makefile.vc:
- * win/tclWinPort.h: Added Tcl stubs implementation. There are now two
- new macros USE_TCL_STUBS and USE_TCL_STUB_PROCS that enable use of
- stubs and disable stub macros respectively. All of the public and
- private function declarations from tcl.h and tclInt.h have moved into
- the *.decls files and the *Stubs.c and *Decls.h files are generated
- using the genStubs.tcl script.
-
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/ldAix: Enhanced AIX shared library support.
-
- * win/tclWinSock.c: Removed a bunch of extraneous PASCAL FAR
- attributes from internal functions.
-
- * win/tclWinReg.c: Changed registry package to use stubs mechanism so
- it no longer depends on the specific version of Tcl.
-
- * doc/AddErrInfo.3:
- * doc/Eval.3:
- * doc/PkgRequire.3:
- * doc/SetResult.3:
- * doc/StringObj.3:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclPanic.c:
- * generic/tclStringObj.c:
- * generic/tclUtil.c:
- * unix/mkLinks: Added va_list versions of all VARARGS functions so
- they can be invoked from the stub functions.
-
- * doc/package.n:
- * doc/PkgRequire.3:
- * generic/tclPkg.c: Added Tcl_PkgProvideEx, Tcl_RequireEx,
- Tcl_PresentEx, and Tcl_PkgPresent. Added "package present" command.
-
- * generic/tclFileName.c:
- * mac/tclMacFile.c:
- * mac/tclMacShLib.exp:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: Changed so TclGetUserHome is defined on all
- platforms, even though it is currently a noop on mac and windows, and
- renamed it to TclpGetUserHome.
-
- * generic/tclPanic.c:
- * generic/panic.c: Renamed panic to Tcl_Panic.
-
-1999-02-25 Scott Redman <redman@scriptics.com>
-
- * win/makefile.vc: Added tclWinConsole.c and tclWinSerial.c
-
- * win/tclWinConsole.c: New code to properly deal with fileevents and
- nonblocking mode on consoles.
-
- * win/tclWinSerial.c: New code to properly deal with fileevents and
- nonblocking mode on serial ports.
-
- * win/tclWinPipe.c:
- * win/tclWinPort.h: Exported functions to allow creation of pipe
- channels from tclWinChan.c
-
- * win/tclWinChan.c: Check the type of a channel, including for the
- standard (stdin/stdout/stderr), and use the correct channel type to
- create the channel (file, serial, console, or pipe).
-
-1999-02-11 Scott Stanton <stanton@GASPODE>
-
- * README:
- * generic/tcl.h:
- * win/README.binary:
- * win/README:
- * unix/configure.in:
- * mac/README: Updated version numbers to 8.1b2.
-
-1999-02-10 Scott Stanton <stanton@GASPODE>
-
- * library/auto.tcl: Fixed auto_mkindex so it handles .tbc files. Did
- some general cleanup to handle bad eval statements that didn't use
- "list".
-
- * unix/mkLinks:
- * doc/SetVar.3:
- * generic/tcl.h:
- * generic/tclVar.c: Restored Tcl_ObjGetVar2 and Tcl_ObjSetVar2 from
- 8.0. Renamed Tcl_Get/SetObjVar2 to Tcl_GetVar2Ex and Tcl_SetVar2Ex.
-
-1999-02-10 Scott Stanton <stanton@GASPODE>
-
- INTEGRATED PATCHES FROM 8.0.5b2:
-
- * test/winPipe.test: Changed to remove echoArgs.tcl temporary file
- when done.
-
- * tests/cmdAH.test:
- * generic/tclFileName.c (TclGetExtension): Changed behavior so the
- split happens at the last period in the name instead of the first
- period of the last run of periods. So, "foo..o" is split into "foo."
- and ".o" now. [Bug 1126]
-
- * win/makefile.vc: Added better support for paths with spaces in the
- name. Added .lib and support .dlls to the install-binaries target.
- Added generate of a pkgIndex.tcl script to the install-libraries
- target.
-
- * win/tclAppInit.c:
- * unix/tclAppInit.c:
- * mac/tclMacAppInit.c:
- * generic/tclTest.c: Changed some EXTERN declarations to extern since
- they are not defining exported interfaces. This avoids generating
- useless declspec() attributes and makes the windows makefile simpler.
-
- * generic/tcl.h: Moved Tcl_AppInit declaration to end and cleared out
- TCL_STORAGE_CLASS so it is not declared with a declspec().
-
- * tests/interp.test:
- * generic/tclInterp.c (DeleteAlias): Changed to use
- Tcl_DeleteCommandFromToken so we handle renames properly. This avoids
- senseless panic. [Bug 736]
-
- * unix/tclUnixChan.c:
- * win/tclWinSock.c:
- * doc/socket.n: Applied Gordon Chaffee's patch to handle failures
- during asynchronous socket connection operations. This adds a new
- "-error" fconfgure option to socket channels. [Bug 893]
-
- * generic/tclProc.c:
- * generic/tclNamesp.c:
- * generic/tclInt.h:
- * generic/tclCmdIL.c:
- * generic/tclBasic.c:
- * generic/tclVar.c: Applied patch from Viktor Dukhovni to rationalize
- TCL_LEAVE_ERR_MSG behavior when creating variables.
-
- * generic/tclVar.c: Fixed bug in namespace tail computation. Fixed bug
- where upvar could resurrect a namespace variable whose namespace had
- been deleted.
-
- * generic/tclCompile.c (TclCompileExprCmd): Eliminated yet another
- bogus optimization in expression compilation.
-
- * unix/configure.in: Added branch for BSD/OS-4* to shared library case
- statement. [Bug 975]
- Fixed to correctly handle IRIX 6.5 n32 library support. [Bug 1117]
-
- * win/winDumpExts.c: Patched to be pickier about stripping @'s. [Bug
- 920]
-
- * library/http2.0/http.tcl: Added catch around eof test in CopyDone
- since the user may have already called http::reset. [Bug 1108]
-
- * unix/configure.in: Changed Linux and IRIX to set SHLIB_LIBS to LIBS
- so shared libraries are linked with the system libraries. [Bug 1018]
-
- * generic/tclCompile.c (CompileExprWord): Fixed exception stack
- overflow bug caused by missing statement. [Bug 928]
-
- * generic/tclIOCmd.c:
- * generic/tclBasic.c: Objectified the "open" command. [Bug 1113]
-
- * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): When using egcs,
- ENOTSUP and EOPNOTSUPP are the same, so now we handle that case. [Bug
- 1137]
-
- * library/init.tcl: Various small changes requested by Jan Nijtmans.
- - If the variable $tcl_library contains the empty string, this empty
- string will be put in $auto_path. This is not useful at all, it only
- slows down later package processing.
- - If the variable tcl_pkgPath is not set, the "unset __dir" fails.
- Thich makes init.tcl totally unusable. Better put a "catch" around
- it.
- - In the function tcl_findLibraries, the "string match" function only
- works correctly if $tcl_patchLevel is in one of the forms "?.?a?",
- "?.?b?" or "?.?.?". Could a "regexp" be used instead, then it allows
- anything to be appended to the patchLevel string. And it is more
- efficient.
- - The tclPkgSetup function assumes that if $type != "load" then the
- type must be "source". This needn't be true. Some users want to add
- their own setup types.
- [RFE 1138] [Bug 978]
-
- * win/tclWinReg.c:
- * doc/registry.n: Added support for HKEY_PERFORMANCE_DATA and
- HKEY_DYN_DATA keys. [Bug 1109]
-
- * win/tclWinInit.c (TclPlatformInit): Added code to ensure tcl_pkgPath
- is set to "" when no registry entry is found. [Bug 978]
-
-1999-02-01 Scott Stanton <stanton@GASPODE>
-
- * generic/tclBasic.c:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclExecute.c:
- * generic/tclHistory.c:
- * generic/tclIO.c:
- * generic/tclIOUtil.c:
- * generic/tclInterp.c:
- * generic/tclMain.c:
- * generic/tclNamesp.c:
- * generic/tclParse.c:
- * generic/tclProc.c:
- * generic/tclTest.c:
- * generic/tclTimer.c:
- * generic/tcl.h: Made eval interfaces compatible with 8.0 by renaming
- Tcl_EvalObj to Tcl_EvalObjEx, renaming Tcl_Eval2 to Tcl_EvalEx and
- restoring Tcl_EvalObj and Tcl_GlobalEvalObj interfaces so they match
- Tcl 8.0.
-
-1999-01-28 Scott Stanton <stanton@GASPODE>
-
- * Merged Tcl 8.0.5b1 changes.
-
- * generic/tclUtil.c (Tcl_DStringSetLength): Changed so the buffer
- overallocates in a manner similar to Tcl_DStringAppend. This should
- improve performance for TclUniCharToUtfDString.
-
-1998-12-11 === Tcl 8.1b1 Release ===
-
-1998-12-10 Scott Stanton <stanton@GASPODE>
-
- * Fixed lots of files that used TCL_THREAD instead of TCL_THREADS.
-
- * generic/tclEncoding.c (Tcl_FreeEncoding): Moved most of the code
- into a static FreeEncoding routine that does not grab the
- encodingMutex to avoid deadlocks/races when called from other routines
- that already have the mutex.
-
-1998-12-09 Scott Stanton <stanton@GASPODE>
-
- * library/msgcat1.0/msgcat.tcl: Fixed bad export list, fixed so all
- locale strings are converted to lower case, including file names.
-
- * generic/regcomp.c (makescan): Fixed bug in longest match case that
- caused anchored patterns to fail. [Bug 897]
-
-1998-12-08 Scott Stanton <stanton@GASPODE>
-
- * library/msgcat1.0/msgcat.tcl: changed mc to invoke mcunknown in the
- calling context, changed locale lookups to be case insensitive
-
-1998-12-07 Scott Stanton <stanton@GASPODE>
-
- * generic/tclAlloc.c (TclpRealloc): Fixed a memory allocation bug
- where big blocks that were reallocated into a different heap location
- were not being placed into the bigBlocks list. [Bug 933]
-
- * tests/msgcat.test: Added message catalog test suite.
-
- * library/msgcat1.0/msgcat.tcl: minor bug fixes, integrated latest
- changes from Mark Harrison.
-
-1998-12-04 Scott Stanton <stanton@GASPODE>
-
- * library/msgcat1.0/msgcat.tcl: Changed code to conform to Tcl coding
- standards. Changed to use file join for portability.
-
- * library/msgcat1.0: Added initial implementaion of Tcl message
- catalog package contributed by Mark Harrison.
-
-1998-12-03 Scott Stanton <stanton@GASPODE>
-
- * win/tclWinPipe.c (BuildCommandLine): Fixed bug that kept arguments
- containing spaces from being properly quoted.
-
- * tests/defs: Changed so auto_path is set to only contain the Tcl
- library directory. This keeps the tests from accidentally picking up
- stuff in installed packages.
-
- * generic/tclUtil.c (Tcl_StringMatch): Changed to match 8.0 behavior
- in corner case where there is no closing bracket.
-
-1998-12-02 Scott Stanton <stanton@GASPODE>
-
- * win/tclWinPipe.c (TclpCreateCommandChannel): Changed reader/writer
- threads to have THREAD_PRIORITY_HIGHEST so they will have a chance to
- run whenever there is something to do.
-
- * generic/tclIO.c (WriteBytes, WriteChars): Fixed so extraneous
- flushes do not happen in line mode.
- (TranslateOutputEOL): Made translation more efficient in line mode and
- fixed a buffer overflow bug in CRLF translation. [Bug 887]
-
-1998-12-02 Brent Welch <welch@SAGE>
-
- * Updated patchlevel to 8.1b1
-
-1998-12-02 Scott Stanton <stanton@GASPODE>
-
- * generic/regc_color.c (subcolor): Added check for error case to avoid
- an out of bounds array reference.
-
- * generic/tclCmdAH.c (Tcl_EncodingObjCmd): Changed to avoid using
- Tcl_DStringResult because it is not binary clean.
-
- * generic/tclParse.c (Tcl_ParseCommand): Fixed bug in comment parsing
- where a trailing comment looked like an incomplete command.
-
-1998-12-02 Brent Welch <welch@SAGE>
-
- * Merged changes from 8.0.4, especially the new pkg_mkIndex
-
-1998-12-01 Scott Stanton <stanton@GASPODE>
-
- * generic/tclIO.c (Tcl_ReadChars): Added a call to UpdateInterest so
- we don't block when there is data sitting in the buffers.
-
- * generic/tclTest.c (TestevalobjvObjCmd): Updated for EvalObjv change.
-
- * tests/parse.test: Updated tests for EvalObjv change.
-
- * generic/tclParse.c (EvalObjv, Tcl_EvalObjv): Changed Tcl_EvalObjv
- interface to remove string and length arguments, preserved original
- interface as EvalObjv for internal use.
-
- * generic/tcl.h: Changed Tcl_EvalObjv interface to remove string and
- length arguments.
-
- * doc/Eval.3: Updated documentation for Tcl_EvalObjv to remove string
- and length arguments.
-
- * generic/tclCompCmds.c (TclCompileForeachCmd): Fixed code that
- corrupted the exceptDepth value in the compile environment when
- foreach failed to compile inline. [Bug 884]
-
- * library/encoding/euc-kr.enc:
- * library/encoding/ksc5601.enc:
- * tools/encoding/ksc5601.txt:
- * unix/tclUnixInit.c: Added support for Korean EUC.
-
- * win/tclWinChan.c (TclpGetDefaultStdChannel): added check for a
- failure during Tcl_MakeFileChannel.
-
-1998-11-30 Scott Stanton <stanton@GASPODE>
-
- * unix/tclUnixNotfy.c (Tcl_WaitForEvent): Fixed hang that occurs when
- trying to close a pipe that is currently being waited on by the
- notifier thread. [Bug 607]
-
- * unix/tclUnixFCmd.c (GetPermissionsAttribute): Increase size of
- returnString buffer to avoid overflow. [Bug 584]
-
- * generic/tclThreadTest.c (TclThreadSend): Fixed memory leak due to
- use of TCL_VOLATILE instead of TCL_DYNAMIC.
-
- * generic/tclThread.c (TclRememberSyncObject): Fixed memory leak
- caused by failure to reuse condition variables.
-
- * unix/tclUnixNotfy.c (Tcl_AlertNotifier, Tcl_WaitForEvent,
- (NotifierThreadProc, Tcl_InitNotifier): Fixed race condition caused by
- incorrect use of condition variables when sending messages between
- threads. [Bug 607]
-
- * generic/tclTestObj.c (TeststringobjCmd): MAX_STRINGS was off by one
- so the strings array was too small.
-
- * generic/tclCkalloc.c (Tcl_DbCkfree): Moved mutex lock so
- ValidateMemory is done inside the mutex to avoid a race condition when
- validate_memory is enabled. [Bug 880]
-
-1998-11-23 Scott Stanton <stanton@GASPODE>
-
- * regexec.c: more performance tuning from Henry Spencer.
-
-1998-11-17 Scott Stanton <stanton@GASPODE>
-
- * tclScan.c: moved "scan" implementation out of tclCmdMZ.c and added
- Unicode support. This required a complete reimplementation of the
- command to avoid using scanf(), which isn't Unicode aware. Two new
- features were added in the process: %n to return the current number of
- characters consumed, and XPG3-style %n$ argument order specifiers
- similar to those provided by the "format" command. [Bug 833]
-
- * tclAlloc.c: changed so allocated memory is always 8-byte aligned to
- improve memory performance and to ensure that it will work on systems
- that don't like accessing 4-byte aligned values (e.g. Solaris and
- HP-UX). [Bug 834]
-
-1998-11-06 Scott Stanton <stanton@GASPODE>
-
- * tclVar.c (TclGetIndexedScalar): Fixed bug 796, var name was getting
- lost before being passed to CallTraces.
-
-1998-10-21 Scott Stanton <stanton@GASPODE>
-
- * added "encoding" command
-
- * Moved internal regexp declarations from tclInt.h to tclRegexp.h
-
- * integrated regexp updates from Henry Spencer
-
-1998-10-15 Scott Stanton <stanton@GASPODE>
-
- * tclUtf.c: added Unicode character table support
-
- * tclInt.h: added TclUniCharIsWordChar
-
- * tclCmdMZ.c (Tcl_StringObjCmd): added "totitle" subcommand, changed
- "wordend" and "wordstart" to properly handle Unicode word characters
- and connector punctuation
-
-1998-10-05 Scott Stanton <stanton@GASPODE>
-
- * auto.tcl, package.tcl: fixed SCCS strings
-
- * tclIndex: updated index to reflect 8.1 files
-
- * tclCompile.c (TclCompileScript): changed to avoid modifying the
- input string in place because name lookup operations could have
- arbitrary side effects
-
- * tclInterp.c: added guard against deleting current interpreter
-
- * tclMacFile.c, tclUnixFile.c, tclWinFile.c, tclFileName.c: added
- warnings around code that modifies strings in place
-
- * tclExecute.c: fixed off-by-one copying error, fixed merge bugs
-
- * tclEvent.c: changed so USE_TCLALLOC is tested for value instead of
- definition
-
- * tclCompCmds.c: replaced SCCS strings, added warnings around code
- that modifies strings in place
-
- * interp.test: added test for interp deleting itself
-
-1998-09-30 Scott Stanton <stanton@GASPODE>
-
- * makefile.vc: fixed so TCL_LIBRARY is set before running tcltest
-
- * tclWin32Dll.c: removed TclpFinalize, cleanup of merges
diff --git a/ChangeLog.2000 b/ChangeLog.2000
deleted file mode 100644
index e22dff9..0000000
--- a/ChangeLog.2000
+++ /dev/null
@@ -1,2539 +0,0 @@
-2000-12-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c:
- * tests/expr-old.test: Re-wrote Tcl's [expr rand()] and [expr
- srand($seed)] implementations, fixing a range error on some 64-bit
- platforms. Added tests that detect the bug. The rewrite changes the
- seed -> sequence map on 64-bit platforms, only for seed >= 2^31, a
- slight incompatibility. [Bug 121072, Patch 102781]
-
-2000-12-10 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl:
- * library/msgcat/msgcat.tcl:
- * library/msgcat/pkgIndex.tcl:
- * library/opt/optparse.tcl:
- * library/opt/pkgIndex.tcl: Where [uplevel] is used in a proc to
- evaluate a Tcl built-in command in the caller's context, the built-in
- commands are now fully namespace-qualified. This prevents problems
- when the caller context is in a namespace where the built-in command
- name has been used by a command in the namespace. (For example,
- [::ns::set] might be called instead of the intended [::set]). [Bug
- 119422, Patch 102545]
-
-2000-12-09 Jeff Hobbs <jhobbs@interwoven.com>
-
- * win/tclWinTime.c (CalibrationThread): added lint return value to
- prevent compiler warning. [Bug 125005]
-
- * docs/scan.n:
- * tests/scan.test:
- * generic/tclScan.c (Tcl_ScanObjCmd): changed %o and %x to use strtoul
- instead of strtol to correctly preserve scan<>format conversion of
- large integers. [Patch 102663, Bug 124600]
-
- * generic/tclExecute.c (TclExecuteByteCode): Commited patch fixing
- handling of {!<boolean>} in expressions. [Patch 102702]
-
-2000-12-08 Jeff Hobbs <jhobbs@interwoven.com>
-
- * library/init.tcl: Added support for PATHEXT variable in auto_execok,
- recognizing the proper set of executable extensions on Windows. [Patch
- 102719]
-
-2000-12-08 Andreas Kupries <a.kupries@westend.com>
-
- * generic/tclEncoding.c (LoadTableEncoding): Changed dangerous code to
- something less critical. This fixes [Bug 119417], part A without
- affecting the speed when loading encodings.
-
-2000-12-08 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/open.n: Added xref to fconfigure and advice on the opening of
- binary files. Should help prevent a recurrence of bugs like [Bug
- 124558]
-
-2000-12-07 Jeff Hobbs <jhobbs@interwoven.com>
-
- * generic/tcl.h: added note about need to updated
- library/dde/pkgIndex.tcl with minor version increment.
-
- * library/dde/pkgIndex.tcl: updated to use 84 version to reflect the
- makefile. Should probably be updated to use its real version at some
- point. [Patch 102560, Bug 119421]
-
-2000-12-06 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tcl.h (attemptckalloc): Fixed typo for #define of
- attemptckalloc (was defined to Tcl_AttempDbCkalloc, should have been
- Tcl_AttemptDbCkalloc). [Bug 124384]
-
- * generic/tclCkalloc.c: Added TCL_MEM_DEBUG versions of
- Tcl_AttemptDbCkrealloc and Tcl_AttemptDbCkalloc. [Bug 124384].
-
-2000-11-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Logical negation "!" can
- now handle string booleans, provided those values are placed in
- variables.
-
- * tests/expr.test (expr-13.17): Check that [expr {!$var}] can negate
- the string-versions of booleans "yes", "false", etc.
-
- * library/tcltest/tcltest.tcl (getMatchingFiles,
- (getMatchingDirectories):
- * tools/man2html.tcl (doDir):
- * tools/man2help.tcl (doDir):
- * library/package.tcl (tclPkgUnknown,tclMacPkgSearch):
- * library/safe.tcl (AddSubDirs): [glob] uses -directory instead of
- unsafe [file join]. [Bug 123313]
-
- * generic/tclIndexObj.c:
- * generic/tclTestObj.c (TestindexobjCmd): Changed internal
- representation of index objects to fix [Bug 119082]; fix shouldn't be
- visible to outside world...
-
- * generic/tclTest.c (TestGetIndexFromObjStructObjCmd):
- * tests/indexObj.test: (indexObj-6.*) Added to test for presence of
- [Bug 119082].
-
-2000-11-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fixed memory leak from [Bug
- 119398]
-
- * library/init.tcl (unknown): Added specific level parameters to
- all uplevel invocation to boost performance; didn't dare touch
- the "namespace inscope" stuff though, since it looks sensitive
- to me! Should fix [Bug 123217], though testing is tricky...
-
-2000-11-21 Andreas Kupries <a.kupries@westend.com>
-
- All of the changes below are described in TIP #7 ~ Specification and
- result from the application of the patch contained therein. Creator of
- the patch is Kevin Kenny <kennykb@crd.ge.com>. The patch used here is
- actually a bit different. Two MS specific constant values (format
- FOOui64) were replaced with a more portable formatting of the values
- and an additional cast to LONGLONG. My cross-compiling gcc was unable
- to process the original form. [Patch 102459]
-
- * tclWinTime.c: Add to the static data a set of variables that manage
- the phase-locked techniques, including a ''CRITICAL_SECTION'' to guard
- them so that multi-threaded code is stable.
-
- * tclWinTime.c: Modify ''TclpGetSeconds'' to call ''TclpGetTime'' and
- return the 'seconds' portion of the result. This change is necessary
- to make sure that the two times are consistent near the rollover from
- one second to another.
-
- * tclWinTime.c: Modify ''TclpGetClicks'' to use TclpGetTime to
- determine the click count as a number of microseconds.
-
- * tclWinTime.c: Modify ''TclpGetTime'' to return the time as M*Q+B,
- where Q is the result of ''QueryPerformanceCounter'', and M and B are
- variables maintained by the phase-locked loop to keep the result as
- close as possible to the system clock. The ''TclpGetTime'' call will
- also launch the phase-lock management in a separate thread the first
- time that it is invoked. If the performance counter is unavailable, or
- if its frequency is not one of the two common 8254-compatible rates,
- then ''TclpGetTime'' will return the result of ''ftime'' as it does in
- Tcl 8.3.2.
-
- * tclWinTime.c: Add the clock calibration procedure. The calibration
- is somewhat complex; to save space, the reader is referred to the
- reference implementation for the details of how the time base and
- frequency are maintained.
-
- * tclWinNotify.c: Modify ''Tcl_Sleep'' to test that the process has,
- in fact, slept for the requisite time by calling ''TclpGetTime'' and
- comparing with the desired time. Otherwise, roundoff errors may cause
- the process to awaken early.
-
- * tclWinTest.c: Add a ''testwinclock'' command. This command returns a
- four element list comprising the seconds and microseconds portions of
- the system clock and the seconds and microseconds portions of the Tcl
- clock.
-
- * winTime.test: Add to the test suite a test that makes sure that the
- Tcl clock stays within 1.1 ms of the system clock over the duration of
- the test.
-
-2000-11-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/global.n:
- * doc/upvar.n:
- * doc/variable.n: Improved documentation to mention that variables so
- created are listed in [info locals] and added a few more cross-links
- between these commands. [Bug 119387]
-
-2000-11-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/safe.test: (safe-4.3):
- * generic/tclVar.c (TclLookupVar): Changed again. Now passes all the
- tests, though one needed modifying since it required the wrong answer.
- (Why on earth do we have inline modification of argument strings? This
- sort of thing is horrendous to debug and doesn't work well in a
- multithreaded environment!) [Bug 119192]
-
- * tests/var.test: (var-1.19) If my attempts to fix the problem aren't
- right yet, my attempts to describe it look pretty good to me...
-
-2000-11-16 Andreas Kupries <a.kupries@westend.com>
-
- * win/tclWinPort.h (line 69): Changed reference to winsock2.h into
- winsock.h. This was a leftover from a foray into using winsock version
- 2 (History lesson from Scott Redman and Jeff Hobbs). This code was no
- problem when compiling Tcl itself, but could trip extensions. [Bug
- 122568]
-
-2000-11-15 Jeff Hobbs <jeff.hobbs@acm.org>
-
- * unix/Makefile.in: removed bp.c references (hasn't existed in a long
- time). Corrected 'make dist' to make dist with unversioned library
- directories (same as out of cvs), so make install works correctly with
- either source tree.
-
-2000-11-15 Jeff Hobbs <jeff.hobbs@acm.org>
-
- * generic/tclVar.c (TclLookupVar): reverted fix below as it broke all
- other array unset error reporting. Bug 119192 is still open.
-
-2000-11-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclVar.c (TclLookupVar): Changed references to part2 to use
- elName instead in various error message generating spots. [Bug 119192]
-
-2000-11-03 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/.cvsignore: Removed 'configure' from the glob list now that it's
- included.
-
-2000-11-03 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- 8.4a2 RELEASE
-
- * unix/Makefile.in (install-libraries, dist):
- * win/makefile.vc (install-libraries):
- * win/Makefile.in (install-libraries): updated to install unversioned
- library directories into versioned directories.
-
- * tools/tcl.wse.in: updated for unversioning of library dirs
-
- * unix/mkLinks: updated mkLinks with latest doc updates
-
- * doc/Tcl_Main.3: added docs for Tcl_SetMainLoop
-
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: added Tcl_SetMainLoop proc that allows people to
- set a main loop that will run for tclsh.
- * generic/tcl.h: added Tcl_MainLoopProc typedef
- * generic/tclMain.c (Tcl_SetMainLoop, StdinProc, Prompt): new
- StdinProc and Prompt static procs and Tcl_SetMainLoop stubs proc. The
- first two handle a fileevent based prompt (taken from tkMain.c).
- Tcl_SetMainLoop enables the interactive setting of a main loop
- procedure. This enables Tk to be a loadable package.
-
-2000-11-02 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * generic/tclEvent.c: tclLibraryPath Tcl_Obj didn't have a way to
- share its data among threads. This caused Tcl_Init() to always fail in
- threads. Added a way to pass the data around with a global char*.
- [BUG: 5301]
-
-2000-11-02 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * unix/configure:
- * unix/dltest/configure:
- * win/configure:
- * tools/configure: checked in configure scripts so people doing CVS
- checkouts aren't required to have autoconf. Changes to configure.in in
- the future will require the corresponding configure script to also be
- re-autoconf'ed and checked in.
-
- * win/makefile.vc:
- * win/tcl.m4: makefile fixes for Win64 support
-
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): minor cast
- changes.
-
-2000-11-01 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * unix/tcl.m4: removed use of -lbsd and -ldl for AIX-5.
-
- * tests/subst.test: added tests for non-zero return code handling by
- subst.
- * generic/tclParse.c (Tcl_EvalEx): corrected handling of non-zero,
- non-error return code cases for subst. [Bug 119829]
-
- * generic/tclVar.c (TclVarTraceExists): Corrected excessive mem use
- when info exists was called on a non-existent array element. [Bug
- 119213, 119336]
-
-2000-10-30 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/configure.in:
- * win/Makefile.in:
- * win/makefile.vc:
- * win/tcl.rc:
- * win/tclsh.rc: Added logic to derive filenames better in the resource
- scripts based on compile options.
-
-2000-10-30 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * unix/tclUnixInit.c: added default encoding map from "ja_JP.eucJP" to
- "euc-jp". (takahashi)
-
- * tests/clock.test: corrected clock-2.* test numbering
-
- * unix/configure.in (SC_TCL_LINK_LIBS): removed code that was
- commented out (it had been moved to tcl.m4's SC_TCL_LINK_LIBS
- already).
-
- * unix/tcl.m4: consolidated gettimeofday check for AIX.
-
-2000-10-27 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * unix/configure.in:
- * unix/tcl.m4: added support for AIX-5.
-
- * generic/tclIO.c (Tcl_NotifyChannel): removed #ifdef around code for
- old channel structures, placed preserve/release around statePtr
- * generic/tclIO.c (CloseChannel): the statePtr for a channel was not
- being freed when the last channel in a stack was freed, causing a mem
- leak.
-
- * unix/tclUnixChan.c: updated channel types to strict
- TCL_CHANNEL_VERSION_2 style to avoid compiler warnings. They work
- either way, but this avoids compiler warnings (that worries people).
-
-2000-10-27 Jennifer Hom <jenn@ajubasolutions.com>
-
- * library/tcltest1.0/tcltest.tcl: Removed a cd into the test directory
- in runAllTests that screwed up the temporary directory setting,
- effectively preventing users from running tests on multiple platforms
- at the same time.
-
-2000-10-26 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/tclWinFile.c (TclpMatchFilesTypes): NULL was being set to "attr"
- which was a DWORD. Changed NULL to zero because a 'void *' can't be
- set to a DWORD to avoid the compiler warning.
-
-2000-10-24 Jennifer Hom <jenn@ajubasolutions.com>
-
- * tests/all.tcl: Removed support for tcltest 1.0.
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl:
- * library/tcltest1.0/pkgIndex.tcl:
- * docs/tcltest.n: Moved tcltest2 code so that it's the standard
- version of tcltest. Removed all tcltest2 files (tests/tcltest2.test,
- library/tcltest1.0/tcltest2.tcl, docs/tcltest2.n).
-
-2000-10-20 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * win/tclWinFile.c (TclpMatchFilesTypes): made the stat call only
- occur when necessary (for 'glob' command). Significantly speeds up
- glob command from 8.3. [BUG: 6216]
-
-2000-10-19 Jennifer Hom <jenn@ajubasolutions.com>
-
- * library/tcltest1.0/tcltest2.tcl:
- * tests/tcltest2
- * doc/tcltest2.n: Code and documentation cleanup. Modified -verbose to
- take list of keywords as well as string of letters. Removed Tcl
- version information from tcltest. Removed tcltest::grep from tcltest
- package. Added optional 3rd directory argument to
- makeFile/makeDirectory and removeFile/removeDirectory.
-
- * tests/basic.test: Changed references to tcltest::tclVersion to
- hard-coded numbers.
- * generic/tcl.h: Changed reference to tcltest2.tcl and tcltest.tcl in
- comments to tests/basic.test.
-
-2000-10-06 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/tclWinChan.c: moved Win2K bug case test with GetStdHandle() from
- TclpGetDefaultStdChannel into Tcl_MakeFileChannel to enable a more
- general method in detecting invalid OS handles rather than just a
- specific known case. [BUG: 5971]
-
-2000-10-06 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * tests/cmdAH.test: extra tests for 'file channels' that include
- multiple interpreter tests and channel sharing
- * generic/tclIO.c (Tcl_GetChannelNamesEx): corrected function (and
- consequently 'file channels') to return channels that are actually
- registered for this specific interp, rather than this thread.
-
- * doc/CrtChannel.3: fixed spelling mistakes
-
-2000-09-29 Jennifer Hom <jenn@ajubasolutions.com>
-
- * library/tcltest1.0/tcltest2.tcl:
- * tests/tcltest2.test:
- * doc/tcltest2.n: Modified the new form of the test command to accept
- both attribute-value pairs and command line options. Updated the tests
- and the documentation for this new format. Also changed the option
- names for the test command.
-
-2000-09-29 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/tclWinSerial.c (SerialGetOptionProc): corrected reporting of
- space parity on Windows (Eason) [Bug 6057].
-
- * win/Makefile.in: commented use of TESTFLAGS
- * unix/Makefile.in: added TESTFLAGS to test target to conform with
- Windows makefile and TEA style.
-
- * tests/stack.test: prevented possible crash on systems with low
- default stacksize (Tru64, AIX) in infinite recursion test. A solution
- to check remaining stack space in the core is best, but hard to do in
- a cross-platform manner.
-
- * generic/tclIOGT.c (FLUSH_DELAY): renamed DELAY define to FLUSH_DELAY
- to avoid defn conflict using Tru64's cc.
-
-2000-09-28 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * tools/tcl.wse.in: added tclPlatDecls.h and tkPlatDecls.h to the
- Windows .exe install.
-
- * tests/fCmd.test (fCmd-6.20): corrected test to remove c:/tcl8975@
- after creating it.
-
- * tests/fileName.test: cleaned up the testing of glob patterns for
- c:/globTest (Windows) to directly create/remove directory.
-
-2000-09-27 Jeff Hobbs <hobbs@ajubasolutions.com>
-
- * generic/tcl.decls:
- * generic/tclIO.c: updated Tcl_IsChannelShared,
- Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel,
- Tcl_IsChannelExisting, and Tcl_ClearChannelHandlers to conform to the
- new stacked channel implementation. Their stub slots were also moved
- to give preference to the new 8.3.2 stub functions. This will cause an
- incompatibility with 8.4a1 only.
- (StopCopy): fixed a bug introduced by a partial fix in 8.3.2 that
- didn't set nonBlocking correctly when resetting the flags for the
- write side. [Bug: 6261]
-
- * doc/ChnlStack.3:
- * doc/CrtChannel.3:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclDecls.h:
- * generic/tclIO.c:
- * generic/tclIO.h:
- * generic/tclIOGT.c:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclTest.c:
- * tests/iogt.test:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc:
- * win/tclConfig.sh.in:
- * win/tclWinChan.c:
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c: Up-port of changes made in 8.3.2 to 8.4a2 code
- base. Most of these changes relate to the rewrite of the stacked
- channel implementation, with a few config related fixes.
-
- Following is an asynchronous include of the applicable ChangeLog
- entries from 8.3.2.
-
- ********************************************************
- ** START OF ASYNCHRONOUS UP-PORT LOG (8.3.2 -> 8.4a2) **
- ********************************************************
-
-2000-08-07 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/ChnlStack.3:
- * doc/CrtChannel.3: updated the docs to be aware of the
- TCL_CHANNEL_VERSION_2 style of Tcl channels.
-
- * generic/tclIO.c (Tcl_CreateChannel): added assertion to verify that
- the new channel versioning will be binary compatible with older
- channel drivers.
-
-2000-08-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIOGT.c (TclChannelTransform): fixed segfault that would
- occur when transforming a channel with a proc that did not yet exist.
- (Kupries)
-
- * generic/tclTest.c (TestChannelCmd): added some lint init'ing of
- statePtr and chan vars.
-
-2000-07-26 Jeff Hobbs <hobbs@scriptics.com>
-
- Merged core-8-3-1-io-rewrite back into core-8-3-1-branch. The
- core-8-3-1-io-rewrite branch should now be considered defunct.
-
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclIO.c: moved the Tcl_Channel* macros from tcl.h to tclIO.c
- and made them proper stubbed functions. These are: Tcl_ChannelName,
- Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc,
- Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc,
- Tcl_ChannelSeekProc, Tcl_ChannelSetOptionProc,
- Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc,
- Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, and
- Tcl_ChannelHandlerProc. These should be used to access the
- Tcl_ChannelType structure instead of direct pointer dereferencing.
-
- * tests/iogt.test: added RCS string, marked tests 2.* to be unixOnly
- due to underlying system differences.
-
-2000-07-25 Andreas Kupries <a.kupries@westend.com>
-
- * tests/iogt.test: (line 866f) New tests iogt-6.[01], highlighting
- buffering trouble when stacking and unstacking transformations.
- iogt-6.0 is solved, see the changes below. iogt-6.1 remains, for now,
- due to the perceived complexity of solutions.
-
- * generic/tclIO.h: (line 139f) struct Channel, added a buffer queue,
- to hold data pushed back when stacking a transformation.
-
- * generic/tclIO.c:
- (line 91f, line 7434f) New internal function 'CopyBuffer'. Derived
- from 'CopyAndTranslateBuffer', with translation removed.
- (line 1025f, line 1212f): Initialization of new queue.
- (line 1164f, Tcl_StackChannel): Pushback of input queue.
- (line 1293f, Tcl_UnstackChannel): Discard input and pushback.
- (line 3748f, Tcl_ReadRaw): Modified to use data in the push back area
- before going to the driver. Uses 'CopyBuffer', s.a.
- (line 4702f, GetInput): Modified to use data in the push back area
- before going to the driver.
- (line 4867f, Tcl_Seek): Modified to take pushback of the topmost
- channel in a stack into account.
- (line 5620f, Tcl_InputBuffered): See above. Added
- 'Tcl_ChannelBuffered'. Analog to 'Tcl_InputBuffered' but for the
- buffer area in the channel.
-
- * generic/tcl.decls: New public API 'Tcl_ChannelBuffered'. S.a.
-
-2000-07-17 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: added tclIOGT.c to objects list to compile.
-
- * generic/tclStubInit.c:
- * generic/tclIntDecls.h:
- * generic/tclInt.decls: commented out internal decls for
- TclTestChannelCmd and TclTestChannelEventCmd as they were moved to
- tclTest.c. Added new decls for TclChannelEventScriptInvoker and
- TclChannelTransform.
-
- * generic/tclIO.c (CloseChannel): stopped masking out of the
- TCL_READABLE|TCL_WRITABLE bits from the state flags in CloseChannel,
- instead adding extra intelligence to CheckChannelErrors with a new
- CHANNEL_RAW_MODE bit for special behavior when called from Raw channel
- APIs.
-
-2000-07-13 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIO.c (StackSetBlockMode): moved set of chanPtr outside of
- blockModeProc check to avoid infinite loop when blockModeProc was
- NULL. Updated TransformSeekProc to not call Tcl_Seek directly
- (Kupries).
-
- * win/tclWinChan.c: updated fileChannelType to v2 channel struct
- * win/tclWinConsole.c: updated consoleChannelType to v2 channel struct
- * win/tclWinPipe.c: updated pipeChannelType to v2 channel struct
- * win/tclWinSerial.c: updated serialChannelType to v2 channel struct
- * win/tclWinSock.c: updated tcpChannelType to v2 channel struct
-
-2000-07-11 Brent Welch <welch@ajubasolutions.com>
-
- * win/tclConfig.sh.in (TCL_LIBS): Cleaned up unix-specific autoconf
- variables.
-
-2000-07-11 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/iogt.test: made tests [345].0 not run by default as they were
- failing in the new design, but I'm not convinced that the returned
- result isn't correct.
-
- * generic/tclDecls.h:
- * generic/tclStubInit.c:
- * generic/tcl.decls: added Tcl_GetTopChannel C API that returns the
- current top channel of a channel stack. Tcl_GetChannel was changed
- earlier to return the bottommost channel of a stack because that is
- the one that is guaranteed to stay around the longest, and this was
- needed to compensate for certain operations that want to look at the
- state of the main channel. Most channel APIs already compensate for
- grabbing the top, so it shouldn't be needed often.
-
- * generic/tclIO.c (Tcl_StackChannel, Tcl_UnstackChannel): Added
- flushing of buffers (Kupries), removed use of DownChannel macro, added
- Tcl_GetTopChannel public API to get to the top channel of the channel
- stack (necessary for TLS). Rewrote Tcl_NotifyChannel for new channel
- design (Kupries). Did some code cleanup in the transform code.
- tclIO.c must still be broken into bits (separate out test code and
- giot code, create tclIO.h).
-
-2000-07-10 Andreas Kupries <a.kupries@westend.com>
-
- * tests/iogt.test: Reverted some earlier changes as a fix by Jeff
- revived the original and correct behaviour. IOW, the tests showed a
- genuine error and I didn't see it :(.
-
- * generic/tclIO.c (Tcl_Read|Write_Raw): Changed to directly use the
- drivers and not DoRead|DoWrite. The latter use the buffering system,
- encoding and eol-translation and this wreaks havoc with the data going
- through the transformations. Both procedures use CheckForchannelErrors
- and let it believe that there is no background copy in progress or
- else stacked channels could not be used for that.
-
- * generic/tclIO.c (TclCopyChannel, CopyData): Moved access to the
- topmost channel from the first to the second procedure to make the
- decision about that at the last possible time (Callbacks can change
- the stacking).
-
- test suite: failures of iogt-[345].0
-
-2000-07-06 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/iogt.test: new tests for stacked channel stuff based off new
- 'testchannel transform|unstack' code (Kupries IOGT extension).
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclDecls.h:
- * generic/tclStubsInit.c:
- * generic/tclIO.c: complete rewrite of Tcl Channel code for stacked
- channels. Channels are now designed to work in a more stacked fashion
- with a shared ChannelState data structure.
-
-2000-06-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIO.c (CloseChannel): removed the &ing out of
- (TCL_READABLE|TCL_WRITABLE) from the flags, as CloseChannel does this
- on the next pass through for the top channel, and it appeared to be
- causing hangs by not allowing the final flush.
-
-2000-06-01 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIO.c (CloseChannel): Rewrote CloseChannel code to unstack
- a channel during the close process. Fixed a refcount bug in
- Tcl_UnstackChannel. [Bug: 5623]
- (CloseChannel): further extended CloseChannel in the stacked case to
- effect certain operations on the next channel that would have been
- done in Tcl_Close. Also added CHANNEL_CLOSED and removed
- (TCL_READABLE|TCL_WRITABLE) bits from chanPtr->flags. Changed final
- reset of the WatchProc to check the chanDownPtr's (next) interestMask.
-
- ******************************************************
- ** END OF ASYNCHRONOUS UP-PORT LOG (8.3.2 -> 8.4a2) **
- ******************************************************
-
-2000-09-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/socket.test: removed doTestsWithRemoteServer constraint from
- socket-12.*. It requires 'exec', not a remote server. Cleaned up some
- coding errors.
-
-2000-09-20 Jennifer Hom <jenn@ajubasolutions.com>
-
- * library/tcltest1.0/pkgIndex.tcl: Updated to load tcltest 2.0.
- * library/tcltest1.0/tcltest2.tcl: New version of tcltest.
- Cleanup of command line parsing: allows users to specify command line
- arguments through an environment variable named TCLTEST_OPTIONS [RFE:
- 3748], does not respond to incorrect arguments, and forces usage of
- entire flag name when using command line arguments. Defines accessor
- procs for all tcltest variables. Allows users to use 'return' in test
- scripts. Allow users to specify whether test files should be sourced
- or run in a separate process. 'all.tcl' code moved to tcltest package.
- 'test' proc modified to use attribute-value pairs. Allow users to
- specify what return codes, output, and errors can be compared and
- whether these values should be compared using regexp, glob, or exact
- matching. makeDirectory & removeDirectory now operate with respect to
- temporaryDirectory [Bug: 6001]. Test results from tests run in slave
- interpreters are now included in test totals [Bug: 1493]. Test files
- that return error values are now reported.
- * tests/all.tcl: Added code to check for the tcltest version loaded;
- modified to figure out which tests to run based on the tcltest version
- loaded.
- * tests/tcltest.test: Modified to explicitly load version 1.0 of
- tcltest.
- * tests/tcltest2.test: New test suite for tcltest; includes all of the
- old tests plus new ones reflecting changes made for version 2.0.
- * tests/cmdAH.test: Added singleTestInterp constraint to cmdAH-31.2;
- this test does not run if tests aren't sourced into a single
- interpreter.
- * tests/socket.test: Fixed two tests that were referencing variables
- outside of scope.
-
- * tools/tcl.wse.in: Added code to install tcltest2.tcl.
-
- * doc/tcltest2.n: New documentation for tcltest version 2.0. Removes
- documentation for tcltest namespace variables. Adds documentation for
- new tcltest procs.
-
- * unix/mkLinks: Added code to link to tcltest2.n.
-
- * generic/tcl.h: Added comment to modify tcltest2.tcl as well as
- tcltest.tcl for version changes.
-
-2000-09-19 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): When using -all, all attempts
- after the first to match the regexp against the string should include
- the TCL_REG_NOTBOL flag, to avoid erroneously matching ^ in the middle
- of the string. Added code to set this flag after the first pass
- through the matching loop. [Bug: 6284].
-
-2000-09-19 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * doc/Eval.3: Added a note about the script argument to Tcl_Eval()
- should be in UTF-8 or risk implied conversion errors when possible
- combinations of upper ascii can be valid UTF-8 special codes.
-
-2000-09-17 Eric Melski <ericm@ajubasolutions.com>
-
- * tests/cmdIL.test: Added a test for fix for [Bug: 6212].
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Applied patch from [Bug:
- 6212], which corrected an error in the handling of the -index option.
-
-2000-09-14 Eric Melski <ericm@ajubasolutions.com>
-
- * doc/Alloc.3: Added entries for Tcl_AttemptAlloc, Tcl_AttempRealloc.
-
- * doc/StringObj.3: Added entry for Tcl_AttemptSetObjLength.
-
- * generic/tclDecls.h:
- * generic/tclStubInit.c: Regen'ed stubs files from new tcl.decls.
-
- * generic/tcl.decls: Added stubs for the Tcl_Attempt* memory
- allocators and for Tcl_AttemptSetObjLength.
-
- * generic/tcl.h: Added #define's for attemptckalloc, attemptckrealloc,
- which map to the Tcl_Attempt* memory allocators.
-
- * generic/tclCkalloc.c: Added non-panic'ing versions of Tcl_Alloc,
- Tcl_Realloc, etc.; these are called Tcl_AttemptAlloc,
- Tcl_AttemptRealloc, etc. These are used by Tcl_AttemptSetObjLength and
- the string obj append functions.
-
- * generic/tclStringObj.c: Modified string growth algorithm to use
- doubling algorithm as long as possible, and only fall back when that
- fails. Added Tcl_AttemptSetObjLength, and modified
- AppendUnicodeToUnicodeRep, AppendUtfToUtfRep, and
- Tcl_AppendStringsToObjVA to support this.
-
-2000-09-07 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/.cvsignore: changed the glob patterns a bit to exclude VC++
- project conversion backups.
-
- * win/tclWinPipe.c: Stage-1 bug fix for TR#2460 "exec leaks memory".
- Added more logic around the close-down of the pipe reader thread so as
- to avoid, at all cost, a TerminateThread. Most cases with exec are
- fixed, but I don't consider 2460 done yet. Closing down the read side
- of a pipe before the child process, doesn't really fit the windows
- model. [BUG: 2460]
-
-2000-09-07 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/trace.n: minor doc cleanup
-
-2000-09-06 André Pönitz <poenitz@htwm.de>
-
- * doc/*.n: added or changed "SEE ALSO:" section
-
-2000-09-06 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/tclWinLoad.c (TclpLoadFile): added special message for
- ERROR_PROC_NOT_FOUND exception in loading a dll.
- * win/tclWinError.c: changed ERROR_PROC_NOT_FOUND to map from ESRCH
- (POSIX: no such process) to EINVAL because there is no good mapping
- for "procedure not found".
-
- * README:
- * generic/tcl.h:
- * library/tcltest1.0/tcltest.tcl:
- * tools/tcl.wse.in:
- * tools/tcltk-man2html.tcl:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure.in: updated patchlevel to 8.4a2
-
- * unix/tclUnixPipe.c (TclpCreateProcess): Removed WNOHANG from
- Tcl_WaitPid call in error case of process creation on Unix, as it
- would lead to defunct processes. [Bug: 6148]
-
- * tests/string.test: extended string repeat tests
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): changed STR_REPEAT to
- preallocate the full space of the final string, avoided repeated
- appends.
-
- * doc/source.n:
- * doc/Eval.3: added extra note about how to safe use ^Z in code, as it
- is now a cross-platform (was just Windows) EOF char.
-
-2000-09-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclHash.c: fixed pedantic warning of incorrectly placed
- #endif
-
- * generic/tclExecute.c (TclExecuteByteCode): INST_STR_INDEX fixed
- pedantic cast warning.
- Corrected support for building with -DTCL_COMPILE_STATS.
- Added efficiency check of object equality.
-
-2000-08-29 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclStringObj.c: Applied patch from Gerhard Hintermayer to
- provide a more conservative string growth algorithm for strings larger
- than one megabyte; this allows more efficient use of memory for very
- large strings.
-
-2000-08-25 Eric Melski <ericm@ajubasolutions.com>
-
- * tests/trace.test: Extended array tracing tests.
-
- * doc/trace.n: Clarified information about when array traces will be
- fired.
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): Corrected call to CallTraces
- (for TCL_TRACE_ARRAY) to only be called when the variable is either an
- array or is undefined, to ensure that array traces do not fire for
- scalar variables.
-
-2000-08-24 Eric Melski <ericm@ajubasolutions.com>
-
- * doc/man.macros: Tweaked tab settings for .SO (Standard Options)
- sections, based on suggestion from Peter Spjuth.
-
-2000-08-24 Mo DeJong <mdejong@redhat.com>
-
- * unix/README: Update to account for removal of --enable-gcc.
- * unix/configure.in:
- * unix/tcl.m4 (SC_ENABLE_GCC): Remove --enable-gcc option.
- * win/README: Add note about building with Cygwin.
- * win/configure.in:
- * win/tcl.m4 (SC_ENABLE_GCC): Remove --enable-gcc option. Remove quick
- hack that provided cross compile support for windows builds.
-
-2000-08-24 Eric Melski <ericm@ajubasolutions.com>
-
- Overall change: Added support for command rename/delete traces and new
- trace syntax, from patch from Vince Darley. Added support for array
- traces for variables. [RFE: 5048, 5967].
-
- * doc/trace.n: Updated documentation for new syntax; flagged old
- syntax as deprecated; added documentation for command rename/delete
- traces and variable array traces.
-
- * tests/trace.test: Updated tests for new trace syntax; new tests for
- command rename/delete traces; new tests for array traces.
-
- * generic/tclVar.c: Support for new trace syntax; support for
- TCL_TRACE_ARRAY.
-
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: Stub functions for command rename/delete traces.
-
- * generic/tcl.h:
- * generic/tclInt.h:
- * generic/tclBasic.c: Support for command traces.
-
- * generic/tclCmdMZ.c (TclTraceVariableObjCmd): Patched to support new
- [trace] syntax:
- trace {add|remove|list} {variable|command} name ops command
- Added support for command traces (rename, delete operations).
- Added support for TCL_TRACE_ARRAY at Tcl level (array operation for
- variable traces).
-
-2000-08-20 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclVar.c: Added check for non-arrays for [array statistics]
- command (patch from Mark Patton).
-
-2000-08-19 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * generic/tclPlatDecls.h: without a previous '#include <windows.h>',
- tclPlatDecls.h can't be parsed due to a missing definition of TCHAR.
- Added a check to include it when not defined.
-
- ***POSSIBLE OBSCURE BUG*** could be caused when the compile flags for
- the core happen to be different than a project who uses these publics
- regarding -D_MBCS and -D_UNICODE. This added check might have to be
- revisited later with a better understanding of the reprocusions. I
- think TCHAR should be replaced with it's expansion.
-
-2000-08-18 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/.cvsignore (added): provides a cleaner build environment with
- graphical CVS clients.
-
-2000-08-15 Eric Melski <ericm@ajubasolutions.com>
-
- * library/tcltest1.0/tcltest.tcl: Set debug level in
- tcltest::restoreState to 2, for consistancy with the debug level in
- tcltest::saveState [Bug: 4505].
-
-2000-08-14 Eric Melski <ericm@ajubasolutions.com>
-
- * win/makefile.vc:
- * win/Makefile.in:
- * unix/Makefile.in: Added tclPlatDecls.h to the list of installed
- headers, for more complete stubs support. [Bug: 5241].
-
- * generic/tcl.h: Added #include "tclPlatDecls.h" to get
- platform-specific stubs declarations (Tcl_WinTCharToUtf, etc)
- [Bug: 5241].
-
- * README: Updated link for instructions on compiling Tcl from sources
- to point to correct location (http://dev.scriptics.com/doc/... instead
- of http://dev.scriptics.com/support/...).
-
-2000-08-11 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclEnv.c (TclUnsetEnv): Changed declaration of length
- variable from "unsigned int" to "int", to match usage when passed to
- TclpFindVariable [Bug: 6126].
-
-2000-08-10 Eric Melski <ericm@ajubasolutions.com>
-
- * library/msgcat1.0/pkgIndex.tcl: Bumped version number to 1.2 [Bug:
- 6100].
-
- * library/msgcat1.0/msgcat.tcl: Removed erroneous [package forget] in
- msgcat namespace initializer. Bumped version number to 1.2 [Bug: 6100]
-
-2000-08-10 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * generic/tclObj.c: r1.15 accidentally changed a global mutex name
- tclObjMutex to ObjMutex. Put the correct name back.
-
-2000-08-07 Eric Melski <ericm@ajubasolutions.com>
-
- * tests/indexObj.test: Added tests using the [testwrongnumargs]
- command to test Tcl_WrongNumArgs.
-
- * generic/tclTest.c (TestWrongNumArgsObjCmd): Added test function for
- the Tcl_WrongNumArgs function.
-
- * generic/tclIndexObj.c (Tcl_WrongNumArgs): Corrected algorithm to not
- insert a space before the message component when objc == 0 [Bug: 6078]
-
-2000-07-27 Mo DeJong <mdejong@redhat.com>
-
- * win/configure.in: TCL_STUB_LIB_FLAG should not include ${TCL_DBGX}
- in win/tclConfig.sh, fix that.
-
-2000-07-25 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * doc/Async.3:
- * generic/tclAsync.c:
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * generic/tclTest.c:
- * mac/tclMacPort.h:
- * unix/tclUnixPort.h:
- * win/tclWinInit.c: Thread-safe rewrite for tclAsync.c. Added notifier
- alerting on all platforms as it was only working on Win before.
- Removed older Win hacks that would end-up waking the wrong notifier in
- the presence of a threaded build. All tests pass as before. New test
- cases will be added soon for the new behavior. [BUG: 5791]
-
-2000-07-25 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclVar.c (CallTraces): Added check for VAR_TRACE_ACTIVE on
- the array containing the variable before executing traces on that
- array, to conform with normal variable traces and the documentation,
- which states that while executing a trace, other traces on that
- variable are disabled. [Bug: 6049].
-
- * win/tclWinPipe.c (BuildCommandLine): Added Tcl_DStringFree call to
- prevent potential memory leaks [Bug: 6041].
-
-2000-07-24 Eric Melski <ericm@ajubasolutions.com>
-
- * doc/msgcat.n: Added documentation about the selection of the default
- locale on Windows.
-
-2000-07-23 Joe English <jenglish@flightlab.com>
-
- * doc/AddErrInfo.3:
- * doc/ChnlStack.3:
- * doc/Exit.3:
- * doc/GetIndex.3:
- * doc/Notifier.3:
- * doc/Object.3:
- * doc/RegExp.3:
- * doc/SetResult.3:
- * doc/SplitList.3:
- * doc/Thread.3: Added missing entries to NAME section.
-
- * doc/AddErrInfo.3:
- * doc/CrtObjCmd.3:
- * doc/RecEvalObj.3: Changed Tcl_EvalObj to Tcl_EvalObjEx
-
-2000-07-21 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclStubInit.c:
- * generic/tclObj.c:
- * generic/tclInt.h:
- * generic/tclHash.c:
- * generic/tclDecls.h:
- * generic/tcl.h:
- * generic/tcl.decls:
- * doc/Hash.3: Reapplied patch from Paul Duffin to extend hash tables
- to allow custom key types, such as Tcl_Obj *'s, and others.
-
- * doc/binary.n: Noted that the example in the introduction assumes a
- 32-bit system [Bug: 6035].
-
-2000-07-21 Mo DeJong <mdejong@redhat.com>
-
- * win/configure.in: Define ${prefix} and ${exec_prefix} like
- unix/configure.in. Fix or add TCL_SRC_DIR, TCL_STUB_LIB_FILE,
- TCL_STUB_LIB_FLAG, TCL_BUILD_STUB_LIB_SPEC, TCL_STUB_LIB_SPEC,
- TCL_BUILD_STUB_LIB_PATH, TCL_STUB_LIB_PATH.
-
-2000-07-20 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclStubInit.c:
- * generic/tclObj.c:
- * generic/tclInt.h:
- * generic/tclHash.c:
- * generic/tclDecls.h:
- * generic/tcl.h:
- * generic/tcl.decls:
- * doc/Hash.3: Reverted patch from Paul Duffin to extend hash tables to
- allow custom key types, such as Tcl_Obj *'s, and others; it seems to
- break Tk.
-
-2000-07-19 Eric Melski <ericm@ajubasolutions.com>
-
- * generic/tclStubInit.c:
- * generic/tclObj.c:
- * generic/tclInt.h:
- * generic/tclHash.c:
- * generic/tclDecls.h:
- * generic/tcl.h:
- * generic/tcl.decls:
- * doc/Hash.3: Applied patch from Paul Duffin to extend hash tables to
- allow custom key types, such as Tcl_Obj *'s, and others.
-
- * tests/pkgMkIndex.test: Added tests for pkg_compareExtension.
-
- * library/package.tcl: Enhanced pkg_compareExtension to handle Unixes
- which tack the version number on to the end of library names (eg,
- foo.so.1.2); such filenames will be correctly matched. (Patch from
- Vince Darley).
-
- * win/makefile.vc: Applied patch from Don Porter to provide better
- nmake support for NT/Alpha [RFE: 5938].
-
-2000-07-18 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure.in:
- * unix/tcl.m4:
- * win/tcl.m4: Properly quote arguments to m4 macros. This allows Tcl
- to work with the new version of autoconf.
-
-2000-07-18 Eric Melski <ericm@ajubasolutions.com>
-
- * tests/opt.test: Removed references to Lfirst, Lrest functions.
-
- * library/opt0.4/optparse.tcl: Applied patch from Chris Nelson, which
- replaces the [Lfirst] function with an inline [lindex ... 0] and
- [Lrest] with [lrange ... 1 end], for better performance. [RFE: 6019]
-
-2000-07-18 Eric Melski <ericm@scriptics.com>
-
- * compat/string.h: Fixed function prototypes for strpbrk and strtok
- [Bug: 6020].
-
-2000-07-17 David Gravereaux <davygrvy@ajubasolutions.com>
-
- * win/tclWinChan.c: Win2K OS bug with GetStdHandle(STD_OUTPUT_HANDLE)
- giving the wrong answer. This made TclpGetDefaultStdChannel grab what
- it thought was a valid native stdout handle. Added a new WriteFile()
- test to make sure it's really valid. This OS bug doesn't affect the
- shells. Only -subsystem:windows (aka WinMain) application that
- dynamically load tclXX.dll [BUG: 5971]
-
-2000-07-17 Eric Melski <ericm@scriptics.com>
-
- * library/msgcat1.0/msgcat.tcl:
- * doc/msgcat.n:
- * tests/msgcat.test: Applied patches from Chris Nelson, to provide the
- mcmset function, which allows the translator to set multiple string
- translations in a single function call, rather than requiring many
- calls to mcset. [RFE: 6000, 5993]. In addition, these patches correct
- mcload to use utf-8 encoding on when reading message catalog files,
- and provides for better default behavior for determining the locale on
- a Windows system.
-
-2000-07-17 Mo DeJong <mdejong@redhat.com>
-
- * unix/tcl.m4 (SC_ENABLE_GCC): Don't set CC=gcc before running
- AC_PROG_CC if CC is already set.
-
-2000-07-13 André Pönitz <poenitz@mathematik.tu-chemnitz.de>
-
- * doc/lappend.n:
- * doc/lindex.n:
- * doc/linsert.n:
- * doc/list.n:
- * doc/llength.n:
- * doc/lrange.n:
- * doc/lreplace.n:
- * doc/lsearch.n:
- * doc/lsort.n: Added SEE ALSO sections.
-
-2000-07-07 Mo DeJong <mdejong@redhat.com>
-
- * win/configure.in: Fix definition of TCL_SRC_DIR so that it matches
- the Unix version.
- * win/tclConfig.sh.in: Removed duplicate variables.
-
-2000-07-06 Eric Melski <ericm@scriptics.com>
-
- * tests/msgcat.test:
- * library/msgcat1.0/msgcat.tcl: Applied patch from Christian Krone, to
- provide extended args support for msgcat::unknown, which is used for
- strings without a known translation in the current locale [Bug: 5984].
-
-2000-06-29 Eric Melski <ericm@scriptics.com>
-
- * doc/msgcat.n: Doc's for mcmax function.
-
- * library/msgcat1.0/msgcat.tcl: Applied patches from Laurent Duperval,
- to add mcmax function, which computes the length of the longest of
- several translated strings. Bumped version number to 1.1.
-
-2000-06-27 Eric Melski <ericm@scriptics.com>
-
- * tests/stringObj.test: Tweaked tests to avoid hard-coded high-ASCII
- characters (which will fail in multibyte locales); instead used \uXXXX
- syntax. [Bug: 3842].
-
-2000-06-26 Eric Melski <ericm@scriptics.com>
-
- * doc/package.n: Corrected information about [package forget]
- arguments [Bug: 5418].
-
-2000-06-23 Eric Melski <ericm@scriptics.com>
-
- * doc/Hash.3: Added documentation patch for Tcl_Obj *'s as keys in Tcl
- hash tables [RFE: 5934].
-
- * generic/tcl.h:
- * generic/tclHash.c: Applied patch from [RFE: 5934], which extends Tcl
- hash tables to allow Tcl_Obj *'s as the key.
-
-2000-06-20 Eric Melski <ericm@ajubasolutions.com>
-
- * tests/opt.test:
- * library/opt0.4/optparse.tcl: Applied patch from [Bug: 5922], which
- corrected an incorrect use of [string match].
-
- * unix/tclConfig.sh.in:
- * win/tclConfig.sh.in: Applied patch from [Bug: 5921], which corrects a
- typo in the comments in these files.
-
-2000-06-19 Eric Melski <ericm@scriptics.com>
-
- * doc/RegExp.3: Replaced instances of "Tcl_GetRegExpInfo" with
- "Tcl_RegExpGetInfo", the correct name of the function [Bug: 5901].
-
-2000-06-13 Eric Melski <ericm@scriptics.com>
-
- * win/tcl.m4:
- * win/configure.in:
- * win/Makefile.in: Applied patch from [RFE: 5844], to extend support
- for mingw compile environment on Windows.
-
- * win/tclWinDde.c:
- * win/tclWinInit.c:
- * win/tclWinNotify.c:
- * win/tclWinPipe.c:
- * win/tclWinReg.c:
- * win/tclWinThrd.c: Applied patch from [Bug: 5794], to fix compiler
- warnings when using mingw on Windows.
-
-2000-05-31 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/set-old.test:
- * doc/unset.n:
- * generic/tclVar.c (Tcl_UnsetObjCmd): added -nocomplain and -- options
- to unset, to allow for a silent unset operation.
-
-2000-05-31 Eric Melski <ericm@scriptics.com>
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): Added support for regexp and
- exact matching for [array names] command. [RFE: 3684].
-
- * doc/array.n: Added documentation for [array names
- -exact/-regexp/-glob] [RFE: 3684].
-
- * tests/set-old.test: Added tests for [array names
- -exact/-regexp/-glob] [RFE: 3684].
-
-2000-06-06 Jeff Hobbs <hobbs@scriptics.com>
-
- 8.4a1 RELEASE
-
- * generic/tclExecute.c (TclExecuteByteCode INST_STR_CMP): added test
- of iResult return from memcmp, as memcmp isn't required to return only
- -1,0,1.
-
-2000-06-03 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Corrected caching
- of the index ptr to account for offsets != sizeof(char *). [Bug: 5153]
-
-2000-05-29 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * tests/http.test
- * doc/http.n
- * library/http2.3/http.tcl: Fixed bug 5741, where unsuccessful geturl
- calls sometimes leaked memory and resources (sockets). Also, switched
- around some of the logic so that http::wait never throws an exception.
- This is because in an asynchronous geturl, the command callback will
- probably end up doing all the error handling anyway, and in an
- asynchronous situation, the user expects to check the state when the
- transaction completes, as opposed to being thrown an exception. For
- the http package, this menas the user can check http::status for
- "error" and http::error for the error message after doing the
- http::wait.
-
-2000-05-27 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/info.test:
- * doc/info.n:
- * generic/tclIOUtil.c (Tcl_EvalFile):
- * generic/tclCmdIL.c (InfoScriptCmd): added ability to set the info
- script return value [info script ?newFileName?]. This will be
- beneficial for virtual file system programs. [Bug: 4225]
-
-2000-05-26 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): reworked to operate in
- Unicode, tweaked for performance.
- (Tcl_StringObjCmd) changed STR_FIRST/STR_LAST error message to
- something more understandable, reworked STR_FIRST, STR_LAST, STR_MAP,
- STR_MATCH, STR_RANGE, STR_REPLACE to operate in Unicode. Removed
- inneffectual STR_RANGE "special" ByteArray support. Optimized STR_MAP
- algorithm, especially optimized for one-pair case. Fixed possible mem
- overrun in STR_INDEX bytearray case.
-
- * generic/tclCompExpr.c: changed INST_STREQ -> INST_STR_EQ,
- INST_STRNEQ -> INST_STR_NEQ
- * generic/tclCompile.c: added streq, strneq, strcmp, strlen &
- strmatch to the compiled stats instructionTable
- * generic/tclCompile.h: added instructions INST_STR_CMP,
- INST_STR_INDEX, INST_STR_MATCH
- * generic/tclCompCmds.c: added byte compiler support for [string
- compare|match|index].
- * generic/tclExecute.c: Changed INST_STR_(N)EQ to return an Int object
- and not bother trying to reuse the top stack object. Added
- INST_STR_CMP, INST_STR_INDEX, INST_STR_MATCH bytecode ops. Extended
- evalstats output info with Tcl_IsShared stat info.
-
- * generic/tclInt.h:
- * generic/tclObj.c (Tcl_DbIsShared): added support for checking result
- of Tcl_IsShared in evalstats (TCL_COMPILE_STATS).
-
- * generic/tclStringObj.c (Tcl_AppendUnicodeToObj): removed dead code.
- (AppendUnicodeToUnicodeRep) removed overallocation by extra
- sizeof(Tcl_UniChar) multiplier.
-
- * tests/string.test: added string map tests for the one-pair case,
- corrected tests to reflect improved error messages in first/last.
- Added tests against mem overrun in string index bytearray case.
-
-2000-05-23 Eric Melski <ericm@scriptics.com>
-
- * generic/tclInt.h: Added function prototypes for TclCompileStringCmd
- and TclCompileReturnCmd.
-
- * generic/tclCompile.h: Added definition of INST_STRLEN opcode and
- updated LAST_INST_OPCODE value.
-
- * generic/tclBasic.c: Added information about TclCompileStringCmd and
- TclCompileReturnCmd to BuiltInCmds table.
-
- * generic/tclExecute.c (TclExecuteByteCode): Added support for the
- INST_STRLEN opcode.
-
- * generic/tclCompCmds.c (TclCompileStringCmd): Basic implementation of
- byte-compiled [string] command. Not all subcommands are implemented;
- those that are not an out-line compiled.
-
- (TclCompileReturnCmd): Byte-compiled implementation of [return]
- command. Only "simple" returns are byte-compiled; in particular, if
- the -code, -errorinfo or -errorcode flags are used, the command is not
- byte-compiled.
-
-2000-05-22 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/scan.n:
- * doc/array.n: minor doc fixes [Bug: 5396]
-
- * generic/tclEnv.c: cast cleanup [Bug: 5624]
- * win/tclWinConsole.c: cast and header cleanup [Bug: 5625]
- * win/tclWinSerial.c: cast cleanup [Bug: 5626]
- * win/tclWinFCmd.c: cast cleanup [Bug: 5627]
-
-2000-05-19 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclTest.c:
- * generic/tclIO.c: moved channel test commands from tclIO.c to
- tclTest.c.
- * generic/tclIO.h: new file, split out from tclIO.c to allow test
- commands to be moved to tclTest.c.
-
- * generic/tclStubInit.c:
- * generic/tclIntDecls.h:
- * generic/tclInt.decls: removed TclTestChannel*Cmd from internal stubs
- table and added TclChannelEventScriptInvoker to the internal stubs
- table so it can be used from the test code.
-
-2000-05-18 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added test for "2 days 2 hours ago" style
- specifications.
-
- * generic/tclDate.c: Regenerated from tclGetDate.y.
-
- * generic/tclGetDate.y: Tweaked grammar to properly handle the "ago"
- keyword when it follows multiple relative unit specifiers, as in "2
- days 2 hours ago". [Bug: 5497]
-
-2000-05-18 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/{tcl.m4,Makefile.in,configure.in}: added support for mingw
- compile env and cross-compiling. [Bug: 5499]
-
- * generic/tclClock.c (FormatClock): correct code to handle locale
- specific return values from strftime, if any. [Bug: 3345]
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): attempt to correct
- setlocale calls for XIM support and locale issues. [BUG: 5422 3345
- 4236 2522 2521]
-
-2000-05-17 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/init.tcl (auto_import): added check to see if a valid
- pattern was coming in, to avoid simple error cases [Bug: 3326]
-
- * doc/regsub.n: correct regsub docs [Bug: 5346]
-
-2000-05-15 Eric Melski <ericm@scriptics.com>
-
- * library/history.tcl: Corrected an off-by-one error in HistIndex,
- which was causing [history redo] to start its search at the wrong
- event index. [Bug: 1269].
-
-2000-05-10 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclPosixStr.c (Tcl_SignalMsg): clarified #defines for Linux
- on Sparc to compile correctly. [Bug: 5364]
-
- * doc/namespace.n:
- * tests/namespace.test:
- * generic/tclNamesp.c (Tcl_NamespaceObjCmd): added 'namespace exists'
- command. [Bug: 4665]
-
- * doc/source.n:
- * doc/Eval.3:
- * tests/source.test:
- * generic/tclIOUtil.c (Tcl_EvalFile): added explicit \32 (^Z) eofchar
- (affects Tcl_EvalFile in C, "source" in Tcl). This was implicit on
- Windows already, and is now cross-platform to allow for scripted
- documents.
-
-2000-05-09 Andreas Kupries <a.kupries@westend.com>
- operating as proxy for David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinThrd.c (TclpInitLock, TclpMasterLock): Added missing
- initialization of joinLock.
-
-2000-05-09 Eric Melski <ericm@scriptics.com>
-
- * tests/lsearch.test:
- * doc/lsearch.n:
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Extended [lsearch] to
- support sorted list searching and typed list searching. [RFE: 4098].
-
-2000-05-08 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/expr.n:
- * tests/expr.test:
- * tests/expr-old.test: added tests for 'eq' and 'ne'
- * generic/tclExecute.c:
- * generic/tclCompile.h: added INST_STREQ and INST_STRNEQ opcodes that
- do strict string comparisons.
- * generic/tclCompExpr.c: added 'eq' and 'ne' string comparison
- operators.
- * generic/tclParseExpr.c (GetLexeme): added 'eq' and 'ne' expr parse
- terms (string (in)equality check).
-
- * generic/tclCmdIL.c (Tcl_LinsertObjCmd): made use of
- Tcl_DuplicateObj where code was otherwise duplicated. Made special
- case of inserting one element at the end work again (where index ==
- len).
- (Tcl_LreplaceObjCmd): moved Tcl_DuplicateObj call lower and cleaned
- up use of other arguments.
-
- * generic/tclObj.c (Tcl_DuplicateObj): simplified code to call
- TclInitStringRep, which the code was just duplicating in part.
-
- * doc/Utf.3:
- * generic/tclStubInit.c:
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclUtf.c: Added new functions Tcl_UniCharNcasecmp and
- Tcl_UniCharCaseMatch (unicode parallel to Tcl_StringCaseMatch)
- * generic/tclUtil.c: rewrote Tcl_StringCaseMatch algorithm for
- optimization and made Tcl_StringMatch just call Tcl_StringCaseMatch
- * tests/string.test: extended string match tests
-
-2000-05-08 Eric Melski <ericm@scriptics.com>
-
- * tests/set-old.test:
- * doc/array.n:
- * generic/tclVar.c: Added [array statistics] command [RFE: 4557]
-
-2000-05-06 Andreas Kupries <a.kupries@westend.com>
- operating as proxy for David Gravereaux <davygrvy@pobox.com>
-
- * tclThreadJoin.c: Fixed several places with missing a & in arguments
- to calls of Tcl_Mutex(Un)lock and Tcl_ConditionNotify functions.
-
-2000-05-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * generic/tcl.h:
- * library/init.tcl:
- * library/reg1.0/pkgIndex.tcl:
- * library/tcltest1.0/tcltest.tcl:
- * mac/README:
- * tools/tcl.hpj.in:
- * tools/tcl.wse.in:
- * unix/README:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README:
- * win/README.binary:
- * win/configure.in:
- * win/makefile.vc:
- * win/tcl.m4: updated patchlevel to 8.4a1
-
- * tests/compile.test:
- * tests/init.test:
- * tests/proc.test:
- * tests/proc-old.test:
- * tests/rename.test:
- * generic/tclProc.c: reworked error return for procedures with
- incorrect args to be like the C Tcl_WrongNumArgs, where a "wrong #
- args: ..." message is printed out with the args list.
-
- * unix/Makefile.in: add tclsh.ico and tcl.spec to dist target
-
-2000-05-02 Andreas Kupries <a.kupries@westend.com>
-
- Overall changes:
- (1) Implementation of joinable threads for all platforms.
- (2) Additional API's for channels. Required to allow the thread
- extension to move channels between threads.
-
- * generic/tcl.decls (lines 1360f): Added Tcl_JoinThread,
- Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel,
- Tcl_SpliceChannel, Tcl_IsChannelExisting and Tcl_ClearChannelHandlers
- (slots 394 to 400).
-
- * generic/tclIO.c: Implemented Tcl_IsChannelRegistered,
- Tcl_IsChannelShared, Tcl_CutChannel, Tcl_SpliceChannel,
- Tcl_IsChannelExisting and Tcl_ClearChannelHandlers. Tcl_CutChannel
- uses code from CloseChannel. Replaced this code by a call to
- Tcl_CutChannel. Replaced several code fragments adding channels to
- the channel list with calls to Tcl_SpliceChannel. Removed now unused
- variables from CloseChannel and Tcl_UnstackChannel.
- Tcl_ClearChannelHandlers uses code from Tcl_Close. Replaced this code
- by a call to Tcl_ClearChannelHandlers. Removed now unused variables
- from Tcl_Close. Added the subcommands 'cut', 'forgetch', 'splice' and
- 'isshared' to the test code (TclTestChannelCmd).
-
- * unix/tclUnixThread.c: Implemented Tcl_JoinThread using the
- pthread-functionality.
-
- * win/tclWinThrd.c: Fixed several small typos in comments.
- Implemented Tcl_JoinThread using a platform independent emulation
- layer (see generic/tclThreadJoin.c below). Added 'joinLock' to
- serialize Tcl_CreateThread and TclpExitThread to prevent a race for
- joinable threads.
-
- * mac/tclMacThrd.c: Implemented Tcl_JoinThread using a platform
- independent emulation layer (see generic/tclThreadJoin.c below). Due
- to the cooperative nature of threading on this platform the race
- mentioned above is not present.
-
- * generic/tclThreadJoin.c: New file. Contains a platform independent
- emulation layer helping in the implementation of joinable threads for
- the win and mac platforms.
-
- * generic/tclInt.h: Added declarations for TclJoinThread,
- TclRememberJoinableThread and TclSignalExitThread. These procedures
- define the API of the emulation layer for joinable threads (see
- generic/tclThreadJoin.c above).
-
- * win/Makefile.in:
- * win/makefile.vc: Added generic/tclTheadJoin.o to the rules.
-
- * mac/: I don't know to which file generic/tclTheadJoin.o has to be
- added to so that it compiles. Sorry.
-
- * unix/tclUnixChan.c: #ifdef'd the thread-local list of file channels
- as it prevents us from transfering channels. To restore this we may
- need an extended interface to drivers in the future. Target:
- 9.0. Found while testing the new transfer of channels. The information
- in this list for a channel was left behind and then crashed the system
- during finalization.
-
- * generic/tclThreadTest.c: Added -joinable flag to 'testthread
- create'. Added subcommand 'testthread join'.
-
- * doc/CrtChannel.3: Added documentation for Tcl_IsChannelRegistered,
- Tcl_IsChannelShared, Tcl_CutChannel, Tcl_SpliceChannel,
- Tcl_IsChannelExisting and Tcl_ClearChannelHandlers.
-
- * doc/Thread.3: Added documentation for Tcl_JoinThread.
-
- * tests/thread.test: Added tests for joining of threads.
-
-2000-04-27 Eric Melski <ericm@scriptics.com>
-
- * doc/library.n: Added entries for auto_qualify and auto_import
- [Bug: 1271].
-
- * doc/Init.3: Manual entry for Tcl_Init [Bug: 1820].
-
- * doc/expr.n: Added documentation for each of the math library
- functions that expr supports [Bug: 1054].
-
-2000-04-26 Eric Melski <ericm@scriptics.com>
-
- * doc/memory.n: Man page for Tcl "memory" command, which is created
- when TCL_MEM_DEBUG is defined at compile time.
-
- * doc/TCL_MEM_DEBUG.3: Man page with overall information about
- TCL_MEM_DEBUG usage.
-
- * doc/DumpActiveMemory.3: Man page for Tcl_DumpActiveMemory,
- Tcl_InitMemory, and Tcl_ValidateAllMemory [Bug: 1816, 1835].
-
- * generic/tclCkalloc.c: Fixed some function headers.
-
- * unix/mkLinks: Regen'd with new mkLinks.tcl.
-
- * unix/mkLinks.tcl: Fixed indentation, made link setup more
- intelligent (only do one existence test per man page, instead of one
- per function).
-
- * doc/library.n: Fixed .SH NAME macro to include each function
- documented on the page, so that mkLinks will know about the functions
- listed there, and so that the Windows help file index will get set up
- correctly [Bug: 1898, 5273].
-
-2000-04-26 Jeff Hobbs <hobbs@scriptics.com>
-
- 8.3.1 RELEASE
-
- * README:
- * mac/README:
- * tools/tcl.wse.in:
- * unix/README:
- * unix/tcl.spec:
- * win/README:
- * win/README.binary: Updating URLs to reference dev.scriptics.com
-
-2000-04-25 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: updated for http change and some cleanup
- * library/http2.[13]: moved dir http2.1 to http2.3 to match version
-
- * doc/Utf.3: clarified docs for Tcl_(UniChar|Utf)AtIndex
-
- * unix/tclUnixThrd.c: removed {}s around PTHREAD_MUTEX_INITIALIZER
- [Bug: 5254]
-
- * unix/tclLoadDyld.c (TclpLoadFile): removed use of interp->result
-
-2000-04-25 Eric Melski <ericm@scriptics.com>
-
- * unix/mkLinks:
- * doc/AddErrInfo.3: Added information about Tcl_LogCommandInfo
- [Bug: 1818].
-
-2000-04-24 Eric Melski <ericm@scriptics.com>
-
- * unix/mkLinks:
- * doc/OpenFileChnl.3: Added man entry for Tcl_Ungets [Bug: 1834].
-
- * unix/mkLinks:
- * doc/SourceRCFile.3: Man page for Tcl_SourceRCFile [Bug: 1833].
-
- * unix/mkLinks:
- * doc/ParseCmd.3: Added documentation for Tcl_ParseVar [Bug: 1828].
-
-2000-04-24 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tclUnixNotfy.c (Tcl_FinalizeNotifier, NotifierThreadProc):
- added write of 'q' into triggerPipe for notifier in threaded case, so
- that Tcl doesn't hang when children are still running [Bug: 4139]
-
- * unix/tclUnixThrd.c (Tcl_MutexLock): minor comment fixes.
-
-2000-04-23 Jim Ingham <jingham@cygnus.com>
-
- These changes make some error handling marginally better for Mac
- sockets. It is still somewhat flakey, however.
-
- * mac/tclMacSock.c (TcpClose): Add timeouts to the close - these don't
- seem to be honored, however. Use a separate PB for the release, since
- an async connect socket will still be using the original buffer. Make
- sure TCPRelease returns noErr before freeing the recvBuff. If the call
- returns an error, then the buffer is not right.
- * mac/tclMacSock.c (CreateSocket): Add timeouts to the async create.
- These don't seem to trigger, however. Sigh...
- * mac/tclMacSock.c (WaitForSocketEvent): If an TCP_ASYNC_CONNECT
- socket errors out, then return EWOULDBLOCK & error out.
- * mac/tclMacSock.c (NotifyRoutine): Added a NotifyRoutine for
- experimenting with MacTCP.
-
-2000-04-22 Jim Ingham <jingham@cygnus.com>
-
- * library/package.tcl (tclPkgUnknown): Fixed a typo in the Mac package
- search part of tclPkgUnknown.
-
-2000-04-21 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Fixed a newly introduced bug where if
- there's a -command callback and something goes wrong, geturl threw an
- exception, called the callback, and unset the token. I changed it so
- that it will not call the callback when throwing an exception (so the
- caller only finds out about a given error from one place). Also,
- fixed http::ncode so that it actually gives you back the http return
- code (i.e. 200, 404, etc.) instead of the first digit of the version
- of HTTP being used (i.e. 1).
-
-2000-04-21 Brent Welch <welch@scriptics.com>
-
- * library/http2.1/http.tcl: More thrashing with the "server closes
- without reading post data" scenario. Reverted to the previous fileevent
- configuratiuon, which seems to work better with small amounts of post
- data.
-
-2000-04-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclAlloc.c: wrapped caddr_t define to not be done on Unix
- * unix/tclUnixPort.h: added Tclp*Alloc defines to allow the use of
- USE_TCLALLOC on Unix. [Bug: 4731]
-
-2000-04-19 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/dde1.1/pkgIndex.tcl:
- * library/reg1.0/pkgIndex.tcl:
- * win/tclWinChan.c:
- * win/tclWinThrd.c: converted CRLF to LF the */tcl.hpj.in files were
- not converted, as it confuses hcw locally. [Bug: 5096]
-
- * win/Makefile.in: expanded cleanup target for help files
-
- * doc/Thread.3: minor macro cleanup
-
- * generic/tclFileName.c (SplitUnixPath): added support for QNX node
- ids.
-
-2000-04-18 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
- * win/README.binary: bumped version to 8.3.1
-
- * win/tcl.hpj.in: updated copyright date
-
- * generic/tclEnv.c: environment support for Mac OS/X
- * unix/tclUnixPort.h: environment support for Mac OS/X
- * unix/tclLoadDyld.c: new file for Mac OS/X dl functions
- * unix/Makefile.in: added install-strip target; bindir, libdir,
- mandir, includedir vars; tclLoadDyld.c target [Bug: 2527]
-
- * unix/tclUnixChan.c (CreateSocket): force a socket back into blocking
- mode (default state) after a -async connect succeeds. [Bug: 4388]
-
- * generic/tclEvent.c (TclInitSubsystems): Moved tclLibraryPath to
- thread-local storage to prevent thread-related race condition.
- [Bug: 5033]
- * unix/tclAppInit.c (main): removed #ifdef TCL_TEST that sets the
- library path as it was unnecessary and conflicts with move of
- tclLibraryPath to thread-local storage.
-
-2000-04-18 Scott Redman <redman@scriptics.com>
-
- * win/Makefile.in:
- * win/tcl.rc:
- * win/tclsh.rc:
- * win/tclsh.ico: Modified copyright dates in Windows resource files.
- Added an icon for tclsh.exe.
-
-2000-04-17 Brent Welch <welch@scriptics.com>
-
- * generic/tcl.h, generic/tclThreadTest.c, unix/tclUnixThrd.c,
- * win/tclWinThread.c, mac/tclMacThread.c: Added Tcl_CreateThreadType
- and TCL_RETURN_THREAD_TYPE macros for declaring the NewThread callback
- proc.
-
-2000-04-14 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tclUnixChan.c (TtyParseMode): Only allow setting mark/space
- parity on platforms that support it [Bug: 5089]
-
- * generic/tclBasic.c (Tcl_GetVersion): adjusted use of major/minor to
- not conflict with global decl on some systems [Bug: 2882]
-
- * doc/AppInit.3:
- * doc/Async.3:
- * doc/BackgdErr.3:
- * doc/CrtChannel.3:
- * doc/CrtInterp.3:
- * doc/CrtMathFnc.3:
- * doc/DString.3:
- * doc/Eval.3:
- * doc/ExprLong.3:
- * doc/GetInt.3:
- * doc/GetOpnFl.3:
- * doc/Interp.3:
- * doc/LinkVar.3:
- * doc/OpenFileChnl.3:
- * doc/OpenTcp.3:
- * doc/PkgRequire.3:
- * doc/RecordEval.3:
- * doc/SetResult.3:
- * doc/SplitList.3:
- * doc/StaticPkg.3:
- * doc/TraceVar.3:
- * doc/Translate.3:
- * doc/UpVar.3:
- * doc/load.n: removed or updated references to interp->result use.
-
-2000-04-13 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/regexp.n: doc clarification [Bug: 5037]
- * doc/update.n: typo fix [Bug: 4996]
-
- * unix/tcl.m4 (SC_ENABLE_THREADS): enhanced the detection of
- pthread_mutex_init [Bug: 4359] and (SC_CONFIG_CFLAGS) added
- --enable-64bit-vis switch for Sparc VIS compilation [Bug: 4995]
-
-2000-04-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/dde.n: corrected dde poke docs. [Bug: 4991]
-
-2000-04-11 Eric Melski <ericm@scriptics.com>
-
- * win/tclWinPipe.c: Added "CONST" keyword to declaration of char
- *native in TclpCreateTempFile, to supress compiler warnings.
-
-2000-04-10 Brent Welch <welch@scriptics.com>
-
- * generic/tcl.h: Fixed Tcl_CreateThread declaration.
- * library/tcltest1.0/tcltest.tcl: Fixed the "mainThread"
- initialization to work with either testthread or the thread extension
- * unix/tclUnixThrd.c: Fixed compiler warning when compiling with
- -DTCL_THREADS
-
-2000-04-10 Eric Melski <ericm@scriptics.com>
-
- * win/tclWinPipe.c (TclpCreateTempFile): Added conversion of contents
- string from UTF to native encoding [Bug: 4030].
-
- * tests/regexp.test: Added tests for infinite looping in [regexp
- -all].
-
- * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all]
- [Bug: 4981].
-
- * tests/*.test: Changed all occurrences of "namespace import
- ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948].
-
-2000-04-09 Brent Welch <welch@scriptics.com>
-
- * lib/httpd2.1/http.tcl: Worked on the "server closes before reading
- post data" case, which unfortunately causes different error cases on
- Solaris, which can read the reply, and Linux and Windows, which cannot
- read anything. This is all in the loop-back case - client and server
- on the same host. Also unified the error handling so the "ioerror"
- status goes away and errors are reflected in a more uniform way.
- Updated the man page to document the behavior.
-
-2000-04-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/reg.test (matchexpected): corrected tests to use tcltest
- constraint types to skip certain tests.
-
- * generic/tclBasic.c (Tcl_SetCommandInfo): comment fix
-
- * unix/tclUnixThrd.c (Tcl_CreateThread): moved TCL_THREADS ifdef
- inside of func as it is declared for non-threads builds as well. In
- the non-threads case, it always returns TCL_ERROR (couldn't create
- thread).
-
-2000-04-08 Andreas Kupries <a.kupries@westend.com>
-
- * Overall change: Definition of a public API for the creation of
- new threads.
-
- * generic/tclInt.h (line 1802f): Removed the definition of
- 'TclpThreadCreate'. (line 793f) Removed the definition of
- 'Tcl_ThreadCreateProc'.
-
- * generic/tcl.h (line 388f): Readded the definition of
- 'Tcl_ThreadCreateProc'. Added Win32 stuff send in by David Graveraux
- <davygrvy@bigfoot.com> to that too (__stdcall, ...). Added macros for
- the default stacksize and allowed flags.
-
- * generic/tcl.decls (line 1356f): Added definition of
- 'Tcl_CreateThread', slot 393 of the stub table. Two new arguments in
- the public API, for stacksize and flags.
-
- * win/tclWinThrd.c:
- * mac/tclMacThrd.c: Renamed TclpThreadCreate to Tcl_CreateThread,
- added handling of the stacksize. Flags are currently ignored.
-
- * unix/tclUnixThrd.c: See above, but handles joinable flag. Ignores
- the specified stacksize if the macro HAVE_PTHREAD_ATTR_SETSTACKSIZE is
- not defined.
-
- * generic/tclThreadTest.c (line 363): See below.
-
- * unix/tclUnixNotfy.c (line 210): Adapted to the changes above. Uses
- default stacksize and no flags now.
-
- * unic/tcl.m4 (line 382f): Added a check for
- 'pthread_attr_setstacksize' to detect platforms not implementing this
- feature of pthreads. If it is implemented, configure will define the
- macro HAVE_PTHREAD_ATTR_SETSTACKSIZE (See unix/tclUnixThrd.c too).
-
- * doc/Thread.3: Added Tcl_CreateThread and its arguments to the list
- of described functions. Removed stuff about not providing a public
- C-API for thread-creation.
-
-2000-04-07 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/binary.n: clarified docs on sign extension in binary scan [Bug:
- 3466]
-
- * library/tcltest1.0/tcltest.tcl (initConstraints): removed win32s
- references (no longer supported)
-
- * tests/fCmd.test: marked test 8.1 knownBug because it is dangerous on
- poorly configured systems [Bug: 3881] and added 8.2 to keep essence of
- 8.1 tested.
-
-2000-04-05 Andreas Kupries <a.kupries@westend.com>
-
- * generic/tclIO.c (Tcl_UnstackChannel, line 1831): Forcing interest
- mask to the correct value after an unstack and re-initialization of
- the notifier via the watchProc. Without this the first fileevent after
- an unstack will come through and be processed, but no more. [Bug: ??].
-
-2000-03-04 Brent Welch <welch@scriptics.com>
-
- * {win,unix}/Makefile.in: added dependency of tclStubInit.c on
- tcl.decls and tclInt.decls
- * generic/tclThread.c: Tweak so this compiles w/out TCL_THREADS
- * generic/{tcl.decls,tclStubInit.c}: Just touched the tcl.decls and
- regenerated the tclStubInit.c file
-
-2000-03-29 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: For the -querychannel option, fconfigure
- the socket to be binary so that we don't translate anything while
- reading the data. This is because we determine the content length of
- the data on the channel by using seek (to the end of the file) and
- tell on the file handle, and we need the content-length to match the
- amount of data actually sent, and translation can affect the number of
- bytes posted.
-
-2000-04-03 Andreas Kupries <a.kupries@westend.com>
-
- * Overall change: Definition of public API's for the finalization of
- conditions and mutexes. [Bug: 4199].
-
- * generic/tclInt.h: Removed definitions of TclFinalizeMutex and
- TclFinalizeCondition.
-
- * generic/tcl.decls: Added declarations of Tcl_MutexFinalize and
- Tcl_ConditionFinalize.
-
- * generic/tclThread.c: Renamed TclFinalizeMutex to Tcl_MutexFinalize.
- Renamed TclFinalizeCondition to Tcl_ConditionFinalize.
-
- * generic/tclNotify.c: Changed usage of TclFinalizeMutex to
- Tcl_MutexFinalize.
-
- * unix/tclUnixNotfy.c:
- * generic/tclThreadTest.c: Changed usages of TclFinalizeCondition to
- Tcl_ConditionFinalize.
-
- * generic/tcl.h: Added empty macros for Tcl_MutexFinalize and
- Tcl_ConditionFinalize, to be used when the core is compiled without
- threads.
-
- * doc/Thread.3: Added description the new API's.
-
-2000-04-03 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCmdIL.c (InfoVarsCmd): checked for non-NULL procPtr to
- prevent itcl info override crash [Bug: 4064]
-
- * tests/foreach.test:
- * tests/namespace.test:
- * tests/var.test: Added lsorts to avoid random sorted return
- problems. [Bug: 2682]
-
- * tests/fileName.test: fixed 14.1 test fragility [Bug: 1482]
-
- * tools/man2help2.tcl: fixed winhelp cross-linking error [Bug: 4156]
- improved translation to winhelp [Bug: 3679]
-
- * unix/Makefile.in (MAN_INSTALL_DIR): patch to accept --mandir
- correctly [Bug: 4085]
-
- * unix/dltest/pkg[a-e].c: Cleaned up test packages [Bug: 2293]
-
-2000-04-03 Eric Melski <ericm@scriptics.com>
-
- * unix/tclUnixFCmd.c (SetGroupAttribute):
- * unix/tclUnixFCmd.c (SetOwnerAttribute): Added (uid_t) and (gid_t)
- casts to avoid compiler warnings.
-
-2000-03-31 Eric Melski <ericm@scriptics.com>
-
- * generic/tclGet.c (Tcl_GetDouble): Added additional conditions to
- error test (previously only errno was checked, but the return value of
- strtod() should be checked as well). [Bug: 4118]
-
- * tests/exec.test: Added test for proper conversion of UTF data when
- used with "<< $dataWithUTF" on exec's.
-
- * unix/tclUnixPipe.c (TclpCreateTempFile): Added
- Tcl_UtfToExternalDString call, so that if there is UTF content in the
- string it will be properly converted to the system encoding before
- being written [Bug: 4030].
- (TclpCreateTempFile): Added a check on the return value of tmpnam;
- some systems (Linux, for example) will start to return NULL after
- tmpnam has been called TMP_MAX times; not checking for this can have
- bad results (overwriting temp files, core dumps, etc.)
-
-2000-03-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Added comments
- noting the need to pair ckalloc with ckfree. [Bug: 4262]
-
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * win/tclWin32Dll.c: removed TclWinSynchSpawn (vestige of Win32s
- support).
-
- * win/tclWinReg.c: made use of TclWinGetPlatformId instead of getting
- info again
-
- * win/tclWinPort.h:
- * win/Makefile.in:
- * win/configure.in:
- * win/tcl.m4: Added support for gcc/mingw on Windows [Bug: 4234]
-
-2000-03-29 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCompile.c (TclCleanupByteCode): made ByteCode cleanup
- more aware of TCL_BYTECODE_PRECOMPILED flagged structs (gen'd by
- tbcload), to correctly clean them up.
-
- * generic/tclClock.c (FormatClock): moved check for empty format
- earlier, commented 0 result return value
-
-2000-03-29 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Removed an unnecessary fileevent statement
- from the error processing part of the Write method. Also, fixed two
- potential memory leaks in wait and reset, in which the state array
- wasn't being unset before throwing an exception. Prior to this
- version, Brent checked in a fix to catch a fileevent statement that
- was sometimes causing a stack trace when geturl was called with
- -timeout. I believe Brent's fix is necessary because TLS closes bad
- sockets for secure connections, and the fileevent was trying to act on
- a socket that no longer existed.
-
-2000-03-27 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/httpd: removed unnecessary 'puts stderr "Post Dispatch"'
-
- * tests/namespace.test:
- * generic/tclNamesp.c (Tcl_Export): added a uniq'ing test to the
- export list so only one instance of each export pattern would exist in
- the list.
-
- * generic/tclExecute.c (TclExecuteByteCode): optimized case for the
- empty string in ==/!= comparisons
-
-2000-03-27 Eric Melski <ericm@scriptics.com>
-
- * unix/tclUnixChan.c: Added (off_t) type casts in lseek() call [Bug:
- 4409].
-
- * unix/tclLoadAout.c:
- * unix/tclUnixPipe.c: Added (off_t) type casts in lseek() calls [Bug:
- 4410].
-
-2000-03-22 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Fixed a bug where string query data that
- was bigger than queryblocksize would get duplicate characters at block
- boundaries.
-
-2000-03-22 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Fixed bug 4463, where we were getting a
- stack trace if we tried to publish a project to a good host but a port
- where there was no server listening. It turned out the problem was a
- stray fileevent that needed to be cleared. Also, fixed a bug where
- http::code could stack trace if called on a bad token (one which
- didn't represent a successful geturl) by adding an http element to the
- state array in geturl.
-
-2000-03-21 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Modified some tests that were not robust with
- respect to the time zone in which they were run and were thus failing.
-
- * doc/clock.n: Clarified meaning of -gmt with respect to -base when
- used with [clock scan] (-gmt does not affect the interpretation of
- -base).
-
-2000-03-19 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: geturl used to throw an exception when the
- connection failed; I accidentally returned a token with the error
- info, breaking backwards compatibility. I changed it back to throwing
- an exception, but unsetting the state array first (thus still
- eliminating the original memory leak problem).
-
-2000-03-19 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Added -querychannel option and altered
- some of Brent's modifications to allow asynchronous posts (via
- -command). Also modified -queryprogress so that it calls the query
- callback as <callback> <token> <total size> <current size> to be
- consistent with -progress. Added -queryblocksize option with default
- 8192 bytes for post blocksize. Fixed a bunch of potential memory leaks
- for the case when geturl receives bad args or can't open a socket,
- etc. Overall, the package really rocks now.
-
- * doc/http.n: Added -queryblocksize, -querychannel, and
- -queryprogress. Also, changed the description of -blocksize, which
- states that the -progress callback will be called for each block, to
- now qualify that with an "if -progress is specified".
-
- * tests/http.test: Added a querychannel test for synchronous and
- asynchronous posts, altered the queryprogress test such that the
- callback conforms to the -progress format. Also, had to use the
- -queryblocksize option to do the post 16K at a time to match Brent's
- expected results (and to test that -queryblocksize works).
-
-2000-03-15 Brent Welch <welch@scriptics.com>
-
- * library/http2.1/http.tcl: Added -queryprogress callback to
- http::geturl and also changed it so that writing the post data is
- event driven if the queryprogress callback or a timeout is given.
- This allows a timeout to occur when writing lots of post data. The
- queryprogress callback is called after each block of query data is
- posted. It has the same signature as the -progress callback.
-
-2000-03-06 Eric Melski <ericm@scriptics.com>
-
- * library/package.tcl: Applied patch from Bug: 2570; rather than
- setting geometry of slave interp to 0x0 when Tk was loaded, it now
- does "wm withdraw .". Both remove the main window from the display,
- but the former caused some internal structures to get initialized to
- zero, which caused crashes with some extensions.
-
-2000-03-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/package.tcl (tclPkgUnknown): extended to allow recognizes
- changes in the auto_path while sourcing in other pkgIndex.tcl files
-
- * doc/FindExec.3: fixed doc for declaration of Tcl_FindExecutable
- [Bug: 4275]
-
- * generic/tclFileName.c (Tcl_TranslateFileName): Applied patch from
- Newman to significantly speedup file split/join on Windows (replaces
- regexp with custom parser). [Bug: 2867]
-
- * win/README.binary: change mailing lists from @consortium.org to
- @scriptics.com [Bug: 4173]
-
-2000-02-28 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added test for ISO bases < 100000
-
- * generic/tclDate.c: (generated on Solaris)
- * generic/tclGetDate.y: Changed condition for deciding if a number is
- an ISO 8601 base from number >= 100000 to numberOfDigits >= 6.
- Previously it would fail to recognize 000000 as an ISO base.
-
-2000-02-14 Eric Melski <ericm@scriptics.com>
-
- * unix/Makefile.in: Added rpm target to generate Tcl binary RPM.
-
- * unix/tcl.spec: RPM specification file for a Tcl binary RPM for
- Linux.
-
-2000-02-10 Jeff Hobbs <hobbs@scriptics.com>
-
- 8.3.0 RELEASE
-
- * changes: updated for 8.3.0 release
-
- * doc/load.n: added notes about dll load errors on Windows
-
- * unix/README:
- * unix/Makefile.in (dist): removed porting.notes and porting.old from
- distribution and CVS. The information was very outdated. Now refer to
- http://dev.scriptics.com/services/support/platforms.html
-
- * tests/unixInit.test: fixed japanese LANG encoding test [Bug: 3549]
-
- * unix/configure.in:
- * unix/tcl.m4: correct CFLAG_WARNING setting, fixed gcc config for
- AIX, added -export-dynamic to LDFLAGS for FreeBSD-3+ [Bug: 2998]
-
- * win/tclWinLoad.c (TclpLoadFile): improved error message for load
- failures, could perhaps be even more intelligent.
-
-2000-02-09 Jim Ingham <jingham@cygnus.com>
-
- * mac/tclMacSock.c: Don't panic when you get an error closing an async
- socket. This doesn't seem to hurt anything, and we return the error so
- the caller can do the right thing.
-
- New Files:
- * mac/MW_TclHeader.h:
- * mac/MW_TclTestHeader.h:
- * mac/MW_TclTestHeader.pch:
- * mac/MW_TclAppleScriptHeader.h: More convenient to use .h prefix
- files in the preference panels...
-
- The above are curtesy of Daniel Steffen (steffen@math.mq.edu.au)
-
-2000-02-08 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added tests for "next monthname" constructs.
- * generic/tclDate.c:
- * generic/tclGetDate.y (Message): Added a grammar rule for "next
- monthname" so that we can handle "next january" and similar constructs
- (bug #4146).
-
-2000-02-08 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * win/configure.in:
- * win/README:
- * win/README.binary:
- * generic/tcl.h (TCL_RELEASE_SERIAL): Moved to 8.3.0 patchlevel
-
- * doc/library.n:
- * library/auto.tcl: fixed crufty puts code and docs [Bug: 4122]
-
- * library/tcltest1.0/tcltest.tcl: correctly protected searchDirectory
- list to allow dirnames with spaces
-
- * unix/tcl.m4: changed all -fpic to -fPIC
-
- * generic/tclDecls.h:
- * generic/tcl.decls: change Tcl_GetOpenFile to use decl of 'int
- forWriting' instead of 'int write' to avoid shadowing [Bug: 4121]
-
- * tests/httpold.test: changed test script to source in the httpd
- server procs from httpd instead of having its own set.
-
- * tests/httpd: improved query support in test httpd to handle fix in
- http.tcl. [Bug: 4089 change 2000-02-01]
-
- * unix/README: fixed notes about --enable-shared and add note about
- --disable-shared.
-
-2000-02-07 Eric Melski <ericm@scriptics.com>
-
- * tests/package.test:
- * library/tclIndex:
- * library/package.tcl: Renamed ::package namespace to ::pkg.
-
-2000-02-03 Eric Melski <ericm@scriptics.com>
-
- * doc/Package.n:
- * doc/packagens.n: Renamed Package.n -> packagens.n because Windows
- can't deal with case-sensitive names.
-
-2000-02-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/regexp.test: added tests for -all and -inline switches
- * doc/regexp.n: added docs for -all and -inline switches
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): added extra comments for new
- -all and -inline switches to regexp command
-
-2000-02-01 Eric Melski <ericm@scriptics.com>
-
- * library/init.tcl: Applied patch from rfe 1734 regarding auto_load
- errors not setting error message and errorInfo properly.
-
-2000-02-01 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/Makefile.in (install-*): reduced verbosity of install
-
- * generic/tclFileName.c (Tcl_JoinPath): improved support for special
- QNX node id prefixes in pathnames [Bug: 4053]
-
- * library/http1.0/http.tcl:
- * library/http2.1/http.tcl: The query data POSTed was newline
- terminated when it shouldn't be altered [Bug: 4089]
-
-2000-01-31 Eric Melski <ericm@scriptics.com>
-
- * tests/package.test:
- * library/tclIndex:
- * library/package.tcl: Added ::package namespace and ::package::create
- function.
-
- * library/init.tcl: Fixed problem with auto_load and determining if
- commands were loaded.
-
- * library/auto.tcl: "Fixed" issues with $ in files to be auto indexed.
-
- * doc/Package.n: New man page for package::create function.
-
- * doc/pkgMkIndex.n: Added additional information.
-
- * doc/library.n: Added additional qualification regarding auto_mkindex.
-
-2000-01-28 Eric Melski <ericm@scriptics.com>
-
- * tests/pkg/magicchar2.tcl:
- * tests/autoMkindex.test: Test for auto loader fix (bug #2480).
-
- * library/init.tcl: auto_load was using [info commands $name] to
- determine if a given command was available; if the command name had *
- or [] it, this would fail because info commands uses glob-style
- matching. This is fixed. (Bug #2480).
-
- * tests/pkg/spacename.tcl:
- * tests/pkgMkIndex.test: Tests for fix for bug #2360.
-
- * library/package.tcl: Fixed to extract only the first element of the
- list returned by auto_qualify (bug #2360).
-
- * tests/pkg/magicchar.tcl:
- * tests/autoMkindex.test: Test for fix for bug #2611.
-
- * library/auto.tcl: Fixed the regular expression that performs $
- escaping before sourcing a file to index. It was erroneously adding \
- escapes even to $'s that were already escaped, effectively
- "unescaping" those $'s. (bug #2611).
-
-2000-01-27 Eric Melski <ericm@scriptics.com>
-
- * tests/autoMkindex.test:
- * library/auto.tcl: Applied patch (with slight modification) from bug
- #2701: auto_mkIndex uses platform dependent file paths. Added test for
- fix.
-
-2000-01-27 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Changed NormalizePath to
- normalizePath and exported it as a public proc. This proc creates an
- absolute path given the name of the variable containing the path to
- modify. The path is modified in place.
- * library/tcltest1.0/pkgIndex.tcl: Added normalizePath.
- * tests/all.tcl: Changed code to use normalizePath.
-
-2000-01-27 Eric Melski <ericm@scriptics.com>
-
- * tests/pkg/samename.tcl: test file for bug #1983
-
- * tests/pkgMkIndex.test:
- * doc/pkgMkIndex.n:
- * library/package.tcl: Per rfe #4097, optimized creation of direct
- load packages to bypass computing the list of commands added by the
- new package. Also made direct loading the default, and added a -lazy
- option.
- Fixed bug #1983, dealing with pkg_mkIndex incorrectly handling
- situations with two procs by the same name but in different namespaces
- (ie, foo::baz and bar::baz).
-
-2000-01-26 Eric Melski <ericm@scriptics.com>
-
- * generic/tclNamesp.c: Undid fix for #956, which broke backwards
- compatibility.
-
- * doc/variable.n:
- * doc/trace.n:
- * doc/namespace.n:
- * doc/info.n: Added further information about differences between
- "namespace which" and "info exists".
-
- * doc/SetErrno.3: Added descriptions of ErrnoId() and ErrnoMsg()
- functions.
-
-2000-01-25 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tcl.m4: modified EXTRA_CFLAGS to add -DHAVE_TZSET for OSF1-V*
- and ULTRIX-4.* when not using gcc. Also added higher min stack size
- for OSF1-V* when building with threads. [Bug: 4063]
-
- * generic/tclClock.c (FormatClock): inlined resultPtr, as it
- conflicted with var creation for HAVE_TZSET #def [Bug: 4063]
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): fixed potential leak when
- calling lsort -command with bad command [Bug: 4067]
-
- * generic/tclFileName.c (Tcl_JoinPath): added support for special QNX
- node id prefixes in pathnames [Bug: 4053]
-
- * doc/ListObj.3: clarified Tcl_ListObjGetElements docs [Bug: 4080]
-
- * doc/glob.n: clarified Mac path separator determination docs.
-
- * win/makefile.vc: added some support for building helpfile on Windows
-
-2000-01-23 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/init.tcl (auto_execok): added 'start' to list of recognized
- built-in commands for COMSPEC on NT. [Bug: 2858]
-
- * unix/tclUnixPort.h: moved include of <utime.h> lower since some
- systems (UTS) require sys/types.h to be included first [Bug: 4031]
-
- * unix/tclUnixChan.c (CreateSocketAddress): changed comparison with -1
- to 0xFFFFFFFF, to ensure 32 bit comparison even on 64 bit systems.
- [Bug: 3878]
-
- * generic/tclFileName.c: improved guessing of path separator for the
- Mac. (Darley)
-
- * generic/tclInt.h:
- * generic/tcl.decls: moved Tcl_ProcObjCmd to stubs table [Bug: 3827]
- and removed 'register' from stub definition of
- Tcl_AppendUnicodeToObj [Bug: 4038]
-
-2000-01-21 Eric Melski <ericm@scriptics.com>
-
- * unix/mkLinks:
- * doc/GetHostName.3: Man page for Tcl_GetHostName (bug #1817).
-
- * doc/lreplace.n: Corrected man page with respect to treatment of
- empty lists, and "prettied up" the page. (bug #1705).
-
-2000-01-20 Eric Melski <ericm@scriptics.com>
-
- * tests/namespace.test: Added test for undefined variables with
- namespace which (bug #956).
-
- * generic/tclNamesp.c: Added check for undefined variables in
- NamespaceWhichCmd (bug #956).
-
- * tests/var.test: Added tests for corrected variable behavior (bug
- #981).
-
- * doc/upvar.n: Expanded explanation of upvar behavior with respect to
- variable traces. (bugs 3917 1433 2110).
-
- * generic/tclVar.c: Changed behavior of variable command when name
- refers to an element in an array (ie, "variable foo(x)") to always
- return an error, regardless of existence of that element in the array
- (now behavior is consistant with docs too) (bug #981).
-
-2000-01-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCmdIL.c (InfoBodyCmd): made [info body] return a string
- if the body has been bytecompiled.
- * generic/tclBasic.c (Tcl_EvalObjEx): added pedantic check for
- originating proc body of bytecompiled code, #def'd out as the change
- for [info body] should make it unnecessary
-
- * unix/tclUnixNotfy.c (Tcl_InitNotifier): added cast for tsdPtr
-
- * tests/set.test: added test for complex array elem name compiling
- * generic/tclCompCmds.c (TclCompileSetCmd): Fixed parsing of array
- elements during compiling, and slightly optimised same [Bug: 3889]
-
- * doc/tclvars.n: added definitions for tcl_(non)wordchars
-
- * doc/vwait.n: added notes about requirement for vwait var being
- globally scoped [Bug: 3329]
-
- * library/word.tcl: changed tcl_(non)wordchars settings to use new
- unicode regexp char class escapes instead of char sequences
-
-2000-01-14 Eric Melski <ericm@scriptics.com>
-
- * tests/var.test: Added a test for the array multiple delete
- protection in Tcl_UnsetVar2.
-
- * generic/tclVar.c: Added protection in Tcl_UnsetVar2 against attempts
- to multiply delete arrays when unsetting them (bug #3453). This could
- happen if there was an unset trace on an array element and the trace
- proc made a global or upvar link to the array, and then the array was
- unset at the global level. See the bug reference for more information.
-
- * unix/tclUnixTime.c: New clock format format.
-
- * compat/strftime.c: New clock format format.
-
- * generic/tclGetDate.y: New clock scan format.
-
-2000-01-13 Jeff Hobbs <hobbs@scriptics.com>
-
- * changes: updated changes file to reflect 8.3b2 mods
-
- * README:
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.m4:
- * win/README.binary:
- * win/configure.in: updated to patchlevel 8.3b2
-
- * generic/regexec.c: added var initialization to prevent compiler
- warning
-
-2000-01-13 Eric Melski <ericm@scriptics.com>
-
- * tests/cmdIL.test: Added tests for lsort -dictionary with characters
- that occur between Z and a in ASCII.
-
- * generic/tclCmdIL.c: Modified DictionaryCompare function (used by
- lsort -dictionary) to do upper/lower case equivalency before doing
- character comparisons, instead of after. This fixes bug #1357, in
- which lsort -dictionary [list ` AA c CC] and lsort -dictionary [list
- AA c ` CC] gave different (and both wrong) results.
-
-2000-01-12 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added tests for "next <day-of-week>" and
- "<day-of-week>"
- Added tests for "monday 1 week ago", etc, from RFE #3671.
-
- * doc/tests/clock.test: Added numerous tests for clock scan.
-
- * doc/generic/tclGetDate.y: Fixed some shift/reduce conflicts in clock
- grammar.
-
- * doc/doc/clock.n: Added documentation for new supported clock scan
- formats and additional explanation of daylight savings time correction
- algorithm.
-
-2000-01-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/file.n:
- * tests/unixFCmd.test:
- * unix/tclUnixFCmd.c: added support for symbolic permissions setting
- in SetPermissionsAttribute (file attr $file -perm ...) [Bug: 3970]
-
- * generic/tclClock.c: fixed support for 64bit handling of clock values
- [Bug: 1806]
-
- * generic/tclThreadTest.c: upped a buffer size to hold double
-
- * tests/info.test:
- * generic/tclCmdIL.c: fixed 'info procs ::namesp::*' behavior (Dejong)
-
- * generic/tclNamesp.c: made imported commands also import their
- compile proc [Bug: 2100]
-
- * tests/expr.test:
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/tcl.m4: recognize strtod bug on Tru64 v5.0 [Bug: 3378] and
- added tests to prevent unnecessary chmod +x in sources while
- installing, as well as more intelligent setsockopt/gethostbyname
- checks [Bug: 3366, 3389]
-
- * unix/tclUnixThrd.c: added compile time support (through use of the
- TCL_THREAD_STACK_MIN define) for increasing the default stack size for
- a thread. [Bug: 3797, 1966]
-
-2000-01-11 Eric Melski <ericm@scriptics.com>
-
- * generic/tclGetDate.y: Added comments for the Convert function. Added
- a fix for daylight savings time handling for relative time spans of
- days, weeks or fortnights. (bug 3441, 3868).
-
- * generic/tclDate.c: Fixed compiler warning issues.
-
-2000-01-10 Jeff Hobbs <hobbs@scriptics.com>
-
- * compat/waitpid.c: use pid_t type instead of int [Bug: 3999]
-
- * tests/utf.test: fixed test that allowed \8 as octal value
- * generic/tclUtf.c: changed Tcl_UtfBackslash to not allow non-octal
- digits (8,9) in \ooo substs. [Bug: 3975]
-
- * generic/tcl.h: noted need to change win/tcl.m4 and
- tools/tclSplash.bmp for minor version changes
-
- * library/http2.1/http.tcl: trim value for $state(meta) key
-
- * unix/tclUnixFile.c: fixed signature style on functions
-
- * unix/Makefile.in: made sure tcl.m4 would be installed with dist
-
- * unix/tcl.m4: added ELF support for NetBSD [Bug: 3959]
-
-2000-01-10 Eric Melski <ericm@scriptics.com>
-
- * generic/tclGetDate.y: Added rules for ISO 8601 formats (BUG #847):
- CCYY-MM-DD
- CCYYMMDD
- YY-MM-DD
- YYMMDD
- CCYYMMDDTHHMMSS
- CCYYMMDD HHMMSS
- CCYYMMDDTHH:MM:SS
- Fixed "clock scan <number>" to scan the number as an hour for the
- current day, rather than a minute after 00:00 for the current day
- (bug #2732).
-
-2000-01-07 Eric Melski <ericm@scriptics.com>
-
- * generic/tclClock.c: Changed switch in Tcl_ClockObjCmd to use
- enumerated values instead of constants. (ie, COMMAND_SCAN instead of
- 3).
diff --git a/ChangeLog.2001 b/ChangeLog.2001
deleted file mode 100644
index 5fdff46..0000000
--- a/ChangeLog.2001
+++ /dev/null
@@ -1,3629 +0,0 @@
-2001-12-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/init.tcl: make sure env(COMSPEC) on Windows is executed with
- the right case, as it may otherwise fail inexplicably.
-
-2001-12-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCkalloc.c (MemoryCmd, TclFinalizeMemorySubsystem): Added
- the [memory onexit] command, intended to replace [checkmem].
-
- * doc/DumpActiveMemory.3:
- * doc/memory.n: Updated documentation for [memory] and related
- matters. [Bug 487677]
-
- * mac/tclMacBOAMain.c (Tcl_Main, CheckmemCmd): Removed all the
- machinery for the [checkmem] command that is completely duplicated by
- code in generic/tclCkalloc.c.
-
- * generic/tclBinary.c:
- * generic/tclListObj.c:
- * generic/tclObj.c:
- * generic/tclStringObj.c: Removed references to [checkmem] in
- comments, referencing [memory active] instead, since it is
- documented.
-
-2001-12-28 Daniel Steffen <das@users.sourceforge.net>
-
- * mac/tclMacInit.c:
- * mac/tclMacTclCode.r: synced up tclInit features to unix/win:
- implemented TclSetPreInitScript support, use of existing tclInit proc
- if defined, check of default encoding dir if set. Changed script
- library resource names to lowercase (i.e. same as corresponding
- files). Used Tcl_JoinPath instead of string append. Check that system
- encoding could be loaded before utf translating the LibraryPath.
- * mac/tclMacApplication.r:
- * mac/tclMacLibrary.r:
- * mac/tclMacOSA.r:
- * mac/tclMacResource.r: minor version resources cleanup
-
-2001-12-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
- Search for config file using exec_prefix instead of prefix when no
- --with-tcl or --with-tk argument is used. [Bug 492418]
-
-2001-12-21 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: fixed incorrect SHLIB_LD_LIBS setting for MacOSX /
- Darwin.
- * unix/configure: Regen.
- * unix/mkLinks.tcl: improved case-insensitive filesystem support.
- * unix/mkLinks: Regen.
-
-2001-12-19 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in (dist): corrected use of eolFix.tcl on working
- files. It should operate on distributed files. [Bug 495120]
-
-2001-12-19 David Gravereaux <davygrvy@pobox.com>
-
- * tools/tcl.wse.in: Fix for [Bug 495120]. tcl.wse.in was stored in cvs
- with improper <eol>. This resulted in corrupted <eol> when checked-out
- on translating CVS clients such as windows (CRCRLF) and mac (CRCR).
-
-2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure:
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Update SunOS 5.[0-6] target so that
- correct linker options are passed to gcc or ld. [Tk Bug 220863]
-
-2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/README: Update to account for changes in the unix/dltest
- directory, the way autoconf is run, and the new "make shell" target.
-
-2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Rename dltest to dlpkgs to fix problem where lib
- files were not getting built because dltest/ directory already
- existed.
-
-2001-12-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinSerial.c (SerialCheckProc): corrected time calculations to
- be unsigned. (schroedter)
-
-2001-12-18 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Define new dltest target that simply does a cd to
- dltest/ before running make. There is no need for the separate
- configure script that was previously being used.
- * unix/configure: Regen.
- * unix/configure.in: Subst into dltest/Makefile.
- * unix/dltest/Makefile.in: Define LIBS using DL_LIBS, LIBS, and
- MATH_LIBS variables instead of TCL_LIBS variable from tclConfig.sh.
- * unix/dltest/README: Update readme to account for new configure free
- implementation.
- * unix/dltest/configure: Removed.
- * unix/dltest/configure.in: Removed.
-
-2001-12-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.h (TCL_STUB_MAGIC): Added cast to force type to be an
- int and get rid of a persistent and pointless warning with SunPro
- compiler.
-
- * generic/tclCkalloc.c (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
- * generic/tcl.decls (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
- Made the file parameters to these functions into CONST char *, like
- they always should have been to match the other Tcl*Db* API functions.
-
-2001-12-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * Applied [Bug 219311] on behalf of Rolf Schroedter
- <schroedter@users.sourceforge.net> to prevent fcopy on serial ports
- from flooding the event queue.
-
-2001-12-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/CrtInterp.3:
- * generic/tclBasic.c: docs and comments corrections. [Bug 493412]
- Bug & patch by Don Porter.
-
-2001-12-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * win/tclWinNotify.c (Tcl_FinalizeNotifier): Stop Tcl on Windows from
- crashing when shutdown from a non-Tcl thread. Fixes [Bug 217982]
- [orig. 5804] reported by Hugh Vu and Gene Leache. I'm not convinced
- that the shutdown process is right even with this, but it was
- definitely wrong without...
-
-2001-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinSock.c (TcpGetOptionProc): Fix for [Bug 478565] reported
- by an unknown person. Bypasses all calls to "gethostbyaddr" for
- address "0.0.0.0" to prevent delays on Win/NT.
-
-2001-12-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/Preserve.3: doc'd TCL_DYNAMIC use. [Patch 483989] (porter)
-
-2001-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_GetsObj): Applied patch for [Bug 491341] as
- provided by Don Porter <dgp@users.sourceforge.net>. Fixes the
- assumption of having an empty Tcl_Obj to work with.
-
-2001-12-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c:
- * generic/tclCompile.c:
- * generic/tclExecute.c: consistency patch, to make all instructions
- that pop a variable number of Tcl_Obj's off the execution stack take
- the number of popped objects as first operand. Modified *only* the new
- instructions INST_LIST_INDEX_MULTI and INST_LSET_FLAT, so this has no
- effect on bytecodes generated up to tcl8.4a3 inclusive.
-
- * generic/tclExecute.c: fix debug messages in INST_LSET_LIST.
-
- * generic/tclCompCmds.c (TclCompileLindexCmd):
- * generic/tclCompExpr.c (CompileMathFuncCall): removed the last two
- overestimates of the necessary stack depth for bytecodes in the fix of
- [Bug 483611]
-
-2001-12-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/tclUnixPipe.c (TclpCreateProcess): Applied Don Porter's patch
- fixing [Bug 437489].
-
-2001-12-10 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclEvent.c:
- * tests/event.test: fix background error reporting in the absence of a
- bgerror proc [Bug 219142].
-
-2001-12-10 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Access.3:
- * doc/CrtChannel.3:
- * doc/DString.3:
- * doc/ExprLong.3:
- * doc/FileSystem.3:
- * doc/GetStdChan.3:
- * doc/OpenFileChnl.3:
- * doc/StdChannels.3:
- * doc/TCL_MEM_DEBUG.3:
- * doc/Tcl_Main.3:
- * doc/Utf.3:
- * doc/file.n:
- * doc/tclsh.1: Several typo and formatting corrections discovered
- during conversion to TMML. Thanks to Joe English. [Patch 490514]
- * unix/mkLinks: 'make mklinks'
-
-2001-12-10 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclProc.c: fixed the calculation of the maximal stack depth
- required by bytecodes. [Bug 483611]
-
-2001-12-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c:
- * tests/trace.test: restored consistency in refCount accounting by
- array traces [Bug 4484339], submitted by Don Porter.
-
-2001-12-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/parseExpr.test, tests/for.test, tests/expr.test:
- * tests/expr-old.test, tests/compile.test, tests/compExpr.test
- * tests/compExpr-old.test: Kept up to date with syntax errors.
- * generic/tclParseExpr.c (ParsePrimaryExpr): Rewrote to give even
- better syntax errors in the fairly common case of an identifier
- without decorations by guessing based on the currently available
- functions. Also made messages consistent between memdebug and ordinary
- builds.
-
-2001-12-05 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c:
- * tests/trace.test: new algorithm for [array get], safe when there are
- traces that modify the array. [Bug 449893]
-
-2001-12-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/compExpr-old.test, tests/compExpr.test, tests/compile.test:
- * tests/expr-old.test, tests/expr.test, tests/for.test:
- * tests/while.test, tests/if.test: Rewrite to handle more specific
- syntax errors.
- * tests/parseExpr.test: Rewrite to get rid of dup test numbers and
- handle more specific syntax errors.
- * generic/tclParseExpr.c (LogSyntaxError): Added a detail message
- argument to help explain what the syntax error is.
- (Tcl_ParseExpr, ParseCondExpr, ParsePrimaryExpr): Added detail
- messages.
- (UNKNOWN_CHAR): New lexeme for characters that are always illegal in
- expressions outside strings.
-
-2001-12-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/expr.n: Various documentation improvements in relation to the
- function calls. Includes fix for [Bug 487704] submitted by Devin Eyre.
-
-2001-12-03 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Some install target bugs repaired along with
- $(TCLSTUBLIB) added to the dependencies rather than implicit through
- the dde and reg extensions which don't happen to always require it for
- some build types.
-
-2001-11-30 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c: Tcl_Preserve'ing VarTrace structures to avoid
- memory corruption. Patch for [Bug 484334] provided by Don Porter
-
-2001-11-29 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/namespace.test: modified namespace-41.2, added 41.3
- {knownbug} after discussion with Don Porter and Kevin Kenny.
-
-2001-11-29 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/namespace.test: added namespace-41.2, a simpler test for
- [Bug 231259]
-
-2001-11-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclBinary.c (BINARY_SCAN_MAX_CACHE, Tcl_BinaryObjCmd,
- (ScanNumber): Added caching scheme to reduce number of object
- allocations when doing scans of large repetitive binary strings. See
- comments in file for reasoning behind implementation. Suggested by
- Miguel Sofer in [Patch 429916], but independently implemented.
-
-2001-11-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/regsub.n, doc/regexp.n: Converted dangling references to
- METASYNTAX section into references to the re_syntax manual page.
-
-2001-11-27 D. Richard Hipp <drh@hwaci.com>
-
- * win/tclWinFCmd.c: Fix a coredump in the filename normalizer code for
- Win95/98.
-
-2001-11-27 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Removed the Tk reference for the 'winhelp' target.
- Converge at install will need to be the solution for Tk and all other
- extensions.
-
-2001-11-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdAH.test (cmdAH-24.2): Made test less sensitive to OS
- preemption, but perfection isn't practical. [Bug 463189, reported by
- Don Porter]
-
- * tests/switch.test (switch-9.*): Added tests to exercise more of the
- argument checking. (switch-7.2,switch-7.3): Test changed behaviour
- slightly.
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reworked argument parsing to
- be stricter about what it accepts. This should make uses of the
- [switch] command be more maintainable. [Bug 475397, reported by Don
- Porter]
-
-2001-11-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIntPlatDecls.h: 'make genstubs' after changes in
- 2001-11-23 commit from Daniel Steffen.
-
-2001-11-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Add comments to better describe TCL_EXE and when
- it should be available.
- * win/Makefile.in: Add TCL_EXE variable to be used by rules like `make
- genstubs`. Don't set TCL_LIBRARY before running `make genstubs` since
- we will be running with a tclsh from the PATH not the one we build.
-
-2001-11-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Add comctl32.lib to wish link libs.
- This change was originally added to Tk on 2001-11-09 but was not
- committed to Tcl.
-
-2001-11-23 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/install-sh:
- * unix/mkLinks:
- * unix/mkLinks.tcl:
- * unix/tclLoadDyld.c:
- * unix/tclMtherr.c: Mac OSX support: build system, dynamic code loading
- and support for case-insensitive filesystems in mkLinks. [Patch 435258]
-
-2001-11-23 Daniel Steffen <das@users.sourceforge.net>
-
- Up-port to 8.4 of mac code changes for 8.3.3 & various new changes for
- 8.4, some already backported to 8.3.4. [Patch 435658]
-
- * generic/tclObj.c: added #include to fix missing prototype errors
-
- * generic/tcl.h: MAC_TCL: addition of ConditionalMacros.h and use of
- DLLIMPORT and DLLEXPORT like on other platforms. ( => no longer need
- the .exp files and can remove use of #pragma export that never worked
- well)
- removed line continuation in #if clause as this breaks the mac
- resource compiler (note that *.r files include tcl.h)
-
- * mac/tclMacFile.c: fixed bug in permission checking code
-
- * mac/tclMacLoad.c: corrected utf-8 handling, comparison of package
- names to code fragment names changed to only match on the length of
- package name, this allows for fragment names with version numbers
- appended.
-
- * mac/tclMacInt.h:
- * generic/tclInt.h:
- * mac/tclMacTime.c:
- * generic/tclIOUtil.c: moved declaration of TclpGetGMTOffset()
-
- * mac/tclMacShLib.exp:
- * mac/tclMacOSA.exp:
- * mac/tclMacMSLPrefix.h: removed files
-
- * unix/Makefile.in: removed reference to .exp files
-
- * mac/MW_TclBuildLibHeader.h:
- * mac/MW_TclBuildLibHeader.pch:
- * mac/MW_TclHeaderCommon.h:
- * mac/MW_TclStaticHeader.h:
- * mac/MW_TclStaticHeader.pch: new precompiled header files
-
- * mac/MW_TclAppleScriptHeader.pch:
- * mac/MW_TclHeader.pch:
- * mac/MW_TclTestHeader.pch:
- * mac/tclMacCommonPch.h: revised precompiled header handling: now
- include a common header file 'MW_TclHeaderCommon.h' from all .pch
- files, the .pch files themselves now only setup #defines (e.g.
- BUILD_tcl, STATIC_BUILD, TCL_DEBUG, TCL_THREADS) like in makefiles on
- other platforms.
-
- * mac/tclMac.h:
- * mac/tclMacPort.h:
- * mac/tclMacInt.h: use of BUILD_tcl and TCL_STORAGE_CLASS like on other
- platforms, standardize #include'd files to what's done on other
- platforms, removed use of #pragma export.
-
- * mac/tcltkMacBuildSupport.sea.hqx: new archive of mac build support
- files & suggested build environment directory hierarchy:
- 'Building MacTclTk' & 'CW Pro6 changes' readme's.
- projects for MoreFiles 1.5.2 static & shared libraries.
- project & sources for 'pseudoCarbonSupport', see below.
- included XML versions of the projects for CW Pro5 or Pro7 users.
-
- * mac/tclMacProjects.sea.hqx: updated mac build project files:
- build support for CodeWarrior Pro6, UnivIntf 3.4 & shared runtime
- libraries: the MSL libraries and MoreFiles are no longer compiled into
- Tcl.shlb, all non-static binaries now use the Pro6 shared runtime
- libraries and MoreFiles.shlb. These shlbs are merged into the standard
- Wish and TclShell, but 3rd party applications linking with Tcl.shlb or
- Tk.shlb need to setup access to them. (see the "(sh-ppc)" targets
- for how to do this.)
- included XML versions of the projects for CW Pro5 or Pro7 users.
- use compat/strtod.c instead of MSL's strtod()
- use WASTE versions of MSL for tcl test target to avoid text buffer
- cutoff at 32k.
- Merging the full MSL.shlb and the other shlbs into Wish & TclShell
- makes them a bit larger than before, use unmerged binaries to avoid
- copying the shared code with every application, e.g. when deploying
- numerous Wish based droplets.
- Note that using CW Pro5 to compile extensions is in principle still
- possible, but need to link with Pro6 runtime libraries.
- Tclapplescript now loads and runs on CFM68k.
- Highly experimental "pseudoCarbon" support for Tcl only on OS 8/9:
- binaries in "Build:(Carbon):" link against CarbonLib instead of
- InterfaceLib, however the actual code has not been carbonized! i.e. it
- will not run on OSX and may not even run properly with CarbonLib.
- This should in principle allow you to build & test OS9 CFM Carbon
- binaries that need to link with Tcl.shlb. On OSX you can use the
- native Tcl.framework, but you have to build a MachO binary as there
- is no CFM glue lib for Tcl.framework.
- the library pseudoCarbonSupport.shlb manually loads the symbols from
- InterfaceLib that are not in CarbonLib but are needed by the
- uncarbonized code in Tcl.shlb and TclShell.
-
- * generic/tclMain.c: MAC_TCL: workaround for broken/non-standard isatty
- on MW Pro6, #include <unistd.h> instead of defining isatty
-
- * mac/tclMacPort.h: MW Pro6 changes for MSL fcntl.h, stat.h & isatty
-
- * mac/tclMacAppInit.c: add EXTERN to InstallConsole to enable DLL
- export via the TCL_STORAGE_CLASS mechanism.
-
- * mac/tclMacFCmd.c: fix for FSpDirectoryCopy API change
-
- * mac/tclMacLibrary.c: emit compile time error when
- TCL_REGISTER_LIBRARY and USE_TCL_STUBS are both defined at the same
- time in an extension, this use is not currently supported and will
- result in a crash when dynamically loading the extension.
-
- * mac/tclMacApplication.r:
- * mac/tclMacLibrary.r:
- * mac/tclMacOSA.r:
- * mac/tclMacResource.r: fixed obsolete copyrights/dates in version
- strings; updated version strings to standard usage; added support for
- '(Support Libraries)' subfolder for shared runtime libraries in
- unmerged binaries; commented out demo setting of "Tcl Environment
- Variables"; reorganized resources among these files to avoid multiple
- copies in applications and shared libraries, the script libraries are
- now no longer duplicated in Tclsh but are only included in the
- resources of Tcl.shlb.
-
- * mac/tclMacChan.c:
- * mac/tclMacSock.c: cast for *BlockMode
-
- * mac/tclMacUtil.c:
- * mac/tclMacMath.h: removed obsolete hypot() definition
-
- * generic/tclIntPlatDecls.h:
- * generic/tclInt.decls:
- * generic/tclStubInit.c:
- * mac/tclMacNotify.c:
- * mac/tclMacOSA.c:
- * mac/tclMacUtil.c:
- * generic/tclThreadTest.c: renamed routines conflicting with standard
- Apple or MoreFiles headers (at compile or link time):
- GetGlobalMouse -> GetGlobalMouseTcl
- FSpGetDirectoryID -> FSpGetDirectoryIDTcl
- FSpOpenResFileCompat -> FSpOpenResFileCompatTcl
- FSpCreateResFileCompat -> FSpCreateResFileCompatTcl
- NewThread -> NewTestThread
- the renamed MoreFiles *Tcl routines are just wrappers calling into the
- MoreFiles DLL.
-
- * mac/tclMacCommonPch.h:
- * mac/tclMacThrd.c:
- * mac/tclMacPanic.c: removed OLDROUTINENAMES define, renamed obsolete
- apple API names to modern equivalents; UH3.4 support: added #include
- <ControlDefinitions.h>, updated New*Proc() calls to New*UPP().
-
- * mac/tclMacUnix.c: added missing (Tcl_Obj ***) cast to
- Tcl_ListObjGetElements call
-
- * mac/tclMacAlloc.c: modernized TclpSysAlloc() to use temporary memory
- instead of system heap memory when available (MacOS >= 7.5 and
- possibly earlier, use of system heap has been discouraged for a long
- time and has many disadvantages, e.g. memory isn't paged out, and
- errors can very easily bring the system down); fixed crashing bug in
- TclpSysRealloc() and CleanUpExitProc() where memory was being accessed
- after having been deallocated; fixed memory leak in (de)allocation
- code (for every block ever allocated with TclpSysAlloc, a Ptr was
- leaked), if temporary memory is available, don't track allocated
- memory, instead use RecoverHandle() to get Handle from Ptr, otherwise
- use doubly linked list to correctly track memory and free all
- allocated memory; added new option for ConfigureMemory:
- MEMORY_DONT_USE_TEMPMEM, disables use of temporary memory even when it
- would be available, only necessary when writing e.g. a driver (using
- tcl??); increased fraction of application heap reserved for OS
- routines to 512K
-
- * compat/strftime.c:
- * mac/tclMacTime.c:
- * mac/tclMacPort.h:
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: timezone support for mac via TclpGetTZName()
- like on windows, using an inverse timezone table adapted from
- tclDate.c to map gmtoffset in seconds gotten from the MacOS APIs to a
- timezone string, as there is no good way to get this info from MacOS.
- I had to make up some unusual timezones and arbitrarily decide on the
- most standard of the multiple choices available for every timezone.
-
- * generic/tclExecute.c: workaround for a MSL bug/misfeature: for very
- small floats, MSL can return errno ERANGE but a non-zero value (<
- LDBL_MIN however)
-
- * mac/tclMacAppInit.c: support for WASTE text library using temporary
- memory, setting has no effect if WASTE is not used.
-
- * mac/tclMacPanic.c: removed duplicate code from generic/tclPanic.c
- and added that file to projects instead.
-
- * tests/all.tcl: set tcltest::singleProcess 1 as multiple processes
- are not available on the mac.
-
- * tests/cmdAH.test: access time not available on the mac, skip the
- atime touch test
-
- * tests/appendComp.test:
- * tests/cmdMZ.test:
- * tests/compile.test:
- * tests/exec.test:
- * tests/fileName.test:
- * tests/lset.test:
- * tests/namespace.test:
- * tests/tcltest.test: added missing cleanups/tests/catches that caused
- tests to fail on the mac.
-
- * doc/tclvars.n: doc bug, env(PWD) should be env(HOME) [Bug 463834]
-
-2001-11-21 Don Porter <dgp@users.sourceforge.net>
-
- * tests/trace.test (trace-8.8): Corrected test for Bug 219393.
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken,CallCommandTraces):
- * generic/tclCmdMZ>c (Tcl_UntraceCommand): Added Tcl_Preserve and
- Tcl_Release calls to prevent deletion of CommandTrace structures until
- all callers are done using them, preventing memory corruption. [Bug
- 453805]
-
-2001-11-20 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * doc/GetTime.3 (Tcl_GetTime):
- * generic/tcl.decls (Tcl_GetTime):
- * generic/tclClock.c (Tcl_ClockObjCmd):
- * generic/tclCompile.c (TclCleanupByteCode, TclInitByteCodeObj):
- * generic/tclCmdMZ.c (Tcl_TimeObjCmd):
- * generic/tclUtil.c (TclpGetTime):
- * generic/tclTest.c (GetTimesCmd):
- * generic/tclTimer.c (Tcl_CreateTimerHandler, TimerSetupProc,
- (TimerCheckProc, TimerHandlerEventProc):
- * mac/tclMacNotify.c (Tcl_SetTimer):
- * mac/tclMacShLib.exp (Tcl_GetTime):
- * mac/tclMacTime.c (Tcl_GetTime):
- * unix/tclUnixChan.c (TclUnixWaitForFile):
- * unix/tclUnixEvent.c (Tcl_Sleep):
- * unix/tclUnixThrd.c (Tcl_ConditionWait):
- * unix/tclUnixTime.c (Tcl_GetTime):
- * win/tclWinNotify.c (Tcl_Sleep):
- * win/tclWinTest.c (TestwinclockCmd):
- * win/tclWinTime.c (TclpGetSeconds, TclpGetClicks, Tcl_GetTime):
- Changed all uses of TclpGetTime to Tcl_GetTime. Added Tcl_GetTime to
- the Stubs table and the library documentation. Added a TclpGetTime in
- tclUtil.c for backward compatibility of extensions. [Patch 483500,
- TIP#73]
-
- * generic/tclCmdMZ.c (Tcl_TimeObjCmd): Corrected an error in the
- [time] command that caused incorrect results to be returned if the
- total duration of all iterations exceeded 2**31 microseconds. [Bug
- 478847]
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclStubInit.h: Reran 'make genstubs'
-
-2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c
- * generic/tclCompile.h:
- * generic/tclExecute.c: moving all code relative to bytecodes from
- tclBasic.c to tclExecute.c - the functions RecordTracebackInfo and
- Tcl_ExprObj went to tclExecute.c, and new interface function was
- defined (TclCompEvalObj).
- The final objective of this sequence of moves is to provide a clean,
- clear-cut interface between Tcl's core and the compiler/engine
- subsystem.
-
-2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c
- * generic/tclCompile.h:
- * generic/tclExecute.c: factoring out of common code in tclBasic.c
- (new function TclInterpReady defined: it resets the interp's result,
- then checks that it hasn't been deleted and that the nesting level is
- acceptable). Passed the responsibility of calling it to the *callers*
- of TclEvalObjvInternal.
-
-2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c
- * generic/tclExecute.c: a better variant of the previous-to-last
- commit (restoring numLevels computations). The managing of the levels
- now has to be done by the *callers* of TclEvalObjvInternal
-
-2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: missing variable declaration under
- TCL_COMPILE_DEBUG.
-
-2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c:
- * generic/tclProc.c: restoring the computations of iPtr->numLevels to
- the original logic (previous to buggy modifs on 2001-11-16).
-
-2001-11-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/eolFix.tcl (new-file):
- * unix/Makefile.in: added EOL correction for Windows bat files to
- dist target. [Bug 219409] (davygrvy)
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): update of patch from
- 2001-11-16 that uses the old Tcl encoding check mechanism as a
- fallback to the original. Also added a TCL_DEFAULT_ENCODING #define
- (defaults to iso8859-1). Tcl will first try setlocale and nl_langinfo,
- and if that fails, guess based on certain LANG|LC_* env vars. [Patch
- 418645]
-
-2001-11-19 David Gravereaux <davygrvy@pobox.com>
-
- * win/buildall.vc.bat: Added useful comments.
-
-2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/compile.test: added a test for bug [Bug 483309]
-
-2001-11-19 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFile.c:
- * win/tclWinFCmd.c:
- * win/tclWin32Dll.c:
- * doc/file.n:
- * tests/winFCmd.test: improved speed of file normalization for
- Win95/98, and clarified docs on differences in file normalization
- between NT/2000 and the older operating systems. Added test to ensure
- normalization is correct.
-
-2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c:
- * generic/tclParse.c: Code reorganisation. Moved all evaluation
- functions from tclParse.c to tclBasic.c, so that now tclParse.c deals
- exclusively with parsing and all evaluations are done by code in
- tclBasic.c. The functions moved are: TclEvalObjvInternal,
- Tcl_EvalObjv, Tcl_LogCommandInfo, Tcl_EvalTokensStandard,
- Tcl_EvalTokens, Tcl_EvalEx, Tcl_Eval, Tcl_EvalObj and
- Tcl_GlobalEvalObj.
-
-2001-11-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/trace.test (trace-8.8): Added adapted version of [Bug 219393]
- as new test; the test won't reliably show up the old problem unless it
- is being run under something like Purify, but something is better than
- nothing...
-
- * generic/tclVar.c (Tcl_TraceVar2, Tcl_UntraceVar2): Added missing
- mask bits for trace result type and a check for a nonsense flag
- combination.
- * generic/tclCmdMZ.c (TraceVarProc): Added missing test for NULL when
- deleting a trace that doesn't cause an error.
-
- * doc/TraceVar.3: Added documentation for change due to TIP#68.
-
- * generic/tclCmdMZ.c (TraceVarInfo): Removed problematic errMsg field
- from structure.
- (TraceVarProc): Removed references to errMsg field and changed
- handling of errors so that they returned a Tcl_Obj* containing the
- error string. This minimizes the number of calls to the memory
- management subsystem.
- (TclTraceCommandObjCmd, TraceCommandProc): Removed references to
- errMsg field which was never used in command traces in any case.
- (Tcl_TraceObjCmd, TclTraceVariableObjCmd): Removed references to
- errMsg field and made variable traces register with
- TCL_TRACE_RESULT_OBJECT bit set.
-
- * generic/tcl.h (TCL_TRACE_RESULT_DYNAMIC,TCL_TRACE_RESULT_OBJECT):
- New constants to define how to handle the strings returned from trace
- callbacks [TIP#68]
- * generic/tclVar.c (CallTraces, Tcl_GetVar2Ex, TclGetIndexedScalar,
- (TclGetElementOfIndexedArray, Tcl_SetVar2Ex, TclSetIndexedScalar,
- (TclSetElementOfIndexedArray, Tcl_UnsetVar2, Tcl_ArrayObjCmd,
- (TclDeleteVars, TclDeleteCompiledLocalVars, DeleteArray,
- (TclVarTraceExists): Support for those new trace flags.
-
-2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c: patch for [Bug 483309] (petasis).
-
-2001-11-16 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclListObj.c: removed a C++-style comment that was
- inadvertently left in the source code.
-
-2001-11-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/interp.test:
- * generic/tclInterp.c (SlaveObjCmd): Corrected argument checking for
- '$interp alias|aliases|issafe'. [Patch 479560] (thoyts, hobbs)
-
- * unix/tclUnixInit.c: added HAVE_LANGINFO code block.
- * unix/configure: regened
- * unix/configure.in: added SC_ENABLE_LANGINFO call
- * unix/tcl.m4: made SHLIB_LD_LIBS='${LIBS}' for FreeBSD* (meyer)
- Added modified version of Wagner patch to make use of nl_langinfo
- where possible to determine Unix platform encoding, instead of the
- inflexible built-in system. This is used by default when possible, and
- can be disabled with --enable-langinfo=no. [Patch 418645] (hobbs,
- wagner)
-
-2001-11-16 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclObj.c: moved Tcl_GetCommandFromObj and all defining code
- for tclCmdNameType objects to tclObj.c (from tclExecute.c). This code
- has nothing to do with bytecodes.
-
-2001-11-16 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclParse.c:
- * generic/tclProc.c:
- * tests/stack.test: consolidation of duplicated code (in
- TclExecuteByteCode and EvalObjv); renaming of EvalObjv to TclEvalObjv
- as it is not static anymore; restored consistency of level counts
- between compiled and directly evaled code. [Bug 480896]
-
-2001-11-12 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc:
- * win/rules.vc: Small bug fixes.
-
- * win/README: added some docs pointing to the docs in makefile.vc for
- it's use.
-
-2001-10-17 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * doc/lappend.n:
- * doc/lindex.n:
- * doc/linsert.n:
- * doc/list.n:
- * doc/llength.n:
- * doc/lrange.n:
- * doc/lsearch.n:
- * doc/lset.n (new-file):
- * doc/lsort.n:
- * generic/tclBasic.c (builtInCmds, Tcl_EvalObjEx):
- * generic/tclCmdIL.c (Tcl_LindexObjCmd, Tcl_LindexList):
- (Tcl_LindexFlat, Tcl_LsetObjCmd):
- * generic/tclCompCmds.c (Tcl_CompileLindexCmd, Tcl_CompileLsetCmd):
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclListObj.c (TclLsetList, TclLsetFlat, TclSetListElement):
- * generic/tclObj.c (TclInitObjSubsystem):
- * generic/tclStubInit.c:
- * generic/tclTestObj.c (TestobjCmd):
- * generic/tclUtil.c (TclGetIntForIndex, SetEndOffsetFromAny):
- * generic/tclVar.c (Tcl_LappendObjCmd):
- * tests/lindex.test:
- * tests/lset.test (new-file):
- * tests/lsetComp.test (new-file):
- * tests/obj.test:
- * tests/string.test:
- * tests/stringComp.test:
- Reference implementation of TIP's #22, #33 and #45. Adds the ability
- of the [lindex] command to have multiple index arguments, and adds the
- [lset] command. Both commands are byte-code compiled. [Patch 471874]
- (work by Kenny, commited by Hobbs)
-
-2001-11-12 David Gravereaux <davygrvy@pobox.com>
-
- * win/buildall.vc.bat(new):
- * win/makefile.vc: Small fix with deriving the "OriginalFilename"
- string in the .rc scripts. Added a quick batchfile for building the
- entire thing.
-
-2001-11-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/FileSystem.3:
- * doc/file.n:
- * doc/tcltest.n: converted use of \' to more reasonable format.
-
-2001-11-10 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in:
- * win/Makefile.in: Add "make gdb" target. This target can run tclsh
- inside either gdb or insight.
-
-2001-11-10 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Added a check to make sure one runs the makefile
- from the /win directory only.
-
- * win/mkd.bat:
- * win/rmd.bat: Changes from Llyod Lim for better stability.
- [Patch 456759]
-
-2001-11-09 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc:
- * win/tcl.dsp: winhelp target fixes for non-NT systems. It seems
- NMAKE under these remembers changed directories during commands. A new
- tcltest feature from Peter Spjuth <peter.spjuth@space.se> to specify a
- pattern file from the commandline and redirecting output to a file
- when not under NT with it's scrollback console. Then it replays it,
- piped through more. Added 2 new static "configurations" to tcl.dsp.
- I could keep adding more, but I think we should leave it up to the
- user for customizing it.
-
- Sticky-points left: 'profile' option.
-
-2001-11-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/FileSystem.3:
- * doc/StdChannels.3:
- * doc/file.n:
- * doc/tcltest.n:
- * tools/man2help.tcl:
- * tools/man2help2.tcl: fixed winhelp generation problems
- [Patch 480268]
-
- * unix/configure:
- * unix/tcl.m4: added -lc to AIX libs, fixed path to ldAix
-
-2001-11-09 Don Porter <dgp@users.sourceforge.net>
-
- * tests/var.test:
- * generic/tclVar.c: Corrected bug in [global] when dealing with
- variable names matching :*. [Bug 480176]
-
-2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- Fixup stack size under OSF1. [Patch 474790]
-
- * unix/configure: Regen.
- * unix/tcl.m4: Add HAVE_PTHREAD_ATTR_SETSTACKSIZE define to
- EXTRA_CFLAGS to adjust initial stack size.
-
-2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- Enable thread support under FreeBSD. [Bug 473708]
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_ENABLE_THREADS): Check for pthread functions in
- libc_r and enable thread support if found.
- * unix/dltest/Makefile.in: Set SHLIB_LD_LIBS and use it in the
- Makefile to properly link a shared library.
-
-2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in:
- * unix/dltest/Makefile.in: Avoid adding libc to the LIBS variable
- since it is not needed when linking with CC. If required when linking
- with LD it should be done on a case by case basis in tcl.m4.
-
-2001-11-08 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc:
- * win/makefile.vc: Fixed install target to adjust for the different
- build types. Added a 'linkexten' option to link the win extensions
- inside the shell when built static. Placed win/tclAppInit.c patch in
- SF patch DB for approval. 'profile' option not hooked in yet.
- Everything else know is done.
-
- * win/tcl.dsp(new):
- * win/tcl.dsw(new): Simple MsDev stub project files that calls
- makefile.vc. Will help run Tcl in the debugger easier without
- confusing MsDev for where the .pdb files are.
-
-2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in:
- * win/Makefile.in: Print a message indicating that the user should run
- "make genstubs" when the generated tclStubInit.c file is out of date.
- We can't regenerate automatically since there may be no tclsh on the
- system and that would cause bootstrap problems. [Bug 465874]
-
-2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- Define TCL_INCLUDE_SPEC in tclConfig.sh. It should be included by
- extensions that need to find Tcl include headers in the install
- location. The user can override the include install dir with
- --includedir so we need to record this information for extensions.
- [Bug 421835]
-
- * unix/configure: Regen.
- * unix/configure.in: Define TCL_INCLUDE_SPEC.
- * unix/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
- * win/configure: Regen.
- * win/configure.in: Define TCL_INCLUDE_SPEC.
- * win/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
-
-2001-11-07 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc:
- * win/makefile.vc: Dropped the NOMSVCRT macro and put it on the option
- list instead. It makes more sense to me this way as NOMSVCRT=0 would
- only be the valid setting. Fixed the dde and reg extension for
- building static. Improved, but not perfected, the winhelp target.
-
-2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Change minimum VC++ version to 5.X since 4.X is known
- not to work.
- Indicate that Mingw is required and building with Cygwin gcc is not
- supported. Include instructions that indicate how to install Mingw and
- what URLs folks should use to download the supported version of Mingw.
- * win/configure: Regen.
- * win/configure.in: Error out if user tries to compile the Windows
- version of Tcl with Cygwin gcc. Users should compile with Mingw gcc
- instead.
-
-2001-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIO.c (ReadChars): Fixed [Bug 478856] reported by Stuart
- Cassoff <stwo@users.sourceforge.net>. The bug caused loss of
- fileevents when [read]ing less data from the channel than buffered.
- Due to an empty input buffer the flag CHANNEL_NEED_MORE_DATA was set
- but never reset, causing the I/O system to wait for more data instead
- of using a timer to synthesize fileevents and to flush the pending
- data out of the buffers.
-
-2001-11-06 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc (new):
- * win/makefile.vc: Complete over/under rewrite to support numerous
- build options all from the commandline itself without needing to edit
- the makefile. Now requires vcvars32.bat to be run prior to running
- nmake for bootstraping the environment. Fully doc'd usage for it is in
- makefile.vc. Commentary welcome. Sticky points left are:
-
- 1) winhelp target shows errors in the converting script.
- 2) .rc scripts aren't getting the right #defines to build the correct
- "OriginalFilename" strings. (have patch, won't commit yet)
- 3) Naming convention with suffixes describing the buildtype are 'tsdx'
- which will need public acceptance. ie. tclsh84tsx.exe is a (t)
- threaded shell (s) statically linked to the core and (x) uses
- msvcrt instead of libcmt.
-
-2001-11-04 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * library/init.tcl: made filesystem fallback proc ::tcl::CopyDirectory
- more robust to vagaries of non-native filesystems.
-
-2001-11-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n:
- * generic/tclIOUtil.c: updated documentation and comments to clarify
- behaviour of 'file copy' wrt soft links.
-
-2001-10-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFile.c: fix to '-types {f r}' bug in TclpMatchInDirectory
- (which could cause a UMR, as well as returning wrong results). Also
- improved API for 'stat' to resolve [Bug 219258].
- * win/tclWin32Dll.c
- * win/tclWinInt.h: addition of improved stat API to internal lookup
- table.
- * tests/fileName.test: two new tests for the above bug.
- * generic/tclIOUtil.c: some cleanup of comments and #ifdefs
-
-2001-10-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tclUnixFile.c (TclpMatchInDirectory): Argument to access() was
- entryPtr->d_name instead of nativeEntry which failed when trying to
- check access for files in other than the current directory. [Bug
- 475941, reported by Georgios Petasis]
-
-2001-10-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tclUnixChan.c: Added stateUpdated member to struct TtyState.
- (TtyCloseProc,TtySetOptionProc,TtyInit): Use stateUpdated member of
- TtyState to decide whether it is necessary to reset a serial port when
- Tcl closes it. Blindly resetting can cause Tcl to be sent an
- unexpected SIGTSTP when it is executing in the background [Bug 471374,
- reported by Chris Nelson]
-
-2001-10-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/ObjectType.3: Minor documentation fix, reported by David N.
- Welton <davidw@users.sourceforge.net> directly to me.
-
-2001-10-22 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFCmd.c: fix to stop test suite from hanging process under
- some versions of WinNT. [Bug 466102] (Kevin Kenny)
-
-2001-10-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/clock.test (clock-8.1):
- * generic/tclDate.c (RelativeMonth):
- * generic/tclGetDate.y (RelativeMonth): corrected off-by-one-day error
- in clock scan with relative months and years during swing hours. [Bug
- 413397, Patch 414024] (lavana)
-
-2001-10-18 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to bug in Tcl_FSChdir shown up by recent
- tclkit builds.
-
-2001-10-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixPipe.c (PipeInputProc, PipeOutputProc): do immediate
- retry when error is returned with errno == EINTR. [Bug 415131] (leger)
-
-2001-10-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclLoadAout.c (TclGuessPackageName): removed unused vars and
- fixed warnings. [Bug 446622] (lim)
-
-2001-10-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclProc.c: changing a memcmp to strncmp to avoid a memory
- error detected by purify (thanks Jeff); modify style to agrre with the
- style guide.
-
-2001-10-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclInt.decls (TclExpandCodeArray,TclGetInstructionTable):
- Added to internal stubs table. Tclcompiler (Tclpro project) needs them
- if used as loadable package under Windows. Changed signatures. We
- don't want to describe compiler internal structures in "tclInt.h".
-
- * generic/tclCompile.h: S.a. Removed function declarations.
- * generic/tclCompile.c: S.a. Adapted to changed signatures.
-
-2001-10-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/configure.in:
- * win/configure:
- * win/configure.in:
- * win/tcl.m4: reworked to be a little cleaner in comparison to each
- other, and to AC_SUBST even empty vars for win/tclConfig.sh
-
- * generic/tclFileName.c: minor code cleanup
-
- * generic/tcl.h: moved #define of WIN32 to tcl.h where __WIN32__ is
- defined and added #ifndef check.
-
- * doc/open.n: moved all fconfigure option docs to fconfigure.n
- * doc/fconfigure.n: added serial config options
-
- * win/tclWinChan.c:
- * win/tclWinPort.h:
- * win/tclWinSerial.c: added TIP #35 Windows enhancements for serial
- configuration. [Patch 438509] (schroedter)
-
-2001-10-15 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFCmd.c: fix to memory leak in TclFileDeleteCmd on
- certain error conditions.
- * doc/FileSystem.3: fix to typo.
-
-2001-10-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/encoding/ebcdic.enc:
- * tools/encoding/ebcdic.txt: EBCDIC charset mapping.
- [Patch 219323] (nijtmans)
-
- * library/encoding/tis-620.enc:
- * tools/encoding/tis-620.txt: TIS-620 charset mapping.
- [Patch 467423] (poonlap)
-
- * tests/http.test: added removeFile for outdata
-
- * tests/ioCmd.test: added catch around file removal, as Windows file
- locking throws errors.
-
- * tests/socket.test (socket-7.2): corrected to work on Win2K.
-
-2001-10-12 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/compile.test: new tests for [Bug 467523]; they are only
- effective if TCL_MEM_DEBUG was set during compilation.
-
-2001-10-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclLiteral.c (TclReleaseLiteral): insured that
- self-referential bytecodes are properly cleaned up on interpreter
- deletion [Bug 467523] (Ronnie Brunner)
-
-2001-10-10 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPort.h: #include <winsock2.h> needed to get moved to
- after #include <windows.h> or wierd misunderstandings took place when
- -D_WIN32_WINNT=0x0400 is set for outside code that requires knowledge
- of Tcl innards. General header macro magic applied liberally...
-
-2001-10-10 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test: Corrected restore of ::env(LANG).
-
-2001-10-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclFileName.c (Tcl_SplitPath): corrected mem leak intro'd
- with VFS code where the result obj from Tcl_FSSplitPath was not
- getting freed.
-
-2001-10-09 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclLiteral.c: (TclReleaseLiteral) reverted previous patch
- for [Bug 467523] - cure is worse than the illness.
-
-2001-10-05 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclLiteral.c: (TclReleaseLiteral) insured that
- self-referential bytecodes are properly cleaned up on interpreter
- deletion. [Bug 467523] (Ronnie Brunner)
-
-2001-10-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/configure:
- * tools/configure.in: noted 8.4 as default Tcl version
-
- * library/encoding/cp936.enc:
- * library/encoding/cp949.enc:
- * library/encoding/cp950.enc:
- * library/encoding/iso8859-16.enc:
- * library/encoding/macCroatian.enc:
- * library/encoding/macCyrillic.enc:
- * library/encoding/macGreek.enc:
- * library/encoding/macIceland.enc:
- * library/encoding/macRoman.enc:
- * library/encoding/macTurkish.enc:
- * tools/encoding/cp1250.txt:
- * tools/encoding/cp1251.txt:
- * tools/encoding/cp1252.txt:
- * tools/encoding/cp1253.txt:
- * tools/encoding/cp1254.txt:
- * tools/encoding/cp1255.txt:
- * tools/encoding/cp1256.txt:
- * tools/encoding/cp1257.txt:
- * tools/encoding/cp1258.txt:
- * tools/encoding/cp874.txt:
- * tools/encoding/cp932.txt:
- * tools/encoding/cp936.txt:
- * tools/encoding/cp949.txt:
- * tools/encoding/cp950.txt:
- * tools/encoding/iso8859-1.txt:
- * tools/encoding/iso8859-10.txt:
- * tools/encoding/iso8859-13.txt:
- * tools/encoding/iso8859-14.txt:
- * tools/encoding/iso8859-15.txt:
- * tools/encoding/iso8859-16.txt:
- * tools/encoding/iso8859-2.txt:
- * tools/encoding/iso8859-3.txt:
- * tools/encoding/iso8859-4.txt:
- * tools/encoding/iso8859-5.txt:
- * tools/encoding/iso8859-6.txt:
- * tools/encoding/iso8859-7.txt:
- * tools/encoding/iso8859-8.txt:
- * tools/encoding/iso8859-9.txt:
- * tools/encoding/koi8-r.txt:
- * tools/encoding/macCentEuro.txt:
- * tools/encoding/macCroatian.txt:
- * tools/encoding/macCyrillic.txt:
- * tools/encoding/macGreek.txt:
- * tools/encoding/macIceland.txt:
- * tools/encoding/macRoman.txt:
- * tools/encoding/macTurkish.txt:
- Updated encodings with latest mappings from www.unicode.org. This did
- not include some Mac encodings that have special multi-unichar
- translations now (like symbols, dingbats and japanese). Also does not
- include big5, gb or euc* as those have different formats in the latest
- Unicode version that need new conversion tools. Not all related .enc
- files changed as some had been updates separately.
-
-2001-10-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEvent.c (Tcl_FinalizeThread): moved freeing of
- tclLibraryPath to before the thread exit handlers are called. Slight
- modification to change on 2001-09-24.
-
-2001-10-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure: regen'ed
- * win/tcl.m4:
- * win/makefile.vc: added Win64 SDK RC1 compilation support
- * win/Makefile.in: added $(LDFLAGS_CONSOLE) to TCLSH, TCLTEST and
- PIPE_DLL_FILE targets to get the link flags
-
- * win/tclWinInit.c: minor 64bit casts
-
-2001-10-01 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclParseExpr.c: removed unnecessary inclusion of
- tclCompile.h and made a small modification in (InfoBodyCmd) to improve
- the isolation of the compiler/engine subsystem.
-
-2001-09-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c:
- * doc/FileSystem.3: corrected and clarified documentation for
- 'Tcl_FSListVolumes(Proc)'. No code changes.
-
-2001-09-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/FindExec.3: added a comment not to change the working directory
- before calling Tcl_GetNameOfExecutable. [Bug 219215]
-
-2001-09-28 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclIO.c: added two more '(ClientData)' casts on calls to
- Tcl_Preserve and Tcl_Release -- ones that Vince apparently missed.
-
-2001-09-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/lsort.n: Improved doc...
- * generic/tclCmdIL.c (Tcl_LsortObjCmd, SortCompare): Made
- offset-from-end indexing work, and factored out some "magic numbers"
- for easier understanding. [Bug 465674]
- * tests/cmdIL.test (cmdIL-1.26): Added test for offset-from-end
- indexing for lsort.
-
-2001-09-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFCmd.c:
- * unix/tclUnixFCmd.c: fix to performance issue reported by jcw in
- which 'access("")' is called unnecessarily when normalizing any
- absolute path.
- * generic/tclIO.c: added '(ClientData)' cast to calls to
- Tcl_(Preserve|Release) newly introduced, fixing compile error on
- Windows.
-
-2001-09-27 Don Porter <dgp@users.sourceforge.net>
-
- * doc/FileSystem.3 (Tcl_FSLoadFile):
- * generic/tcl.decls (Tcl_FSLoadFile):
- * generic/tcl.h (Tcl_FSLoadFileProc):
- * generic/tclInt.h (TclpLoadFile):
- * generic/tclIOUtil.c (Tcl_FSLoadFile):
- * generic/tclLoadNone.c (TclpLoadFile):
- * generic/tclTest.c (TestReportLoadFile):
- * library/ldAout.tcl:
- * mac/tclMacLoad.c (TclpLoadFile):
- * unix/tclLoadAix.c (TclpLoadFile):
- * unix/tclLoadAout.c (TclpLoadFile):
- * unix/tclLoadDl.c (TclpLoadFile):
- * unix/tclLoadDld.c (TclpLoadFile):
- * unix/tclLoadDyld.c (TclpLoadFile):
- * unix/tclLoadNext.c (TclpLoadFile):
- * unix/tclLoadOSF.c (TclpLoadFile):
- * unix/tclLoadShl.c (TclpLoadFile):
- * win/tclWinLoad.c (TclpLoadFile):
- * win/tclWinFCmd.c (DoRemoveJustDirectory): More CONST poisoning
- fixes from the 2001-09-24 TIP 27 changes. CONST-ified Tcl_FSLoadFile
- and TclpLoadFile. Report and patch from Kevin Kenny. [Bug 465833]
-
- * generic/tclIO.c (ChannelTimerProc): Added Tcl_Preserve() and
- Tcl_Release() to fix segfault introduced by the 2001-09-26 changes.
- [Bug 465494]
-
- * doc/TCL_MEM_DEBUG.3: Updated out-of-date reference to #define
- GUARD_SIZE.
-
- * doc/UpVar.3 (Tcl_UpVar,Tcl_UpVar2):
- * generic/tcl.decls (Tcl_UpVar,Tcl_UpVar2):
- * generic/tclInt.decls (TclFindProc,TclGetFrame):
- * generic/tclInt.h (TclFindProc,TclGetFrame,TclLookupVar,
- (TclPrecTraceProc,TclProcInterpProc}):
- * generic/tclProc.c (TclGetFrame,TclFindProc):
- * generic/tclVar.c (Tcl_UpVar,Tcl_UpVar2,MakeUpvar): Updated APIs in
- generic/tclProc.c and generic/tclVar.c according to the guidelines of
- TIP 27. [Patch 465442]
-
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
-2001-09-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/fileevent.n: Accepted [Patch 465279] adding an example to the
- fileevent manpage. Minor modifications to get a better formatting.
- Report and patch by David N. Welton <davidw@users.sourceforge.net>.
-
- * The changes below fix [Bug 462317] where Expect tried to read more
- than was in the buffers and then blocked in the OS call as its pty
- channel driver provides no blockmodeproc through which the OS could be
- notified of blocking-behaviour. Because of this the general I/O core
- has to take more care than usual to preserve the semantics of
- non-blocking channels.
-
- The problem was reported by "Kevin O'Gorman" <kevin@kosmanor.com>.
-
- * generic/tclIO.c (Tcl_ReadRaw): Do not read from the driver if the
- channel is non-blocking and the fileevent causing the read was
- generated by a timer. We do not know if there is data available from
- the OS. Instead of going to the OS for more and potentially blocking
- we simply signal EWOULDBLOCK to the higher levels to cause the system
- to wait for true fileevents.
- (GetInput): Same as before.
- (ChannelTimerProc): Added set and clear of CHANNEL_TIMER_FEV.
-
- * generic/tclIO.h (CHANNEL_TIMER_FEV): New flag for channels. Is set
- if a fileevent was generated by a timer, the channel is not blocking
- and the driver did not provide a blockmodeproc. In that case the I/O
- core has to be especially careful about going to the driver for more
- data.
-
-2001-09-26 Don Porter <dgp@users.sourceforge.net>
-
- * doc/SplitPath.3 (Tcl_GetPathType):
- * generic/tcl.decls (Tcl_GetPathType):
- * generic/tclFileName.c (Tcl_GetPathType):
- * win/tclWinFile.c (TclpMatchInDirectory, NativeStat): Vince Darley
- reports the 2001-09-24 TIP 27 changes left the win directory CONST
- poisoned. These changes should fix that.
-
- * generic/tclDecls.h: make genstubs
-
-2001-09-25 Don Porter <dgp@users.sourceforge.net>
-
- * doc/GetInt.3:
- * generic/tclInt.h (TclGetLong deleted):
- * generic/tcl.decls:
- * generic/tclInt.decls:
- * generic/tclGet.c: Updated APIs in generic/tclGet.c according to the
- guidelines of TIP 27. [Patch 464674]
-
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
-2001-09-25 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c: removed comments referring to unused flag
- TCL_PARSE_PART1.
-
-2001-09-24 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Concat.3:
- * doc/DString.3:
- * doc/SplitList.3:
- * generic/tclInt.h (TclCheckBadOctal):
- * generic/tcl.decls:
- * generic/tclInt.decls:
- * generic/tclEncoding.c (OpenEncodingFile):
- * generic/tclMain.c (Tcl_Main):
- * generic/tclUtil.c:
- * unix/tclLoadDl.c (TclpLoadFile): Updated APIs in generic/tclUtil.c
- according to the guidelines of TIP 27. [Patch 464553]
-
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
-2001-09-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- The change below fixes [Bug 464380]. The bug was reported by Ronnie
- Brunner <rbrunner@users.sourceforge.net>. He also provided the patch.
-
- * generic/tclEvent.c (Tcl_Finalize): Moved release of 'tclLibraryPath'
- to Tcl_FinalizeThread.
- (Tcl_FinalizeThread): See above, new place for release of
- 'tclLibraryPath'.
-
-2001-09-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tools/encoding/cp1252.txt: File was missing part of the encoding
- [euro, ZCaron and zcaron].
-
- * doc/OpenFileChnl.3: Add docs for Tcl_OutputBuffered; remove some old
- changebars.
-
-2001-09-21 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (TclExecuteByteCode): corrected INST_STR_CMP
- else case for strings to pass true utf char length to Tcl_UtfNCmp.
-
-2001-09-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinInit.c: added extra processor definitions. (mstacy)
-
- * win/tclWinSock.c (SocketThread): corrected pointer cast for _WIN64.
-
- * win/tclWinNotify.c: removed unnecessary winsock include (it is
- already in from tclWinPort.h).
-
- * win/tclWinPort.h: changed winsock.h include to winsock2.h. Reverses
- change from 2000-11-16, but is necessary for WIN64. Extensions should
- comply with defined OS words, or use #ifndef.
-
-2001-09-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/socket.test: removed dependence on being run from same dir as
- remote.tcl, which only now needs to be in the same dir as this file.
- [Bug 219326]
-
-2001-09-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclTest.c (TestcmdtokenCmd): corrected pointer
- storage/retrieval for 64bit machines.
-
- * generic/tclCmdAH.c (Tcl_FormatObjCmd):
- * generic/tclScan.c (Tcl_ScanObjCmd): corrected handling of format and
- scan on 64-bit machines. [Bug 412696] (rmax)
-
- * unix/configure: regen'ed
- * unix/tcl.m4: added --enable-64bit support for HP-11 with the 64-bit
- kernel.
-
- * tests/basic.test:
- * tests/cmdInfo.test: improved skip reporting of missing commands
-
- * tests/winFCmd.test: simplified error check for winFCmd-7.9
-
- * tests/winPipe.test: removed obsolete cat16 tests
-
- * generic/tclExecute.c (TclExecuteByteCode): fixed invalid usage of
- valuePtr in TRACE_WITH_OBJ in INST_EVAL_STK case. [Bug 462594] Changed
- INST_STR_CMP instruction to promote to Unicode strings only when one
- of the strings is already of Unicode type.
-
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclCompile.c (instructionTable):
- * generic/tclCompCmds.c (TclCompileStringCmd): INST_STR_MATCH -
- Updated to Int1 instruction type and added special case to use
- INST_STR_EQ instead when no glob chars are specified in a static
- string.
-
- * tests/{for.test,foreach.test,if.test,while.test}:
- * generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd,
- TclCompileIfCmd, TclCompileWhileCmd): Corrected the overaggressive
- compiling of loop bodies enclosed in ""s. [Bug 219166] (msofer)
-
-2001-09-19 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: insured that execution stack errors are also
- detected at abnormal returns.
-
-2001-09-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/socket.n: Added documentation to mention what happens when a
- server socket is created with port=0. Removed an old change bar, and
- no new change bar because Tcl has always behaved this way as it is
- really a poorly-documented standards-defined OS feature.
-
- * tests/util.test (util-8.1): Test derived from code to detect the
- problem, but the test always works in the C locale, so beware if you
- are maintaining the code.
- * generic/tclUtil.c (TclNeedSpace): Rewrote to be UTF-8 aware. [Bug
- 411825, but not that patch which would have added extra spaces if
- there was a real non-ASCII space involved.]
-
-2001-09-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIOCmd.c (Tcl_PutsObjCmd): Rewritten to have saner and
- faster argument handling. [Bug 123552], [Patch 402564] (fellows)
-
-2001-09-18 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): On Linux, disable inlining when one
- of the compat/*.c routines is to be linked in. [Patch 440891]
-
-2001-09-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tcl.h: removed forced #define USE_TCLALLOC 1 for Windows.
- This means the native system allocator will be used by default. This
- should be binary and source compatible with extensions, as Tcl_Alloc
- is a properly stubbed function.
-
-2001-09-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: corrected small bug in [Patch 456668] - the
- varFramePtr was not restored in one possible exit.
-
-2001-09-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/tclvars.n:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclProc.c: disabled all compile and execution tracing
- functionality in standard builds; TCL_COMPILE_DEBUG is now necessary
- to enable it. [Bug 451858]
-
-2001-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/gets.n:
- * doc/read.n:
- * doc/puts.n:
- * doc/flush.n:
- * doc/fconfigure.n:
- * doc/flush.n:
- * doc/eof.n:
- * doc/seek.n:
- * doc/tell.n:
- * doc/close.n:
- * doc/fileevent.n: Added references to the Tcl standard channels. Item
- [219250], reported by David LeBlanc <whisper@oz.net>. Thanks to
- Christopher Nelson <chris@pinebush.com> for doing editorial work.
-
-2001-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/Makefile.in:
- * win/configure.in:
- * win/makefile.bc:
- * win/makefile.vc:
- * library/dde/pkgIndex.tcl: Fixed version numbers from bogus tcl
- versions to independent versions for dde and registry packages.
-
-2001-09-13 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/regexp.test (regexp-20.1):
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): had to adjust fix from
- 2001-08-06 to actually duplicate the objects in certain cases. This is
- really a place where feather would have been essential. [Bug 461322]
-
- * generic/tclUtf.c (Tcl_UtfPrev): corrected to return the proper
- location when the middle of a UTF-8 byte was passed in [Tk Bug 450504]
-
- * ChangeLog.1999:
- * ChangeLog: broke changes from 199x into ChangeLog.1999 to reduce
- size of the main ChangeLog.
-
-2001-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/ioCmd.test: Changed the computation of the result for
- iocmd-8.1[123] so that the tests work for single- and multi-process
- execution of the testsuite. Depending on the choice of the user stdout
- is a tty or not and thus reports different channel options. Fixes
- [460993] reported by Don Porter.
-
-2001-09-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/ParseCmd.3:
- * generic/tcl.decls:
- * generic/tclCmdMZ.c (Tcl_SubstObjCmd):
- * generic/tclDecls.h:
- * generic/tclParse.c:
- * generic/tclStubInit.c:
- * tests/parse.test: Deprecate the use of Tcl_EvalTokens, replaced by
- the new Tcl_EvalTokensStandard. The new function performs the same
- duties but adheres to the standard return convention for Tcl
- evaluations; the deprecated function could only return TCL_OK or
- TCL_ERROR, which caused [Bug 219384] and [Bug 455151]. This patch
- implements [TIP 56].
-
-2001-09-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4: Invert the logic that checks for $GCC. Instead of
- checking for "$GCC" = "no" we check for "$GCC" != "yes" or simply swap
- the true and false blocks of code in an if statement. That way if GCC
- is set to "" everything will still work. [Bug 460991]
-
-2001-09-12 Don Porter <msofer@users.sourceforge.net>
-
- * tests/appendComp.test:
- * tests/lsearch.test:
- * tests/namespace.test:
- * tests/rename.test:
- * tests/split.test: Corrected tests to better isolate tests in one
- file from influencing tests in other files. [Bug 460591]
-
-2001-09-12 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tcl.decls: reserved stub #481 for the implementation of
- [TIP 56]
-
-2001-09-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/OpenFileChnl.3: Added documentation for Tcl_WriteRaw and
- Tcl_ReadRaw [Bug 414929].
-
- * doc/CrtChannel.3: Added documentation for Tcl_ChannelBuffered and
- Tcl_GetTopChannel [Bug 414929].
-
- * The changes below are a fix for [Bug 219253].
-
- * tests/socket.test: Removed _most_ instances of hardwired port
- numbers for listening sockets. Remaining are the ports in all tests
- with constraint 'doTestsWithRemoteServer'. These seem to be designed
- for a more controlled environment and are usually skipped when running
- the testsuite.
-
- * tests/io.test: Removed all instances of hardwired port numbers for
- listening sockets.
-
-2001-09-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEvent.c (TclInExit): Corrected handling of tsd in late
- stages of finalization. [Bug 419449] (darley)
-
- * tests/stack.test:
- * generic/tclInterp.c (AliasObjCmd): Check the numLevels to ensure
- that we aren't hitting some alias loop condition. [Bug 443184]
-
-2001-09-10 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Don't include . characters in the
- Tcl library name when building on FreeBSD 3.X and later systems.
- [Patch 450725]
-
-2001-09-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/tclsh.1:
- * doc/Tcl_Main.3:
- * doc/CrtChannel.3:
- * doc/OpenFileChnl.3:
- * doc/GetStdChan.3: Enhanced the manpages with cross-references to
- the new manpage and more explanations how these functions deal with
- the standard channels in various situations.
-
- * doc/StdChannels.3: New manpage describing handling of the standard
- channels by the Tcl library. [Bug 402725]
-
-2001-09-10 Don Porter <dgp@users.sourceforge.net>
-
- * unix/mkLinks (Tcl_FSLink): Updated to reflect 2001-08-23 file system
- changes.
-
- * unix/tclLoadShl.c: Added #include of tclInt.h; access to Tcl
- internals, notably TclpUnloadFile(), is required. Thanks to Bob
- Techentin for report and patch. [Bug 459305]
-
- * generic/tclInitScript.h (initScript):
- * win/tclWinInit.c (TCL_REGISTRY_KEY, TclpSetVariables): Removed
- vestiges of Tcl's old initialization from registry variables. [Bug
- 455645]
-
-2001-09-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclInt.decls: Also added 'TclWinFlushDirtyChannels' to the
- internal platform specific stub table.
-
- * win/tclWinFile.c (TclpObjStat): Now added the call to
- 'TclWinFlushDirtyChannels' to this function. I don't know where my
- head was last thursday (2001-09-06), but the call was actually added
- to 'TclpObjChdir', i.e. the implementation of [cd]. Corrected this
- now. Thanks to Vince Darley for spotting this.
-
-2001-09-10 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclProc.c:
- * tests/proc.test: made [proc] bytecompile a no-op for procs defined
- with _args_ as single argument and an empty body. [FRQ 451441]
-
-2001-09-09 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in:
- * win/Makefile.in: Use () around variable name instead of {}. Use
- TCLTEST variable directly instead of depending on the tcltest alias.
-
-2001-09-09 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tcl.h:
- * generic/tclPlatDecls.h: Reminder from David Cuthbert
- <dacut@kanga.org> that I hadn't finished the Borland compatibility
- stuff. [Patch 436116]
-
-2001-09-09 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/cmdAH.test: Modify cmdAH-20.5 and cmdAH-24.8 to display the
- file atime or mtime results if the test fails.
-
-2001-09-08 David Gravereaux <davygrvy@pobox.com>
-
- * win/mkd.bat:
- * win/rmd.bat: made these text files, text files again. [Patch 451333]
-
-2001-09-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/mkd.bat:
- * win/rmd.bat: Apply binary property (cvs admin -kb) to files and
- convert to CRLF linefeed format to fix the VC++ build. [Bug 219409]
-
-2001-09-08 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tclFCmd.c:
- * doc/FileSystem.3:
- * generic/tclIOUtil.c: removed Tcl_FSCopyFile fallback to channel
- copying, since the channels will not have access to interpreters and
- the channel copying currently requires an interp. Code which required
- cross-platform copies always has interpreters, so that solves the
- problem. Fixes bug in TclKit.
-
-2001-09-07 David Gravereaux <davygrvy@pobox.com>
-
- * win/tcl.m4: Added -link50compat option so a VC6 linker makes a VC5
- (pre sp3) compatible import library. [Bug 219257]
-
-2001-09-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinThrd.c (TclpThreadExit): Cast status argument to
- _endthreadex to unsigned instead of DWORD to match the Win32 function
- prototype.
-
-2001-09-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * All the changes below serve to fix bug [219148] which reports a 80x
- performance hit for file I/O on Win* systems. On my system it was
- closer to a 120x hit. Problem report by Uwe Traum <no email address
- available>.
-
- The fix goes like this: The obstacle is 'FlushFileBuffers', executed
- whenever Tcl writes data to the OS, as Tcl has to wait for the disk to
- complete I/O, and disks are slow. We remove that obstacle. This opens
- another problem, [file size] reports back wrong numbers. So for [file
- size] we add the call back in. As optimization we keep track of the
- channels which were written to and flush only these.
-
- * win/tclWinFile.c (TclpObjStat): Added a call to
- 'TclWinFlushDirtyChannels'. This ensures that [file size] and related
- commands report the correct size of a file even if Tcl has recently
- written to it. Unixoid OS's always report the correct size even for
- files with pending data, but Win* syssystem don't. They only report
- what is actually on disk.
-
- * win/tclWinInt.h: Added declaration of 'TclWinFlushDirtyChannels',
- making it available to other parts of the tcl core.
-
- * win/tclWinChan.c (TclWinFlushDirtyChannels): New, internal,
- procedure. Goes through the list of open file channels and forces the
- OS to flush its file buffers for all which were written to since the
- last call of this function. This is an expensive operation as Tcl has
- to wait for the OS to complete actual writes to the disk.
-
- (FileInfo): Added dirty flag required by the procedure above.
-
- (FileOutputProc): Removed flushing of file buffers, setting the dirty
- flag instead. This means that the previously incurred delays do not
- happen anymore.
-
- (TclWinOpenFileChannel): Added initialization of 'dirty' flag.
-
-2001-09-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/http.n: noted -binary, charset and coding state keys.
- * tests/http.test:
- * library/http/pkgIndex.tcl:
- * library/http/http.tcl (geturl): correctly get charset parameter
- and convert text according to specified encoding (if known). RFC
- iso8859-1 is used by default. Also recognize Content-encoding to see
- if we should do binary translation. Added a CYA -binary switch for the
- cases that were missed. [Bugs 219211, 219399]
-
- * tests/ioUtil.test: changed to make better use of constraints and
- remove knownBug constraints that weren't valid.
-
-2001-09-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-3.2): Updated test to support newer
- HP-UX releases that properly report euc-jp as the system encoding for
- Japanese. Bug report and patch verification by Bob Techentin. [Bug
- 453883]
-
- * doc/http.n:
- * library/http/*.tcl:
- * tools/tcl.wse.in:
- * tools/tclmin.wse:
- * unix/Makefile.in:
- * win/{Mm}akefile.*: Updated http package to version 2.4, reflecting
- the new features just added.
-
-2001-09-06 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclTest.c: tests of old-fs hooks no longer cause problems in
- threaded builds. Also removed unused unload proc.
- * generic/tcl.decls:
- * generic/tclIOUtilc: added Tcl_FSMountsChanged so that a vfs can
- inform the filesystem that the filesystem epoch must be changed (since
- cached filesystems may now be incorrect). Fixes problem running tclvfs
- extension.
- * library/tcltest/tcltest.tcl: if tests aren't in a native filesystem,
- then don't use pipes to run them. [Bug 458741]
-
-2001-09-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.decls (479 generic):
- * generic/tclIO.c (Tcl_Seek,Tcl_Tell,Tcl_OutputBuffered): Added public
- function to return the size of the output buffer and reworked other
- channel functions to use this shared functionality and that of
- Tcl_InputBuffered() too. [TIP#49, Rolf Schroedter]
-
-2001-09-05 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclPlatDecls.h: Another small trim finalizing Borland
- support.
-
- * win/tclWinPipe.c:
- * win/tclWinPort.h: More Borland compatibility fixes. Changed EDQUOT
- #define from 49 to 69. Borland had a clash as it was already using
- this number. Upon advice from Helmut Giese, EDQUOT has been found in
- other header files #defined as 69. [Patch 436116]
-
- * win/.cvsignore: A few more glob patterns added.
-
- * win/makefile.bc (new): Borland lives once more! rejoice..
- * generic/tclAlloc.c: Small Borland compatibility fix.
- * win/tclWinTime.c: More Borland compatibility fixes. [Patch 436116]
-
-2001-09-05 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/winFCmd.test: made notWin2000 constraint false if not running
- on Windows at all.
-
-2001-09-04 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinThrd.c: Revisited _beginthreadex() stuff. Instead of
- assuming a c-runtime implimentation of _beginthreadex normal, I
- reversed the logic to not assume, and use when is by explicitly
- needing to add runtimes that support it such as Borland.
-
- * generic/tcl.h:
- * generic/tclPlatDecls.h: Borland compatibility change so ClientData
- was properly typed as a void* and TCHAR would not be defined twice.
-
- * generic/tcl.h: Removed a small mistake from before. Changes to the
- EXTERN macro for proper Borland compatibility will have to see a TIP.
- What's this with the MS compiler:
-
- __declspec(dllexport) int func (int a, int b);
-
- will have to be this with Borland:
-
- int __cdecl __export func (int a, int b);
-
- The order of the attribute needs to be after the return type.
-
-2001-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * compat/strtod.c (strtod): Fixed failure to handle expressions like
- 3eq2 and failure to set errno on overflow. [Bug 440894]
-
-2001-09-04 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclProc.c:
- * tests/proc.test: made [proc] check that formal args have simple
- names. [Bug 458548]
-
-2001-09-04 Vince Darley <vincentdarley@users.sourceforge.net>
-
- Minor bug fixes in filesystem, plus small vfs changes as a result of
- enabling the test filesystem to work properly.
- * tests/fileName.test: ensure new test cleans up after itself
- * doc/filename.n:
- * generic/tclFileName.c: improved Mac path handling and document why
- [Bug 421842] on Windows handling of UNC paths is not valid.
- Documentation and code now much clearer on what is and is not a UNC
- path.
- * doc/FileSystem.3:
- * unix/tclUnixPipe.c:
- * generic/tclFCmd.c:
- * generic/tclIOUtil.c: fixed error message, fixed [Bug 453512] about
- dangerous use of tmpnam, replaced with mkstemp. Documented all the
- changes.
- * generic/tclTest.c: made test vfs fully functional as a 'reporting
- filesystem'.
- * generic/tcl.stubs:
- * generic/tcl.h:
- * generic/tclInt.h:
- * generic/tclIOUtil.c:
- * doc/file.n:
- * various platform-specific 'TclpLoadFile': fixed comments about
- unload behaviour, and completed objectification of loading. Required
- change to Tcl_Filesystem lookup table, so incompatible with 8.4a3, but
- not older versions of Tcl. The change also allows 'link' and
- 'reporting' filesystems to function correctly when loading files.
- Implementation of 'file delete -force' copes with case where cwd is
- inside the directory. Moved overlooked Tcl_FSGetPathType from internal
- to external API. Made sure filesystems which are registered and then
- unregistered are only freed when all references to them are gone.
- Documented changes.
- * unix/tclUnixFCmd.c: when deleting directories recursively, make sure
- permissions are ok. Together with the above, this fixes [Bug 219139]
- * tests/winFCmd.test: differentiated test results for win2k versus
- not. This fixes [Bug: 219239]
- * tests/fCmd.test: added tests for 'file delete -force' where the cwd
- is inside, and when permissions are inadequate.
-
-2001-09-04 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.c: fixed incorrect operands for INST_LIST [Bug
- 458241] (David Cuthbert, dacut@users.sourceforge.net)
-
-2001-09-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (TclExecuteByteCode): fixed missing comma in
- debug macro.
-
-2001-09-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/ExprLongObj.3: Fixed error in documentation of argument type to
- Tcl_ExprObj [Bug 457435]
-
-2001-09-02 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinThrd.c: Portability fix for Cygwin who's c-runtime,
- not surprisingly, doesn't have the MSVCRT specific _beginthreadex /
- _endthreadex pair. This might have to be revisited for proper Borland,
- lcc32, Watcom and other support as well. [Patch 444255]
-
- * win/tclWinThrd.c: Moved FinalizeConditionEvent() proto to within
- the main #ifdef TCL_THREADS block to avoid mingw warning about it
- being there but unused.
-
- * win/makefile.vc: Added -Zl (zee el) to tclStubLib.c compile line to
- make sure the tclstub84.lib static library is built without requiring
- a specific C-runtime library at link-time for the end-use developer.
- It has been noted on c.l.t that this trips many first time users
- trying to make extensions. [Patch 403533]
-
-2001-08-31 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.h: added TclCompileListCmd header
- * generic/tclBasic.c: added TclCompileListCmd compile proc
- * generic/tclCompCmds.c (TclCompileListCmd): function to compile the
- 'list' command at parse time.
- * generic/tclExecute.c (TclExecuteByteCode): definition of INST_LIST
- bytecode.
-
- * doc/StringObj.3: added words of warning to use Tcl_ResetResult with
- the Tcl_Append* functions.
-
- * tests/compile.test: added compile-11.* interp result checks
- * generic/tclUtil.c (TclGetIntForIndex): added Tcl_ResetResult before
- Tcl_AppendStringsToObj to prevent shared object crash when called from
- bcc instruction. The Tcl_Append* calls that append to the result
- object that are invoked by bcc insts must remember to call
- Tcl_ResetResult because the bcc doesn't do this for us. [Bug 456892]
-
-2001-08-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIndexObj.c: fixed some casting problems that upset Crays.
- [Bug 419528] (andreasen)
-
-2001-08-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Silence warning from Sun compiler. [Bug 454374]
-
-2001-08-30 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: allow cached fully-qualified command names to
- be usable from different namespaces within the same interpreter
- without forcing a new lookup. This speeds up scripts that pass command
- names in variables ("this" in some OO packages). [Patch 456668]
-
-2001-08-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- Further fs updates. After examining the most common Tcl extensions
- (TclX, BLT, Tk, TclPro, Mktclapp), it has been determined that only
- TclpGetCwd and the Access/Stat/Open insert/delete hooks of the
- internal fs functions are ever used. The remaining functions from
- Tcl's internal interfaces have therefore been removed, since Tcl now
- exports a more suitable public API (Tcl_FS...)
-
- * generic/tclInt.stubs:
- * generic/tclInt.h: updated for removed internal functions. Some new
- internal functions have been put in tclInt.h (and not exported in the
- stub table because good public equivalents exist).
- * generic/tclTest.c: some test functions used the internal private
- APIs. These tests have been retained, but modified to use public APIs.
- Also objectified the internal filesystem tests.
- * win/tclWinFile.c: removed TclpStat, TclpAccess and refactored code
- to use NativeAccess, NativeStat. This should speed up stat, access and
- glob commands.
- * win/tclWinFCmd.c: removed all TclpCopy/Rename/Delete File/Directory
- string-based procedures which aren't used any more. Improved
- efficiency of some other procedures. Ensure that filename conversions
- with a NULL interp do not crash Tcl.
- * mac/tclMacFCmd.c: wrapped long lines and cleaned up
- TclpObjNormalizePath, removed all TclpCopy/Rename/Delete
- File/Directory string-based procedures which aren't used any more.
- * mac/tclMacFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
- etc.
- * unix/tclUnixFCmd.c: removed use of TclpAccess, removed all
- TclpCopy/Rename/Delete File/Directory string-based procedures which
- aren't used any more.
- * unix/tclUnixFile.c: removed obsolete TclpStat, TclpAccess,
- TclpChdir, etc.
- * tcl(Unix|Mac|Win)Chan.c: objectified TclpOpenFileChannel.
- * various 'load' implementations all objectified.
- * generic/tclFileName.c: removed redundant code.
- * generic/tclIOUtil.c: removed TclStat, TclAccess, TclpListVolumes.
- Fix to MatchInDirectory at the root of a volume. Also improved some
- documentation, and improved default path joining behaviour for virtual
- filesystems, especially regarding '~'.
- * tests/fileName.test: added tests to check for bugs fixed above.
- * doc/FileName.3: improved documentation
-
-2001-08-30 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclAsync.c:
- * generic/tclEvent.c:
- * generic/tclInt.h: Improper cleanup of asyncMutex in tclAsync.c
- repaired. TclFinalizeSynchronization() was trying to remove a
- registered mutex that was dumped earlier when the TSD it was stored in
- was cleared. This was only surfacing on *nix. Windows was being masked
- by mutexes not actually being returned to the system! That was
- repaired in a previous patch. Needed to add a private
- TclFinalizeAsync() to tclAsync.c and called from Tcl_FinalizeThread().
- Pheww.. Is this done yet? [Bug 414419] requested by Rob Ratcliff
- <rrr6399@futuretek.com>
-
-2001-08-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c (TclPushVarName): noted 'static' defn.
- [Bug 453872]
-
-2001-08-26 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl (tcl_findLibrary):
- * tests/unixInit.test (unixInit-2.{1,9}):
- * unix/tclUnixInit.c (TclpInitLibraryPath):
- * win/tclWinInit.c (TclpInitLibraryPath): Corrected inconsistency
- between the search path for script libraries and the directory name
- $DISTNAME into which distributions built by 'make test' unpack. [Bug
- 455642]
-
-2001-08-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/stringComp.test: added string-1.3
- * generic/tclCompCmds.c (TclCompileStringCmd): changed to return
- TCL_OUT_LINE_COMPILE instead of TCL_ERROR when compiling and an
- unknown string method is called. This is necessary as the string
- command may be never called, or not until 'string' is redefined.
-
-2001-08-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/glob.n: documented windows-style path issue with glob.
- [Bug 219392]
- * doc/filename.n: documented windows path/file length limitation.
- [Bug 454597]
-
-2001-08-24 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-2.9): Corrected expected result to
- match Tcl's quirky construction of its init library path.
-
-2001-08-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinPipe.c (BuildCommandLine): Fixed [Bug 432499]. Part of the
- code used the non-absolute path to the executable to determine
- quoting. This failed if the absolute path contained spaces, but the
- application name itself not. This bug caused no trouble on Win NT 5,
- but does for other variants in the Win* family. Report and fix due to
- Ken Poole <kenpoole@users.sourceforge.net>.
-
-2001-08-23 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: added QNX-6 build support. [Bug 219410] (loverso)
-
- * unix/tclUnixFCmd.c:
- * generic/tclIOUtil.c:
- * generic/tclFileName.c: corrected minor compiler warnings.
-
-2001-08-23 Vince Darley <vincentdarley@users.sourceforge.net>
-
- Variety of small filesystem and vfs issues fixed or improved. The new
- fs code allows many new opportunities for efficiency improvements
- through the objectified API. The main changes integrated here are such
- efficiency improvements. Some limitations of the original
- implementation have also now been lifted. Meanwhile a variety of fs
- bugs (some old, some new) have also been fixed.
-
- * generic/tclFileName.c: Made Tcl_FSSplitPath more efficient, and
- removed some static string-based procedures which are no longer used.
- Much more objectification. Tcl_FSJoinPath is now very efficient and
- more aware of virtual filesystems. Clarified where the Mac-specific
- code attempts to interpret Unix-style paths. Modified TclDoGlob to use
- lstat not access to fix [Bug 434876] (L. Virden)
-
- * tcl(Win|Unix|Mac)FCmd.c:
- * tcl(Win|Unix|Mac)File.c: replaced TclpListVolumes with
- TclpObjListVolumes with different signature, updated code due to more
- efficient signature of Tcl_FSGetTranslatedPath. Used cached native
- paths where possible to improve efficiency -- this was completed on
- MacOS, but on Unix and Win the traversal functions make the task much
- more complex, so there are still some improvements possible there.
- Removed unused TclpNormalizePath which had been left in tclWinFCmd.c.
- Objectified all 'file attributes' functions. Fixed the new [Bug
- 451571, Bruce Stephens] which is most obvious on Unix, but could occur
- on MacOS or Windows. This bug actually existed in Tcl 8.3.x but was
- only made obvious by the recent filesystem overhaul when the code was
- exercised more heavily.
- * tests/fileName.test: Three new tests to exercise the above bug, and
- make sure it is fixed correctly.
- * unix/tclUnixFile.c: avoid panic in glob when a link doesn't point
- anywhere. It would probably be good to define exactly what Tcl should
- do in circumstances like these, and make sure mac/win/unix all behave
- accordingly. [Bug 417111] (Hemang Lavana). Also fixed
- misleading/obsolete comment in the code.
- * generic/tcl.stubs: changed signature of Tcl_FSGetTranslatedPath and
- added Tcl_FSGetTranslatedStringPath.
- These changes allow further optimisations in the FS code.
- * generic/tcl.h: changed signature of Tcl_FSListVolumes so that it
- doesn't require a Tcl interpreter plus result. Renamed Tcl_FSReadLink
- to Tcl_FSLink with additional argument so we can support making links
- in the future. [Patch: 450340]
- * generic/tclInt.h: added declaration for TclpObjListVolumes.
- Objectified internal call signatures for 'file attributes' functions,
- and added an internal objectified get path type function.
- * generic/tclIOUtil.c: added the moved function TclpListVolumes which
- calls platform specific code (needed for backwards compatibility), and
- improved efficiency of parts of the FS (particularly file
- normalization). Much less copying and memory allocation is required
- now. added new GetPathType so that changes in 'file volumes' can
- actually affect files' types, and objectified more code. Made current
- code work with test suite artificially changing current platform.
- Added 'static' keywords where required.
- * generic/tclIO.c:
- * generic/tclTest.c: Added 'static' keywords, fixing [Bug 453872] (Bob
- Techentin)
- * generic/tclCmdAH.c: file command implementation updated for API
- changes, removed unnecessary special-case SplitPath static function,
- since it no longer helps prevent code duplication. Moved setting of
- interpreter result to each individual location that actually required
- it, to avoid very large code separation between reading and setting
- the result.
- * doc/FileSystem.3: updated documentation for the new or changed APIs,
- and clarified some issues.
- * doc/SplitPath.3: added pointer to newer APIs in FileSystem.3
- * doc/filename.n: clarified current implementation of tilde support on
- Mac/Win. [Bug 453514] (Sergey Kuzmin)
- * doc/glob.n: improved documentation for '-directory' and '-path'
- options.
-
- There are now many private, obsolete, platform-specific 'Tclp'
- string-based filesystem APIs which could be removed. We should check
- whether any of these are used by extensions and, at least in Tcl 9,
- remove them.
-
- The above changes signify a ***POTENTIAL INCOMPATIBILITY*** with
- 8.4a3, since signatures of two functions in the new API have changed,
- but not with older versions of Tcl.
-
-2001-08-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclBinary.c (FormatNumber): Extract a long from the object
- and not an int, to stop [binary format] from being unable to format
- some input numbers on architectures where sizeof(int) is less than
- sizeof(long) (particularly Alpha). [tiprender Bug 441861]
-
- * tests/format.test: Converted conditional execution of tests into a
- test constraint.
-
-2001-08-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/Makefile.in:
- * win/makefile.vc: updated install target for dde1.2
- * doc/dde.n: fixed dde man page (which was totally incorrect).
- * tests/winDde.test:
- * win/tclWinDde.c (Tcl_DdeObjCmd): added -binary option to dde request
- command to allow for returning binary data. [Bug 227482]
- Updated dde to 1.2
-
- * tests/tcltest.test: added unixExecs constraint to files that used
- 'grep' in the test. [Bug 453143]
-
- * library/tcltest/tcltest.tcl: fixed stdio constraint test. [Patch
- 454050] (stanton)
- Simplified unixExecs constraint test.
-
-2001-08-22 Don Porter <dgp@users.sourceforge.net>
-
- * tests/ioUtil.test (ioUtil-3.*): Corrected errors in tests revealed
- by fix of overagressive compiler. [Bug 451200]
-
-2001-08-21 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c:
- * tests/compile.test: Fixed overagressive compilation of [catch]: it
- was catching errors at substitution time. [Bug 219184]
-
-2001-08-21 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/tcltest.test (tcltest-12.2): fixed test that would break when
- env vars weren't Tcl list friendly [Patch 454046] (stanton)
-
-2001-08-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/http.tcl (geturl): added port number to Host: header to
- comply with HTTP/1.1 spec (RFC 2068). [Bug 452217]
-
-2001-08-16 David Gravereaux <davygrvy@pobox.com>
-
- * tools/tcl.wse.in:
- * tools/tcl.hpj.in:
- * win/tcl.hpj.in: Removed -kb storage in CVS to ensure these text
- files are checked-out in the translation mode CVS is in. Setting these
- as binary as part of an effort to make sure they are always in CRLF,
- no matter what the CVS translation, is bypassing how CVS works and is
- confusing.
-
- * tools/genStubs.tcl: Removed LF-only output. Having to reconvert
- back to CRLF before committing to CVS was giving me a headache. [Bug
- 451333]
-
- * win/makefile.vc: replaced $(WINDIR) with $(include32) for the
- .rc.res inference rule. winver.h wasn't getting included. [Bug 445630]
-
-2001-08-14 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c: make the intial maxNestingDepth of an
- interpreter be MAX_NESTING_DEPTH instead of a hardwired value. [Bug
- 232564]
-
-2001-08-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/trace.test: Corrected test numbers. [Bug 449794]
-
-2001-08-12 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure: Regen.
- * unix/configure.in:
- * unix/tcl.m4: Use GCC variable set by AC_PROG_CC instead of defining
- our own using_gcc variable.
-
-2001-08-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- Variety of small issues introduced by the vfs code fixed:
- * generic/tclIOUtil.c: uninitialised read.
- * generic/tclFCmd.c: possible memory leak in file delete with error
- condition.
-
-2001-08-10 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c:
- * tests/trace.test: Insure that [array] traces work correctly for
- undefined variables. [Bug 449094]
-
-2001-08-09 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Delete the unused getcwd.o target. [Bug 440942]
-
-2001-08-08 Don Porter <dgp@users.sourceforge.net>
-
- * library/dde/pkgIndex.tcl:
- * library/http/http.tcl:
- * library/http/pkgIndex.tcl:
- * library/msgcat/msgcat.tcl:
- * library/msgcat/pkgIndex.tcl:
- * library/opt/optparse.tcl:
- * library/opt/pkgIndex.tcl:
- * library/reg/pkgIndex.tcl:
- * library/tcltest/tcltest.tcl:
- * library/tcltest/pkgIndex.tcl: Added checks for package dependencies.
- Bumped patchlevels of changed packages: http 2.3.2, msgcat 1.2.2,
- opt 0.4.3, tcltest 2.0.1. [Patch 448931]
-
- * README:
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure:
- * win/configure.in: Bumped up patchlevel to 8.4a4 to distinguish CVS
- snapshots from the 8.4a3 release. This does not necessarily mean there
- will be an 8.4a4 release. [Bug 448938]
-
-2001-08-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- 8.4a3 RELEASE
-
- * changes:
- * README:
- * mac/README:
- * unix/README:
- * win/README.binary: updated for 8.4a3 release
-
- * generic/tclFileName.c (Tcl_FSSplitPath): update to Tcl style guide.
-
- * generic/tclFCmd.c (FileCopyRename): fixed mem leak in introduction
- of vfs code where a new Tcl_Obj wasn't freed.
-
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): reordered
- the retrieval of arguments to avoid shimmering bug when the pattern
- and string referenced the same object.
-
- * unix/configure: regenerated
- * unixE/tcl.m4: added GNU (HURD) configuration target.
- [Patch 442974] (brinkmann)
-
- * win/README: made note of URL for Windows compilation notes
-
- * win/tclWinThrd.c (TclpFinalizeMutex, TclpFinalizeCondition): added
- DeleteCriticalSection calls for cleanup [Patch 419683]
-
- * unix/tclUnixPipe.c (TclpCreateTempFile): fixed use of tmpnam,
- which is dangerous. [Patch 442636] (lim)
- The use of tmpnam in TclpTempFileName must still be changed.
-
- * tests/http.test (http-4.14): fixed variable error return.
- [Bug 424252]
-
-2001-08-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure: regenerated
- * win/tcl.m4: fixed DLLSUFFIX definition to always be ${DBGX}.dll.
- This is necessary for TEA compliant builds that build shared against a
- static-built Tcl.
- * win/Makefile.in ($(TCLSH)): added $(TCL_STUB_LIB_FILE) to build
- target, otherwise it wouldn't get generated in a static build.
-
-2001-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIOCmd.c (Tcl_GetsObjCmd): Applied patch from [Bug 442665]
- to fix the bug reported by it. The function can corrupt a freed object
- if it is called with objc == 3. This is because it retrieves resultPtr
- and does not increment its reference count, but then calls
- Tcl_ObjSetVar2, which causes the retrieved resultPtr object to be
- released.
-
-2001-08-06 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tclsh.1: Added note that the tclsh program is frequently
- installed with the Tcl version numer as part of the name. [Patch
- 402725]
-
- * generic/tclPkg.c:
- * tests/pkg.test: [package forget] now forgets all of the package
- arguments it receives, not stopping when a package is not found. [Bug
- 415273]
-
-2001-08-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIOUtil.c (Tcl_FSMatchInDirectory): corrected
- uninitialized value.
-
-2001-08-02 Mo DeJong <mdejong@redhat.com>
-
- * generic/tclPlatDecls.h:
- * win/tclWinPort.h: Revert <tchar.h> related changes made to improve
- Cygwin support on 2001-07-18. This change ended up breaking the VC++
- build because of conflicts between Windows APIs and internal Tk APIs.
-
-2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFCmd.c: minor casts to eliminate warnings. (lim)
- [Patch 440218]
-
- * tests/parseOld.test: changed some tests that required testwordend to
- exist to skip in a proper tcltest manner. [Bug 442663]
-
- * library/http/http.tcl (http::mapReply): the regsub'ing of \n and \t
- to escape them was unnecessary.
-
-2001-07-31 Vince Darley <vincentdarley@users.sourceforge.net>
-
- Changes from TIP#17 "Redo Tcl's filesystem"
- The following files were impacted:
- * doc/Access.3:
- * doc/FileSystem.3:
- * doc/OpenFileChnl.3:
- * doc/file.n:
- * doc/glob.n:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclDate.c:
- * generic/tclDecls.h:
- * generic/tclEncoding.c:
- * generic/tclFCmd.c:
- * generic/tclFileName.c:
- * generic/tclGetDate.y:
- * generic/tclIO.c:
- * generic/tclIOCmd.c:
- * generic/tclIOUtil.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclLoad.c:
- * generic/tclStubInit.c:
- * generic/tclTest.c:
- * generic/tclUtil.c:
- * library/init.tcl:
- * mac/tclMacFCmd.c:
- * mac/tclMacFile.c:
- * mac/tclMacInit.c:
- * mac/tclMacPort.h:
- * mac/tclMacResource.c:
- * mac/tclMacTime.c:
- * tests/cmdAH.test:
- * tests/event.test:
- * tests/fCmd.test:
- * tests/fileName.test:
- * tests/io.test:
- * tests/ioCmd.test:
- * tests/proc-old.test:
- * tests/registry.test:
- * tests/unixFCmd.test:
- * tests/winDde.test:
- * tests/winFCmd.test:
- * unix/mkLinks:
- * unix/tclUnixFCmd.c:
- * unix/tclUnixFile.c:
- * unix/tclUnixInit.c:
- * unix/tclUnixPipe.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclWinInit.c:
- * win/tclWinPipe.c:
-
-2001-07-24 Mo DeJong <mdejong@redhat.com>
-
- * win/tclWinThrd.c (Tcl_CreateThread): Close Windows HANDLE returned
- by _beginthreadex. The MS documentation states that this handle is not
- closed by a later call to _endthreadex.
-
-2001-07-21 Don Porter <dgp@users.sourceforge.net>
-
- * doc/pkgMkindex.n:
- * library/package.tcl: Corrected documentation and usage message of
- [pkg_mkIndex].
-
-2001-07-18 Mo DeJong <mdejong@redhat.com>
-
- * generic/tclPlatDecls.h: Define TCHAR by including windows.h instead
- of tchar.h since Cygwin does not support the tchar.h header. Include
- CHECK_UNICODE_CALLS logic from tclWinPort.h.
- * win/tclWinPort.h: Remove CHECK_UNICODE_CALLS logic. Remove include
- of windows.h since this now done it tclPlatDecls.h.
- * win/tclWinReg.c: Remove duplicate include of windows.h.
-
-2001-07-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIO.c: Aftermath to [Bug 427196]. Squash empty buffers if
- they are smaller than the requested buffersize, to prevent reusage of
- old buffers and to honor changes in the requested buffersize made by
- the user.
-
-2001-07-17 Mo DeJong <mdejong@redhat.com>
-
- * win/tclWinFile.c (TclpReadlink): Add Cygwin specific definition for
- the TclpReadlink function. This method implements reading of symbolic
- links when build with Cygwin.
-
-2001-07-17 Mo DeJong <mdejong@redhat.com>
-
- * win/tclWinPort.h: Add Cygwin specific defines for environ and
- timezone variables.
-
-2001-07-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIO.c (GetInput): Fixed [Bug 427196]. Memory was
- overwritten because a buffer was used after a change of the requested
- buffersize together with that requested buffersize and not its actual
- size, which was smaller. Note that the continous reuse of the smaller
- buffer negatively impacts performance. The system never allocates a
- buffer with the newly requested bigger buffersize.
-
-2001-07-16 Mo DeJong <mdejong@redhat.com>
-
- * generic/tcl.h: Define __WIN32__ when __CYGWIN__ or __MINGW32__ is
- defined.
- * generic/tclAlloc.c: Define caddr_t when compiling with VC++ or
- mingw. This type is already defined when compiling with Cygwin.
-
-2001-07-16 Mo DeJong <mdejong@redhat.com>
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinPort.h:
- * win/tclWinSerial.c:
- * win/tclWinThrd.c:
- Remove unnecessary #includes of dos.h, direct.h, and tchar.h. This
- will help the Cygwin porting effort since these headers do not exist
- under Cygwin.
-
-2001-07-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinPipe.c (PipeClose2Proc): constrained the mutex lock to
- just the TerminateThread call and waiting for termination. (jsmith)
-
- * generic/tclCmdMZ.c: Removed extra copy of the SCAN_* macros
- #defined in generic/tclScan.c. [Bug 441230] (porter)
-
-2001-07-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/unixInit.test (unixInit-2.8): Added extra constraint,
- notInstalledInTmp, to stop this test from damaging installations in
- /tmp; not much fun to have to reinstall the Tcl library every time you
- run the test suite!
-
- * tests/subst.test (subst-10.*): Updated tests to check new behaviour
- for 'break' in command substitutions.
- (subst-1.2,subst-7.1): Error messages changed.
- * doc/SubstObj.3: New file, to document Tcl_SubstObj.
- * doc/subst.n: Improved and updated documentation for 'subst' to help
- support the changed behaviour.
- * generic/tcl.decls (generic-437): Declaration for Tcl_SubstObj
- * generic/tcl.h (TCL_SUBST_*): Added flags for Tcl_SubstObj.
- * generic/tclCmdMZ.c (Tcl_SubstObj,Tcl_SubstObjCmd): Divided into two
- parts to allow people to access the innards of 'subst' and changed the
- behaviour when command substitutions do a 'break' to be different from
- 'continue'. Also now works with objects, which allows for some nifty
- optimisations with variable substitutions and a slight improvement
- with command substitutions. [TIP#36]
-
-2001-07-10 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Add AR variable for use in STLIB_LD.
- * unix/configure: Regen.
- * unix/configure.in: Use STLIB_LD when defining MAKE_LIB and
- MAKE_STUB_LIB. Subst RANLIB and AR.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add doc comment about STLIB_LD
- command. Check ${AR} env var when setting STLIB_LD and delay
- evaluation until make time.
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Delay evaluation of ${AR} in STLIB_LD
- and add flags to better match the Unix implementation. Don't bother
- defining AR when using VC++ since it is not used.
-
-2001-07-06 Mo DeJong <mdejong@redhat.com>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Pass -e _WinMain@16 in addition to
- the -mwindows flag to work around a problem with ld when it
- incorrectly use main() as the executable entry point when both
- WinMain() and main() are available.
-
-2001-07-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdAH.test: Added leading zero to file modes to work around
- fault in HPUX strtol() which ignores the base parameter. [Bug 438808]
-
-2001-07-05 Mo DeJong <mdejong@redhat.com>
-
- * win/Makefile.in: Subst DEPARG directly instead of relying on a
- variable. This will make Cygwin builds faster since an extra exec will
- be avoided.
- * win/configure: Regen.
- * win/configure.in: Subst DEPARG.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Move AC_MSG_CHECKING after the
- AC_CHECK_PROG so that status messages do not get mixed together. Set
- DEPARG based on the results of the cygpath check so that we avoid
- using an extra exec when it is not needed. Use ac_cv_cygwin status
- flag instead of looking at the output of gcc -v, which works in the
- case where -mno-cygwin is set in the CFLAGS.
-
-2001-07-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README:
- * mac/README:
- * unix/README:
- * win/README:
- * win/README.binary: updated READMEs with purls
-
-2001-07-03 Mo DeJong <mdejong@redhat.com>
-
- * win/Makefile.in: Remove PATHTYPE variable.
- * win/configure: Regen.
- * win/configure.in: Don't subst PATHTYPE.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove PATHTYPE variable. Set CYGPATH
- to "cygpath -w" if the cygpath executable is found on the path. This
- approach works for native Cygwin builds and cross compiles.
-
-2001-07-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/var.test:
- * generic/tclVar.c (Tcl_VariableObjCmd): added patch to check for
- number of args. [Patch 426038]
-
- * generic/tclVar.c (Tcl_GetVar2Ex): added ability to recognize
- TCL_TRACE_READS flags to cause creation of part1 in TclLookupVar to
- make sure newly created array will get read traces triggered
- appropriately. This is called by Tcl_ObjGetVar2, Tcl_GetVar, and
- Tcl_GetVar2.
- (TclSetIndexedScalar, TclSetElementOfIndexedArray): added read trace
- triggering for lappend case.
- (Tcl_LappendObjCmd): pass TCL_TRACE_READS to Tcl_ObjGetVar2 to trigger
- possible read traces for new arrays.
-
- * generic/tclExecute.c (TclExecuteByteCode): added TCL_TRACE_READS
- flag to INST_LAPPEND(_ARRAY)_STK case to trigger read traces for newly
- created arrays. Removed unnecessary #ifdef for TCL_COMPILE_DEBUG in
- INST_LOAD_SCALAR1 case.
-
- * tests/append.test:
- * tests/appendComp.test: added tests for read trace triggering for
- append and lappend.
-
-2001-07-03 Mo DeJong <mdejong@redhat.com>
-
- * tests/clock.test (clock-2.5): Adjust test so that it passes when the
- time slice is 60 msecs, now passes under Windows 98.
-
-2001-07-03 Mo DeJong <mdejong@redhat.com>
-
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Don't pass the v flag to ${AR} when
- using gcc, verbose output is not needed.
-
-2001-07-03 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-2.8): Changed test back to using
- installation layout, adding comments explaining why the test writes to
- the directories it does, and checks to avoid destroying other files in
- /tmp.
-
-2001-07-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/unixInit.test (unixInit-1.2): Fixed faults reported in
- [Bug 438070] - well, at least enough to work on Solaris - and added
- comments that should make what is going on in the test clearer.
-
-2001-07-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/util.test: added util-4.6
- * generic/tclUtil.c (Tcl_ConcatObj): Corrected walking backwards over
- utf-8 chars. [Bug 227512]
-
-2001-07-02 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-2.8): Corrected test for all absolute
- pathnames in library path when executable is installed near root
- directory to use correct development directory layout. [Bug 438014]
-
- * tests/unixInit.test (unixInit-2.9):
- * unix/tclUnixInit.c (TclpInitLibraryPath):
- * win/tclWinInit.c (TclpInitLibraryPath): Corrected buggy
- construction of search path entries relative to executable. Added test
- for bad construction. [Bug 438014]
-
-2001-06-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclNamesp.c: Correction to faulty patch from [Bug 231259]
-
-2001-06-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/unixInit.test (unixInit-1.2): Modified so as not to require a
- local echo service, which fails on many systems which have that turned
- off for security reasons...
-
-2001-06-27 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.h:
- * generic/tclObj.c:
- * unix/Makefile.in: added a -DPURIFY mode that makes Tcl_Obj's
- allocated and free singularly (instead of in alloc in blocks and never
- free) to allow checkers like Purify to operate better.
-
- * library/encoding/koi8-u.enc: added koi8-u (Ukranian variant)
- encoding.
-
- * tests/subst.test:
- * generic/tclUtf.c (Tcl_UtfBackslash): Corrected backslash handling of
- multibyte utf-8 chars. [Bug 217987]
-
- * generic/tclCmdIL.c (InfoProcsCmd): fixed potential mem leak in info
- procs that created objects without using them.
-
- * generic/tclCompCmds.c (TclCompileStringCmd): fixed mem leak when
- string command failed to parse the subcommand.
-
- * doc/interp.n:
- * doc/unknown.n: updated notes about what is in a safe interp. [Bug
- 218605]
-
-2001-06-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/event.test (event-11.5): Removed hard-coded port number which
- could fail on some systems. [Bug 436727]
-
-2001-06-26 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in:
- * win/Makefile.in: Add `make shell` target. This target will set the
- proper env vars before invoking tclsh from the build directory.
-
-2001-06-26 Mo DeJong <mdejong@redhat.com>
-
- * win/Makefile.in: Use : to separate VPATH entries. This works for
- both Cygwin builds and cross builds, the VPSEP variable is simply
- unneeded complexity.
- * win/configure: Regen.
- * win/configure.in: Don't subst VPSEP.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove VPSEP variable.
-
-2001-06-26 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure: Regen.
- * unix/configure.in: Fix last checkin by removing export since that
- only works in bash.
- * win/configure: Regen.
- * win/configure.in: Ditto.
-
-2001-06-26 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure: Regen.
- * unix/configure.in: Set CFLAGS to "" if the user did not set CFLAGS
- in the env. This keeps AC_PROG_CC from adding "-g -O2" to the CFLAGS
- by default.
- * win/configure: Regen.
- * win/configure.in: Ditto.
-
-2001-06-25 Mo DeJong <mdejong@redhat.com>
-
- * win/configure: Regen.
- * win/configure.in: Use RC_DEFINE flag from tcl.m4.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set RC_DEFINE flag based on the
- compiler in use.
-
-2001-06-25 Mo DeJong <mdejong@redhat.com>
-
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Link to the imm32 library when
- building with mingw gcc.
-
-2001-06-25 Mo DeJong <mdejong@redhat.com>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): When building with gcc, don't attempt
- to link with LD or support dllwrap. Simply require a recent version of
- Cygwin gcc or Mingw gcc that supports -shared. When linking, use gcc
- instead of ld since gcc automatically includes libs like -lmsvcrt.
-
-2001-06-22 Mo DeJong <mdejong@redhat.com>
-
- * win/configure: Regen.
- * win/configure.in: Add resource compiler fix from 8.3.3 to fix
- compiling with mingw.
-
-2001-06-22 Mo DeJong <mdejong@redhat.com>
-
- * win/configure: Regen.
- * win/tcl.m4: Fix silly typo in last checkin.
-
-2001-06-22 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@. Set
- LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. Add LDFLAGS_DEBUG and
- LDFLAGS_OPTIMIZE to match the way CFLAGS_DEFAULT works. This will
- support user set CFLAGS or LDFLAGS at configure time.
- * unix/configure: Regen.
- * unix/configure.in: Don't set CFLAGS to CFLAGS_DEFAULT, instead
- subst CFLAGS_DEFAULT into the Makefile. Add AC_SUBST for
- CFLAGS_DEFAULT, LDFLAGS_DEFAULT, LDFLAGS_DEBUG, and LDFLAGS_OPTIMIZE.
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that it
- uses a Makefile variable just like CFLAGS_DEFAULT.
- * win/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@. Set
- LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. This will support user set
- CFLAGS or LDFLAGS at configure time.
- * win/configure: Regen.
- * win/configure.in: Don't set CFLAGS or LDFLAGS, instead subst
- CFLAGS_DEFAULT and LDFLAGS_DEFAULT into the Makefile.
- * win/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that it
- uses a Makefile variable just like CFLAGS_DEFAULT.
-
-2001-06-22 Mo DeJong <mdejong@redhat.com>
-
- * win/configure:
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Don't set LDFLAGS_DEBUG to -g or
- LDFLAGS_OPTIMIZE to -O when compiling with gcc. These flags are not
- needed and can cause problems with the Cygwin version of ld.
-
-2001-06-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/unixInit.test (unixInit-1.2,unixInit-2.8): Added test for code
- described below, and fixed a couple of errors that caused problems
- during testing; the code to determine the installedTcl constraint was
- wrong, and test unixInit-2.8 assumed that /tmp/lib was free for use
- and could be deleted, which clashed nastily with my installation and
- made other tests fail unnecessarily!
-
- * unix/tclUnixChan.c (TtyInit,TclpOpenFileChannel,
- (Tcl_MakeFileChannel,TclpGetDefaultStdChannel): Alterations so that
- the standard channels - stdin, stdout and stderr - have the correct
- type and fconfigure options. This required making the initialisation
- of serial lines a little more sophisticated to make the console behave
- correctly in interactive mode... [Bug 219137 and duplicates]
-
-2001-06-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclPanic.c (Tcl_PanicVA):
- * mac/tclMacAppInit.c (main):
- * mac/tclMacPanic.c (TclpPanic):
- * unix/tclUnixPort.h:
- * win/tclWinPort.h: Replaced TclMacSetPanic with TclpPanic for setting
- a platform-specific panic handler. TclpPanic is NULL on Unix and
- Windows. Fixes broken wish on Mac due to earlier patches. [Patch
- 415648]
-
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: `make gentubs` after above changes.
-
-2001-06-13 Don Porter <dgp@users.sourceforge.net>
-
- * mac/tclMacAppInit.c (main, Macintosh_Init):
- * mac/tclMacBOAAppInit.c (main):
- * mac/tclMacPanic.c: Applied patches from Dan Steffen correcting
- problems on the Macintosh in the 2001-06-08 changes.
-
-2001-06-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/regexp.test (regexp-18.12):
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): Fixed so that submatches
- that do not match always have index pair {-1 -1} [Bug 219232]
-
-2001-06-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h:
- * generic/tcl.decls:
- * generic/tclPanic.c: Added CONST to Tcl_*Panic* public interfaces.
- [Patch 415648, TIP 27]
-
- * generic/tclInt.decls:
- * mac/tclMacAppInit.c (main):
- * mac/tclMacBOAAppInit.c (main):
- * mac/tclMacPanic.c: Modified special Mac implementations of
- Tcl_*Panic* to be exact copies of the generic implementations. Added
- TclMacSetPanic. The generic implementations should be used directly,
- rather than copies, but that requires further changes by someone
- familiar with the Mac build systems. [Patch 415648]
-
- * generic/tclDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: `make gentubs` after above changes.
-
- * doc/Panic.3:
- * unix/mkLinks: New file documenting Tcl_*Panic* public interfaces,
- followed by `make mklinks`. [Patch 415648, Bug 219170, Bug 414936]
-
-2001-06-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (Tcl_DStringAppendElement): patch to save an
- extra strlen call. [Bug 428572]
-
-2001-05-30 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Added two casts to
- INST_STR_CMP implementation to get rid of a couple warnings from the
- SUNWspro C compiler.
-
- * generic/tclBasic.c (Tcl_GetMathFuncInfo,Tcl_ListMathFuncs):
- * generic/tclCmdIL.c (Tcl_InfoObjCmd,InfoFunctionsCmd):
- * generic/tcl.decls (generic table, positions 435+436):
- * tests/info.test:
- * doc/CrtMathFnc.3:
- * doc/info.n: Changes due to TIP #15 "Functions to List and Detail
- Math Functions"
-
-2001-05-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/init.tcl (unknown): removed errant " in error message
-
-2001-05-27 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/regc_locale.c: updated character class range data for
- Unicode v3.1.0 compliance.
- * generic/tclUniData.c: regenerated from Unicode v3.1.0 data file (new
- as of 2001-05-16). This brings Tcl to current unicode compliance.
-
- * tests/utf.test: added tests to check unicode 3 compliance
-
- * unix/Makefile.in (tclUtf.o): added tclUniData.c dependency.
-
- * tools/uniClass.tcl: added comments to output format and the script
- for clarification.
-
- * tools/uniParse.tcl: corrected filename output and GetDelta macro to
- use 'info' as param (was 'infO')
-
-2001-05-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
- (ParseSearchId): Added code to speed up array searching by reducing
- the amount of parsing needed for searchIds.
-
- * generic/tclObj.c (TclInitObjSubsystem):
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
- * generic/tclNamesp.c (TclInitNamespaceSubsystem):
- * generic/tclInt.h: Moved some Tcl_ObjType initialisation to
- TclInitObjSubsystem to be with the bulk of the rest. [Patch 424851]
- Committed by Miguel Sofer <mig@utdt.edu>
-
-2001-05-23 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/io.test: changed io-52.[9-11] to not be platform sensitive
- with EOL translation.
-
- * library/encoding/cp1250.enc:
- * library/encoding/cp1251.enc:
- * library/encoding/cp1252.enc:
- * library/encoding/cp1253.enc:
- * library/encoding/cp1254.enc:
- * library/encoding/cp1255.enc:
- * library/encoding/cp1256.enc:
- * library/encoding/cp1257.enc:
- * library/encoding/cp1258.enc:
- * library/encoding/cp874.enc:
- * library/encoding/iso8859-6.enc:
- * library/encoding/iso8859-7.enc:
- * library/encoding/iso8859-8.enc:
- * library/encoding/iso8859-10.enc (new):
- * library/encoding/iso8859-13.enc (new):
- * library/encoding/iso8859-14.enc (new): updated encoding tables based
- on http://www.unicode.org/Public/MAPPINGS/. (kuhn)
-
-2001-05-23 Mo DeJong <mdejong@redhat.com>
-
- * unix/tcl.m4 (SC_PATH_TCLCONFIG): Fix comments, and typo in cached
- variable name.
-
-2001-05-23 Mo DeJong <mdejong@redhat.com>
-
- * unix/tcl.m4 (SC_LOAD_TKCONFIG): Remove use of undefined TCLCONFIG
- variable and call AC_MSG_RESULT to print the checking result.
- * win/tcl.m4: Ditto.
-
-2001-05-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclObj.c (TclAllocateFreeObjects): simplified
- objSizePlusPadding to use sizeof(Tcl_Obj) (max) Corrected use of
- tclObjsAlloced/Freed/Shared in TCL_MEM_DEBUG compile.
-
-2001-05-22 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: removed Tcl_DuplicateObj in INST_DUP
-
-2001-05-21 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/tcltest.test (tcltest-19.1): fixed failing test that was
- getting affected by Windows env handling of empty valued elements.
-
- * unix/tcl.m4: added more common install directories in which to
- search for *Config.sh. [Bug 419812]
-
- * tests/cmdMZ.test (cmdMZ-1.4): added notLinux constraint to test to
- prevent failure message on Linux due to OS caching bug.
-
- * tests/httpd (httpdRespond): added response to timeout value in query
- string.
-
- * tests/http.test: removed unused notLinux constraint setting
-
- * generic/tclRegexp.c (Tcl_RegExpExecObj): added use of
- Tcl_GetUnicodeFromObj.
-
-2001-05-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * Note that "tclbench" (see project "tcllib") was extended with
- performance benchmarks for [fcopy] too.
-
- * doc/fcopy.n: Updated to reflect the extended behaviour of 'fcopy'.
-
- * tests/io.test: Added tests 'io-52.9', 'io-52.10' and 'io-52.11' to
- test the handling of encodings by 'fcopy' / 'TclCopychannel'. [Bug
- 209210]
-
- * generic/tclIO.c: Split of both 'Tcl_ReadChars' and 'Tcl_WriteChars'
- into a public error checking and an internal working part. The public
- functions now use the new internal ones. The new functions are
- 'DoReadChars' and 'DoWriteChars'. Extended 'CopyData' to use the new
- functions 'DoXChars' when required by the encodings on the input and
- output channels. [Bug 209210]
-
-2001-05-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/history.tcl (tcl::HistAdd): prevent empty calls from being
- added to the history (arndt)
-
- * tests/error.test: updated error-1.3 message to account for string
- index being compiled at toplevel.
- * tests/appendComp.test:
- * tests/stringComp.test: new files for extended bytecode testing
-
- * generic/tclBasic.c: added new CompileProc invocations to basic
- command initialization.
- * generic/tclCompCmds.c: added new compile commands for append,
- lappend, lindex and llength. Refactored set and incr compile commands
- to use new TclPushVarName function for handling the varname component
- during compilation (also used by append and lappend). Changed string
- compile command to compile toplevel code as well (when possible).
- * generic/tclCompile.c: added new instruction enums
- * generic/tclCompile.h: added debug info for new instructions
- * generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to toplevel
- var (oft-used). Added definitions for new bytecode instructions
- INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1,
- INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4,
- INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1,
- INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4,
- INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK.
- Refactored repititious code for reuse with INST_LOAD_STK (same as
- INST_LOAD_SCALAR_STK), INST_STORE_STK (same as INST_STORE_SCALAR_STK).
- Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows
- [Bug 219201] as that fix only affected the runtime eval'ed "string"
- (string compare is normally byte-compiled now). We may want to back
- these out for speed in the future, noting the problems with \x00
- comparisons in the docs.
- * generic/tclInt.h: declarations for new compile commands.
- * generic/tclVar.c: change TclGetIndexedScalar,
- TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and
- TclSetIndexedScalar to use flags. The Set functions now support
- TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well.
- * generic/tclInt.decls:
- * generic/tclIntDecls.h: minor signature changes for above.
-
- * generic/tclCmdMZ.c: made use of new Tcl_GetUnicodeFromObj.
-
-2001-05-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/console.n: Deleted. Put it in the wrong source tree! D'oh!
-
-2001-05-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclStubInit.c:
- * generic/tclStringObj.c (Tcl_GetUnicodeFromObj): new function to
- parallel Tcl_GetStringFromObj (fix of an API oversight).
-
- * unix/tclUnixPipe.c: updated pipeChannelType to TCL_CHANNEL_VERSION_2
- type specification.
-
- * tests/fileName.test: corrected tests not to fail on win when a
- C:/test dir exists.
-
- * generic/tclFileName.c (ExtractWinRoot): corrected ABR error
-
-2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/lindex.test: added test for nested braces [Patch 423617]
-
-2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tclNamesp.c: invalidate all bytecodes in a namespace if a
- new command shadows a bytecoded command.
- * tests/namespace.test:
- Patched from [Bug 231259]
-
-2001-05-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/console.n: Created. It seems very odd to me that the console
- implementation is part of the Tcl distribution and not part of Tk, but
- given the location of the source, the documentation must obviously
- match up...
-
-2001-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * tests/string.test (string-4.14): Negative string indices should not
- be added as offsets to the result of [string first] but instead be
- treated as referring to the start of the string. [Bug 423581]
-
-2001-05-11 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Add a LDFLAGS variable to the Makefile instead of
- directly substing @LDFLAGS@.
- * unix/configure: Regen.
- * unix/tcl.m4: Fix CFLAGS_DEFAULT so that the name of a Makefile
- variable is passed as @CFLAGS@.
- * win/Makefile.in: Move the setting of CFLAGS higher up in the
- Makefile.
- * win/configure: Regen.
- * win/configure.in: Use dnl to comment out macros so that they are not
- accidently expanded.
- * win/tcl.m4: Fix CFLAGS_DEFAULT so that the name of a Makefile
- variable is passed as @CFLAGS@.
-
-2001-05-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: insure different rand() seeds in different
- threads. [Bug 416643]
-
-2001-05-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/tcltest.test: removed extraneous 'c' (doh!) [Bug: 414031]
-
- * tools/tcltk-man2html.tcl: removed use of 'exec' for portability and
- fixed up code.
-
-2001-05-03 Don Porter <dgp@users.sourceforge.net>
-
- * doc/library.n:
- * library/init.tcl:
- * tests/autoMkindex.t*: Modified [auto_import] to apply pattern
- matching in the [namespace import] style. [Bug 420186]
- ***POTENTIAL INCOMPATIBILITY*** for any callers of [auto_import] from
- outside Tcl that expect the pattern matching to be like that of
- [string match].
-
-2001-05-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclParse.c:
- * tests/namespace.test: Insure consistent behaviour of the [unknown]
- command: when a command is unknown, it is always processed by
- [::unknown], ignoring any namespace proc which happens to be called
- "unknown" [Patch 421166, Bug 420507]
-
-2001-05-02 Don Porter <dgp@users.sourceforge.net>
-
- * tools/genStubs.tcl: Add a package require of Tcl 8 at the beginning
- of the script so that the script will print a descriptive error
- message when run in an old Tcl 7 shell.
-
-2001-04-27 Kevin Kenny <kennykb@crd.ge.com>
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclCmdIL.c:
- * generic/tclProc.c:
- * generic/tclVar.c: Added another collection of missing CONSTs related
- to TclGetNamespaceForQualName.
- * generic/tclIntDecls.h: Regenerated.
-
-2001-04-25 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure: Regen.
- * unix/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
- * unix/tclConfig.sh.in: Add TCL_THREADS variable.
- * win/configure: Regen.
- * win/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
- * win/tclConfig.sh.in: Add TCL_THREADS variable.
-
-2001-04-25 Mo DeJong <mdejong@redhat.com>
-
- * unix/configure: Regen.
- * unix/configure.in: Use $@ in MAKE_LIB and MAKE_STUB_LIB commands
- instead of using a delayed subst variable. Replace instances of
- STUB_LIB_FILE with TCL_STUB_LIB_FILE.
-
-2001-04-25 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of STUB_LIB_FILE.
- * unix/configure: Regen.
- * unix/configure.in: Don't subst STUB_LIB_FILE, use TCL_STUB_LIB_FILE
- instead.
-
-2001-04-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tools/encoding/iso8859-15.txt:
- * library/encoding/iso8859-15.enc: Oops! Got the full encoding wrong.
- Should be fixed now...
-
- * tools/encoding/iso8859-15.txt:
- * library/encoding/iso8859-15.enc:
- * tools/tcl.wse.in: Added ISO 8859-15 (a.k.a. Latin-1 + Euro currency
- symbol) support.
-
- * generic/tclNamesp.c:
- * generic/tclBasic.c (TclRenameCommand): Missing CONST from several
- declarations relating to use of TclGetNamespaceForQualName
-
-2001-04-24 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/AssocData.3:
- * doc/CrtCommand.3:
- * doc/CrtMathFnc.3:
- * doc/CrtObjCmd.3:
- * doc/ExprLong.3:
- * generic/tclBasic.c:
- * generic/tclCmdMZ.c:
- * doc/CrtSlave.3:
- * generic/tclNamesp.c:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclInt.decls:
- * generic/tclInt.h: (TIP #27) Another round of CONST changes, this
- time adding CONST to the API's exported from tclBasic.c. [Patch
- 415179]
- ***POTENTIAL INCOMPATIBILITY*** from 8.4a2, in which Vince Darley's
- changes to command tracing were added. A const has been added to the
- type signature of one of the parameters to Tcl_CommandTraceProc.
-
-2001-04-10 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclUnixTime.c: Altered code to use memcpy instead of
- structure assigments in an effort to achieve better K&R
- compatibility.
-
-2001-04-10 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclUnixTime.c: Fixed silly typo in calls to 'gmtime' and
- 'localtime' that broke the Linux build.
-
-2001-04-09 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclLoadShl.c: Added DYNAMIC_PATH to the load flags so that the
- SHLIB_PATH will be searched for other libraries. [Bug 219140]
-
-2001-04-09 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tcl.m4: Added _REENTRANT to Solaris build so that thread safe
- library routines are included.
- * unix/configure: Re-ran 'autoconf' with changed tcl.m4
- * tclUnixTime.c: Modified for thread safety of 'gmtime' and
- 'localtime' system calls. [Bugs 219136 and 232558]
-
-2001-04-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/expr.test (expr-21.*): Tests to check below fix.
- * generic/tclParseExpr.c (GetLexeme): Now recognises the
- non-numeric boolean literals for what they are. It no longer makes
- sense for anyone to create functions with the same name as one of
- them, but this was true in 7.* as well [Bug 217777; finally!]
-
-2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: Avoid panic when there are extra items in the
- tcl stack. [Bug 406709, Patch 414470]
- * tests/foreach.test: test to exercise the patch
-
-2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/namespace.n: document correct functionality
- * generic/tclNamesp.c: corrected behaviour of [namespace code]
- [Bug 219385, Patch 403530]
- * library/init.tcl:
- * tests/namespace-old.test: test correct functionality
- * tests/namespace.test: test correct functionality
-
-2001-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/Makefile.in (checkdoc): New target, checking the definitions as
- found in the compiled library against the manpages to find
- undocumented public functionality.
-
- * unix/mkLinks: Updated to include the new manpage.
-
- * doc/UniCharIsAlpha.3: New manpage documenting the Unicode
- character classification APIs. [Bug 218720]
-
-2001-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/mkLinks: Updated to incorporate the changes below.
-
- * doc/StringObj.3: Added 'Tcl_AttemptSetObjLength' to the NAME
- section. [Bug 414435]
-
- * doc/Alloc.3: Added both 'Tcl_AttemptAlloc' and 'Tcl_AttemptRealloc'
- to the NAME section. [Bug 414435]
-
- * doc/Utf.3: Added both 'Tcl_UniCharCaseMatch' and
- 'Tcl_UniCharNcasecmp' to the NAME section. [Bug 414435]
-
-2001-04-06 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl:
- * tests/init.test: Modified processing of $::errorInfo by [unknown]
- when the auto-loaded command throws an error to better cover the
- tracks of auto-loading. [Bug 219280, Patch 403551]
-
-2001-04-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/read.n: Added section on "USE WITH SERIAL PORTS" to resolve
- [Bug 219402]
-
- * tests/string.test (string-2.30): Test for this case
- * generic/tclCmdMZ.c (Tcl_StringObjCmd, STR_COMPARE branch): Fixed
- problem caused by Utf-rep of \x00 being more than Utf-rep of \x01
- fooling memcmp by forcing everything through Utf-based comparisons.
- Added optimizations for case where objects have a string/unicode-rep
- or a bytearray-rep (i.e. where we can perform comparisons on
- fixed-size units). [Bug 219201]
- * generic/tclUtf.c (Tcl_UtfNcmp): Corrected seriously erroneous
- comment.
-
-2001-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * doc/Macintosh.3: Removed duplicates from .SH line. [Bug 413983]
-
-2001-04-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Fixed so will compile
- with K&R compilers. [Patch 413844, Bug 413847]
-
-2001-04-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c: Patch from Kevin Kenny to restore support of
- pre-ANSI compilers. [Bug 413846, Patch 413842]
-
-2001-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/mkLinks: Updated to contain the new manpage.
-
- * doc/Environment.3: New manpage, describes Tcl_PutEnv. [Bug 219171]
-
- * doc/Macintosh.3: New manpage describing the macintosh specific parts
- of the public API. [Bug 219169]
-
-2001-04-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: extended test of termios vs. termio vs. sgtty to
- better detect result on Linux and when certain configure
- redirections are being used. [Patch 402923; Bug 227412, 219194] (max)
-
-2001-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclTest.c:
- * tests/io.tests: TIP #10 followup correcting a problem with the
- original patch because of the lack of 'testthread id' for a
- non-threaded compilation.
-
-2001-04-04 Kevin Kenny <kennykb@acm.org>
-
- * doc/ByteArrObj.3:
- * doc/DumpActiveMemory.3:
- * doc/InitStubs.3:
- * doc/PkgRequire.3:
- * doc/StringObj.3:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBinary.c:
- * generic/tclCkalloc.c:
- * generic/tclDecls.h:
- * generic/tclListObj.c:
- * generic/tclObj.c:
- * generic/tclPkg.c:
- * generic/tclStringObj.c:
- * generic/tclStubLib.c: (TIP#27) Changed a number of Tcl API's to
- accept "CONST char*" in place of simple "char*". (kennykb) [Patch
- 404026]
-
-2001-04-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclListObj.c (Tcl_SetListObj): set objPtr->length = 0 in
- empty object case to maintain sanctity of Tcl_Obj bytes/length
- pairing. [Patch 405998] (porter)
-
-2001-04-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/mkLinks: Added 'Signal.3', 'Tcl_WaitPid'.
-
- * doc/DetachPids.3: Added description of 'Tcl_WaitPid' [Bug 219173].
-
- * doc/Signal.3: New man page describing the public API procedures
- 'Tcl_SignalId' and 'Tcl_SignalMsg'. [Bug 219172]
-
-2001-04-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README:
- * win/README:
- * win/README.binary: further notes corrections.
-
- * win/configure:
- * win/tcl.m4 (SHLIB_LD): added -incremental:no. [Bug 219381]
-
-2001-04-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README:
- * mac/README:
- * win/README:
- * win/README.binary:
- * unix/README: updated patchlevel information to 8.4a3 and updated
- links and notes.
-
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * win/configure.in (VER):
- * win/configure:
- * unix/configure:
- * unix/configure.in (VER):
- * unix/tcl.spec: updated patchlevel information to 8.4a3
-
-2001-03-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCkalloc.c (TclFinalizeMemorySubsystem): set curTagPtr
- to NULL to allow for reuse.
- * generic/tclEvent.c (Tcl_Finalize): moved the tsdPtr initialization
- inside the subsystemsInitialized check to prevent it potentially
- getting called twice during finalization.
- [Patch 403532, Bug 219391] (wu)
-
- * generic/tclThreadTest.c (Tcl_ThreadObjCmd): cast fixes
- * generic/tclTest.c (TestChannelCmd): added cast to mollify Windows
- debug build.
-
- * win/tclWinSock.c (SocketEventProc): Fixed race condition in
- readability of socket on Windows. [Patch 410674, Bug 219205, 219333]
-
- * win/tcl.m4: added imm32.lib to LIBS_GUI for Tk IME support.
-
- * win/Makefile.in (install-libraries): removed extra \s that broke
- the target.
- (install-doc): improved install-* targets to use their base build
- dependency.
-
-2001-03-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * All of the changes below belong to TIP #10 [Tcl I/O Enhancement:
- Thread-Aware Channels]. See also [Patch 403358] at SF.
-
- * generic/tclIO.h (struct ChannelState, line 236f): Extended the
- structure with a new field of type 'Tcl_ThreadId' to hold the id of
- the thread currently managing all channels with this state.
-
- Note: This structure is shared by all channels in a stack of
- transformations.
-
- * generic/tclIO.c (Tcl_CreateChannel, lines 1058-1065): Modified to
- store the Id of the current thread in the 'ChannelState' of the new
- channel.
-
- * generic/tclIO.c (Tcl_SpliceChannel, lines 2265-2270): Modified in
- the same manner as 'Tcl_CreateChannel' as the channel will be managed
- by the current thread afterward.
-
- * generic/tclIO.c (Tcl_GetChannelThread, lines 1478-1503):
- * generic/tcl.decls (Tcl_GetChannelThread, lines 1504-1506): New API
- function to retrieve the Id of the managing thread from a channel.
- Implementation and declaration.
-
- * generic/tclTest.c (TestChannelCmd, lines 4520-4532): Added
- subcommand 'mthread' to query a channel about its managing thread.
-
-2001-03-29 Mo DeJong <mdejong@redhat.com>
-
- * tests/interp.test: Print out warning when testinterpdelete command
- is not defined. Add tests that checks to make sure a child interp
- inherits the parent's cwd.
-
-2001-03-29 Jeff Hobbs <jeffh@gimlet.activestate.com>
-
- * doc/tcltest.n: corrected incorrect macro usage.
-
- * doc/lsort.n: corrected unbalanced nroff macros.
-
- * unix/tclUnixPipe.c (TclpCreateTempFile): prevent potential race
- condition and security leak in tmp filename creation.
- [Patch 402924] (max)
-
- * unix/configure:
- * unix/tcl.m4: corrected IRIX-5.x config to not use -n32.
- [Patch 403626] (english)
-
- * unix/tclUnixThrd.c (Tcl_ConditionWait): fixed handling of timeout
- for threads (corrects excessive CPU usage issue for Tk on Unix in
- threaded Tcl environment). [Bug 411603] (ruppert)
-
-2001-03-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/lsort.n: Added some notes that clarify the behaviour of
- [lsort] as well as a whole bunch of examples. [Bug 219202]
-
-2001-03-27 Jeff Hobbs <jeffh@gimlet.activestate.com>
-
- * doc/Alloc.3: corrected docs to note that Tcl_Attempt* return char
- *'s, not ints. [Bug 411388]
-
- * tests/regexp.test (regexp-19.1):
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): fixed handling of nulls in
- subspec value.
-
-2001-03-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclDecls.h (Tcl_InitCustomHashTable): Correction to patch
- from 2001-01-18; tclDecls.h was not generated using 'make genstubs'.
-
-2001-03-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * win/tclWinInt.h (tclWinTCharEncoding): Removed as now a static
- variable in win/tclWin32Dll.c instead.
-
-2001-03-23 Jeff Hobbs <jeffh@activestate.com>
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): Corrected retrieval of resultPtr
- to prevent possible corruption.
-
- * generic/tclNamesp.c (Tcl_Import): Correctly freed a DString.
- [Patch 403755] (lavana)
-
-2001-03-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/set-old.test (set-old-7.2): Changed error behaviour of
- [unset] to agree with documentation, so must change test as well.
-
-2001-03-14 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl (pkg_mkIndex): Added patch from Vince Darley to
- make [pkg_mkIndex -verbose] even more verbose. [Bug 219349, Patch
- 403529]
-
-2001-03-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/info.n: Improved documentation for [info hostname]. [Bug 403840]
-
- * generic/tclVar.c (Tcl_UnsetObjCmd): Made command behave as
- documented [issue remaining from Bug 405769]
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): A missing {return TCL_OK;}
- was causing memory corruption. [Bug 408002]
-
- * generic/tclExecute.c (TclDeleteExecEnv, GrowEvaluationStack,
- (TclExecuteByteCode): Added some casts to ClientData that are
- apparently needed on some architectures.
-
-2001-03-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/string.test: Fixed some test numberings and added a test.
- [Patch 403229]
-
-2001-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to avoid
- a read off the end of the argument array that could occur when
- executing something like [unset -nocomplain] was executed. Improved
- the error message given when not enough arguments are given (-nocomplain
- should obviously be *before* --, not after it) and also modified the
- test suite to take account of that and the documentation to use the
- same improvement. [Bug 405769]
-
-2001-03-02 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Fixed bug that could pass
- pointers to freed memory to command implementations, which most
- obviously caused some weird behaviour with [info level], but could
- have caused problems with user code and command traces too. [Bug
- 404865, Patch 405436]
-
-2001-02-23 msofer <msofer@users.sourceforge.net>
-
- * no changes; fixing up the missing comment in the previous one.
- Sorry.
-
-2001-02-23 msofer <msofer@ant.utdt>
-
- * /cvsroot/tcl/tcl/tests/execute.test: added test for evaluation of an
- expression in a variable; evals once by compiling, second time using
- the previous compilation
-
-2001-02-18 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Updated documentation to reflect the addition of
- compat/strftime.c, including the correct formatting of ISO-8601:1988
- fiscal week number (%V).
-
-2001-02-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_SplitObjCmd): Improved efficiency of
- splitting strings into individual characters by adding hash so that
- only one Tcl_Obj per character is created. Improves performance of
- splitting of short strings and makes a huge difference to splitting of
- long strings, such as is done in the mime package in tcllib. [Bug
- 131523]
-
-2001-01-31 Don Porter <dgp@users.sourceforge.net>
-
- * win/makefile.vc (install-libraries): Corrected misdirected install
- directory for the msgcat 1.2 package.
-
-2001-01-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIO.c (CopyData): Moved code that updates the count of how
- many bytes are left to copy. Corrects bug that when writing occurs in
- the background, the copy loop could be escaped without updating the
- count, causing CopyData() to try to copy more bytes than the toRead
- value originally passed to TclCopyChannel(), leading to hangs and
- misreporting of number of bytes copied. [Bug 118203, Patch 103432]
-
-2001-01-18 Andreas Kupries <a.kupries@westend.com>
-
- Everything below belongs together, it fixes [Bug 123153]
-
- * generic/tcl.h (line 342): A bit more explanation about the default
- value for TCL_PRESERVE_BINARY_COMPATABILITY.
-
- * generic/tcl.h (line 1208): Define the macro 'Tcl_InitHashTable' only
- when TCL_PRESERVE_BINARY_COMPATIBILITY is not set as it kills binary
- compatibility to 8.3 and earlier versions. This is the main part of
- the patch/change.
-
- * generic/tcl.decls (line 1469):
- * generic/tclHash.c (Tcl_InitHashTable):
- * generic/tclHash.c (Tcl_InitHashTableEx):
- * generic/tclObj.c (Tcl_InitObjHashTable): Changed
- 'Tcl_InitHashTableEx' to 'Tcl_InitCustomHashTable'. This change is
- more of an estethical nature, replacing the ubiquitous 'Ex' suffix
- with a more meaningful name. The introduced binary incompatibility is
- deemed acceptable as it is between alpha versions. Updated callers.
-
- * doc/Hash.3:
- * unix/mkLinks: Changed 'Tcl_InitHashTableEx' to
- 'Tcl_InitCustomHashTable'.
-
-2001-01-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/winPipe.test (winpipe-1.20):
- * tests/winDde.test (createChildProcess):
- * tests/pkgMkIndex.test (pkgtest::createIndex): Removed assumption
- that paths contain no spaces which causes problems with both [eval]
- and [open |...] due to the well-known differences between lists and
- strings. Fixes [Bug 119406]
-
-2001-01-04 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test:
- * unix/tclUnixInit.c (TclpInitLibraryPath):
- * win/tclWinInit.c (TclpInitLibraryPath): Several entries in the
- library path ($tcl_libPath) are determined relative to the absolute
- path of the executable. When the executable is installed in or near
- the root directory of the file system, relative pathnames were being
- incorrectly generated, and in the worst case, memory access violations
- were crashing the program. [Bug 119416, Patch 102972]
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2002 b/ChangeLog.2002
deleted file mode 100644
index 9534476..0000000
--- a/ChangeLog.2002
+++ /dev/null
@@ -1,4741 +0,0 @@
-2002-12-18 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: some uses of xcopy swapped to the @$(CPY) macro.
- Reported by Joe Mistachkin <joe@mistachkin.com>.
-
-2002-12-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclNotify.c (TclFinalizeNotifier, Tcl_SetServiceMode):
- (Tcl_ThreadAlert): Check that the stub functions are non-NULL before
- calling them. They could be set to NULL by Tcl_SetNotifier.
-
-2002-12-16 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclPipe.c (TclCleanupChildren):
- * tests/winPipe.test:
- * win/tclWinPipe.c (Tcl_WaitPid):
- * win/tclWinTest.c: Gave Tcl_WaitPid the ability to return a Win32
- exception code translated into a Posix-style SIG*. This allows [close]
- to report "CHILDKILLED" without the meaning getting lost in a
- truncated exit code. In TclCleanupChildren(), TclpGetPid() had to get
- moved to before Tcl_WaitPid() as the the handle is removed from the
- list taking away the ability to get the process id after the wait is
- done. This shouldn't effect the unix implimentaion unless waitpid is
- called with a pid of zero, meaning "any". I don't think it is..
-
-2002-12-13 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure.in: Updated configure of CVS snapshots to reflect
- * win/configure.in: the 8.4.1.1 patchlevel.
-
- * unix/configure: autoconf
- * win/configure autoconf
-
-2002-12-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclProc.c (ProcessProcResultCode): Fix failure to propagate
- negative return codes up the call stack. [Bug 647307]
- * tests/proc.test (proc-6.1): Test for Bug 647307
-
- * generic/tclParseExpr.c (TclParseInteger): Return 1 for the string
- "0x" (recognize leading "0" as an integer). [Bug 648441]
- * tests/parseExpr.test (parseExpr-19.1): Test for Bug 648441.
-
-2002-12-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinThrd.c (TclpMasterUnlock):
- * generic/tclThread.c (TclFinalizeThreadData): TclpMasterUnlock must
- exist and be called unconditional of TCL_THREADS. [Bug 651139]
-
-2002-12-08 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinSock.c (SocketThreadExitHandler, InitSockets): Check
- that the tsdPtr is valid before dereferencing as we call it from the
- exit handler, too [Bug 650353]. Another WSAStartup() loaded version
- comparison byte swap issue fixed. Although 0x0101 byte swapped is
- still 0x0101, properly claiming which is major/minor is more correct.
-
-2002-12-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclStubInit.c: regen
- * generic/tclIntPlatDecls.h: regen
- * generic/tclInt.decls: added TclWinResetInterface
-
- * win/tclWin32Dll.c (TclWinResetInterfaces):
- * win/tclWinInit.c (TclpSetInitialEncodings, WinEncodingsCleanup):
- add exit handler that resets the encoding information to a state where
- we can reuse Tcl. Following these changes, it is possible to reuse Tcl
- (following Tcl_FindExecutable or Tcl_CreateInterp) following a
- Tcl_Finalize.
-
- * generic/tclIOUtil.c (TclFinalizeFilesystem): reset statics to their
- original values on finalize to allow reuse of the library.
-
-2002-12-04 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c: reverted back to -r1.27 due to numerous test
- failures that need to be resolved first. The idea was good, but the
- details aren't.
-
-2002-12-04 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c (Tcl_WaitPid): When a process exits with an
- exception, pass this notice on to the caller with a SIG* code rather
- than truncating the exit code and missing the meaning. This allows
- TclCleanupChildren() to report "CHILDKILLED".
-
- This has a different behavior than unix in that closing the read pipe
- to a process sends the SIGPIPE signal which is returned as a SIGPIPE
- exit status. On windows, we send the process a CTRL_BREAK_EVENT and
- get back a CONTROL_C_EXIT which is documented to mean a SIGINT which
- seems wrong as a system, but is the correct exit status.
-
-2002-12-04 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to redirected 'load' in virtual filesystem
- for some Unix systems.
-
- * generic/tclEvent.c: the filesystem must be cleaned up before the
- encoding subsystem because it needs access to encodings. Fixes crash
- on exit observed in embedded applications.
-
- * generic/tclTestObj.c: patch omitted from previous change of
- 2002-11-13
-
-2002-12-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclStubLib.c (Tcl_InitStubs): prevent the cached check of
- tclStubsPtr to allow for repeated load/unload of the Tcl dll by
- hosting apps. [Bug 615304]
-
-2002-12-03 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c (sigHandler): Protect from trying to close a NULL
- handle.
-
- * win/tclWinPipe.c (PipeClose2Proc, TclpCreateProcess): Send a real
- Win32 signal (CTRL_C_EVENT) when the read channel is brought down to
- alert the child to close on its side. Start the process with
- CREATE_NEW_PROCESS_GROUP to allow the ability to send these signals.
- The following test case now brings down the child without the use of
- an external [kill] command.
-
- % set p [open "|[info name]" w+]
- file8d5380
- % pid $p
- 2876
- % close $p <- now doesn't block in Tcl_WaitPid()
- %
-
- * win/tclWinPipe.c (PipeClose2Proc): Changed CTRL_C_EVENT to
- CTRL_BREAK_EVENT as it can't be ignored by the child and proved to
- work on [open "|netstat 1" w+] where CTRL_C_EVENT didn't.
-
-2002-11-27 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPort.h: Don't turn off winsock prototypes! TclX didn't
- like it. Even though the core doesn't use the prototypes, do offer
- them.
-
- * win/tclWinSock.c: Removed shutdown() from the function table as it
- wasn't referenced anywhere and cleaned-up some casting that that
- wasn't needed.
-
- * win/tclWinSock.c: WSAStartup() loaded version comparison error which
- resulted in 2.0 looking less than 1.1.
-
- * win/tclWinChan.c (Tcl_MakeFileChannel): return of DuplicateHandle()
- incorrectly used. [Bug 618852]
-
-2002-11-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEncoding.c (TclFinalizeEncodingSubsystem): properly
- cleanup all encodings by using Tcl_FirstHashEntry in the while loop.
-
- * unix/Makefile.in (valgrind): add simple valgrind target
-
- * tests/exec.test: unset path var to allow singleproc testing
-
- * generic/tclInterp.c (AliasCreate): preserve/release interps to
- prevent possible FMR error in bad alias cases.
-
-2002-11-26 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPort.h:
- * win/tclWinSock.c: This patch does two things:
-
- 1) Cleans-up the winsock typedefs by using the typedefs provided by
- winsock2.h. This has no effect on how winsock is initialized; just
- makes the source code easier to read. [Patch 561305 561301]
-
- 2) Revamps how the socket message handler thread is brought up and
- down to allow for cleaner exits without the use of TerminateThread().
- TerminateThread is evil. No attempt has been made to resolve [Bug
- 593810] which may need a new channel driver version for adding a
- registering function within the transfered thread to init the handler
- thread. IOW, initialization of the TSD structure is getting bypassed
- through the thread extension's [thread::transfer] command.
-
-2002-11-26 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
- * win/tclWinThrd.c:
- * win/tclWinTime.c: General cleanup of all worker threads used by the
- channel drivers. Eliminates the normal case where the worker thread is
- terminated ('cept the winsock one). Instead, use kernel events to
- signal a clean exit. Only when the worker thread is blocked on an I/O
- call is the thread terminated. Essentially, this makes all other
- channel worker threads behave like the PipeReaderThread() function for
- it's cleaner exit behavior. This appears to fix [Bug 597924] but needs
- 3rd party confirmation to close the issue.
-
-2002-11-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update msys build env URL. This release #4 build both
- tcl and tk without problems.
-
-2002-11-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/init.tcl: code cleanup to reduce use of
- * library/opt/optparse.tcl: string compare
-
- * tests/interp.test: interp-14.4
- * generic/tclInterp.c (TclPreventAliasLoop): prevent seg fault when
- creating an alias command over the interp name. [Bug 641195]
-
-2002-11-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (SetEndOffsetFromAny): handle integer offset
- after the "end-" prefix.
-
- * generic/get.test:
- * generic/string.test:
- * generic/tclObj.c (SetIntFromAny, SetWideIntFromAny):
- * generic/tclGet.c (TclGetLong, Tcl_GetInt): simplify sign handling
- before calling strtoul(l). [Bug 634856]
-
-2002-11-18 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinThrd.c (Tcl_CreateThread/TclpThreadExit): Fixed improper
- compiler macros that missed the VC++ compiler. This resulted in VC++
- builds using CreateThread()/ExitThread() in place of the proper
- _beginthreadex()/_endthreadex(). This was a large error and am
- surprised I missed seeing it earlier.
-
-2002-11-13 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/regexpComp.test: added tests 22.*
- * generic/tclCompCmds.c (TclCompileRegexpCmd): add left and right
- anchoring (^ and $) recognition and check starting or ending .* to
- extend the number of REs that can be compiled to string match or
- string equal.
-
-2002-11-13 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdMZ.c:
- * tests/trace.test: applied patch from Hemang Levana to fix [Bug
- 615043] in execution traces with 'return -code error'.
-
- * generic/tclTestObj.c:
- * tests/stringObj.test: added 'knownBug' test for [Bug 635200]
- * generic/tclStringObj.c: corrected typos in comments
-
- * generic/tclFileName.c:
- * tests/fileName.test: applied patch for bug reported against tclvfs
- concerning handling of Windows serial ports like 'com1', 'lpt3' by the
- virtual filesystem code.
-
- * doc/RegExp.3: clarification of the 'extendMatch' return values.
-
-2002-11-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (Tcl_Backslash): use TclUtfToUniChar.
- (Tcl_StringCaseMatch): use TclUtfToUniChar and add further
- optimizations for the one-byte/char case.
-
- * generic/tclUtf.c: make use of TclUtfToUniChar macro throughout the
- functions, and add extra optimization to Tcl_NumUtfChars for
- one-byte/char case.
-
- * generic/tclVar.c (DisposeTraceResult, CallVarTraces): add proper
- static declarations.
-
- * generic/tclStringObj.c (Tcl_GetCharLength): optimize for the ascii
- char case.
- (Tcl_GetUniChar): remove unnecessary use of Tcl_UtfToUniChar.
- (FillUnicodeRep): Use TclUtfToUniChar.
-
- * generic/tclHash.c (HashStringKey): move string++ lower to save an
- instruction.
-
- * generic/tclExecute.c (TclExecuteByteCode): improve INST_STR_CMP to
- use memcmp in the one-byte/char case, also use direct index for
- INST_STR_INDEX in that case.
-
- * generic/tclEncoding.c (UtfToUtfProc, UtfToUnicodeProc):
- (TableFromUtfProc, EscapeFromUtfProc): Use TclUtfToUniChar.
- (UnicodeToUtfProc, TableToUtfProc): add 1-byte char optimizations for
- Tcl_UniCharToUtf call. These improve encoded channel conversion speeds
- by up to 20%.
-
- * tests/split.test: added 1-char string split tests
- * generic/tclCmdMZ.c (Tcl_SplitObjCmd): Use TclUtfToUniChar. Also
- added a special case for single-ascii-char splits.
- (Tcl_StringObjCmd): Use TclUtfToUniChar. For STR_RANGE, support
- getting ranges of ByteArrays (reverts change from 2000-05-26).
- (TraceExecutionProc) add proper static declaration.
-
- * generic/tclInt.h: add macro version of Tcl_UtfToUniChar
- (TclUtfToUniChar) that does the one-byte utf-char check without
- calling Tcl_UtfToUniChar, for use by the core. This brings notable
- speedups for primarily ascii string handling.
-
- * generic/tcl.h (TCL_PATCH_LEVEL): bump to 8.4.1.1 for patchlevel
- only. This interim number will only be reflected by [info patchlevel].
-
-2002-11-11 Kevin Kenny <kennykb@acm.org>
-
- * doc/Tcl.n: Corrected indentation of the new language. Oops.
-
-2002-11-10 Kevin Kenny <kennykb@acm.org>
-
- * doc/Tcl.n: Added language to the Endekalogue to make it clear that
- substitutions always take place from left to right. [Bug 635644]
-
-2002-11-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * changes: Note TclInExit TclInThreadExit changes.
- * generic/tclEvent.c (TclInExit, TclInThreadExit): Split out
- functionality of TclInExit to make it clear which one should be called
- in each situation.
- * generic/tclInt.decls: Declare TclInThreadExit.
- * generic/tclIntDecls.h: Regen.
- * generic/tclStubInit.c: Regen.
- * mac/tclMacChan.c (StdIOClose):
- * unix/tclUnixChan.c (FileCloseProc):
- * win/tclWinChan.c (FileCloseProc):
- * win/tclWinConsole.c (ConsoleCloseProc):
- * win/tclWinPipe.c (TclpCloseFile):
- * win/tclWinSerial.c (SerialCloseProc): Invoke the new TclInThreadExit
- method instead of TclInExit.
-
-2002-11-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Generate a fatal configure error if
- no ar program can be found on the path. [Bug 582039]
- * win/configure: Regen.
- * win/configure.in: Check that AR, RANLIB, and RC are found on the
- path when building with gcc.
-
-2002-11-03 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c: Calls Registry_Init() and Dde_Init() when
- STATIC_BUILD and TCL_USE_STATIC_PACKAGES macros are set.
-
- * win/makefile.vc:
- * win/rules.vc: linkexten option now sets the TCL_USE_STATIC_PACKAGES
- macro which also adds the registry and dde object files to the link
- of the shell. [Patch 479697] Also factored some additional macros that
- will be helpful for extension authors. Version grepping of tcl.h will
- need to be added to complete this.
-
- * win/buildall.vc.bat: Added more descriptive commentary.
-
-2002-11-01 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinReg.c: Changed the Tcl_PkgProvide() line to declare the
- registry extension at version 1.1 from 1.0.
-
-2002-10-31 Andreas Kupries <andreask@activestate.com>
-
- * library/word.tcl: Changed $tcl_platform to $::tcl_platform to avoid
- possible scope trouble.
-
-2002-10-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinInt.h:
- * win/tclWin32Dll.c: added comments about certain NULL function
- pointers which will be filled in when Tcl_FindExecutable is called, so
- that users don't report invalid bugs on this topic. (No code changes
- at all).
-
-2002-10-29 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclLoadDyld.c (TclpFindSymbol): pass all dyld error messages
- upstream [Bug 627546].
-
-2002-10-28 Andreas Kupries <andreask@activestate.com>
-
- * library/dde/pkgIndex.tcl:
- * library/reg/pkgIndex.tcl: Changed the hardwired debug suffix (d) to
- the correct suffix (g).
-
-2002-10-28 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Converted the Mac-specific [package unknown]
- * library/init.tcl: behavior to use a chaining mechanism to extend
- * library/package.tcl: the default [tclPkgUnknown]. [Bug 627660]
- * library/tclIndex: [Patch 624509] (steffen)
-
-2002-10-26 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: xcopy on NT 4.0 doesn't support the /Y switch
- (overwrite). Added logic to handle this. [Bug 618019]
-
-2002-10-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclInt.h: Removed definitions of obsolete HistoryEvent and
- HistoryRev structures (the history mechanism has been written in Tcl
- for some time now.)
-
-2002-10-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.4.1 TAGGED FOR RELEASE ***
-
- * changes: updated for 8.4.1 release
-
- * win/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
- * win/configure: regen
- * win/configure.in: removed SC_ENABLE_MEMDEBUG call
- * win/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
- SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
-
-2002-10-22 Daniel Steffen <das@users.sourceforge.net>
-
- * library/auto.tcl (tcl_findLibrary):
- * library/package.tcl (tclPkgUnknown): on macosx, search inside the
- Resources/Scripts subdirectory of any potential package directory.
- * macosx/Tcl.pbproj/project.pbxproj: add standard Frameworks dirs to
- TCL_PACKAGE_PATH make argument.
- * unix/tclUnixInit.c (TclpSetVariables): on macosx, add embedded
- framework dirs to tcl_pkgPath: @executable_path/../Frameworks and
- @executable_path/../PrivateFrameworks (if they exist), as well as the
- dirs in DYLD_FRAMEWORK_PATH (if set). [Patch 624509]
- use standard MAXPATHLEN instead of literal 1024
-
-2002-10-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/StringObj.3, doc/Object.3: Documented that Tcl_Obj's standard
- string form is a modified UTF-8; apparently, this was not mentioned
- anywhere in the main docs, and lead to [Bug 624919].
-
-2002-10-21 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: bumped version to 8.4.1
- * generic/tcl.h: Added reminder comment to edit
- macosx/Tcl.pbproj/project.pbxproj when version number changes.
-
-2002-10-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/reg/pkgIndex.tcl:
- * win/configure:
- * win/configure.in:
- * win/Makefile.in:
- * win/makefile.vc:
- * win/makefile.bc: Updated to reg1.1
-
- * doc/registry.n: Added support for broadcasting changes to the
- * tests/registry.test: registry Environment. Noted proper code in the
- * win/tclWinReg.c: docs. [Patch 625453]
-
- * unix/Makefile.in (dist): add any mac/tcl*.sea.hqx files
-
-2002-10-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclVar.c: Fixed code that check for proper # of args to
- * tests/var.test: [array names]. Added test. [Bug 624755]
-
-2002-10-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure: add workaround for cygwin windres
- * win/tcl.m4 (SC_CONFIG_CFLAGS): problem. [Patch 624010] (howell)
-
-2002-10-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README: added archives.tcl.tk note
-
- * unix/configure:
- * unix/tcl.m4: Correct AIX-5 ppc build flags. Correct HP 11 64-bit gcc
- building. [Patch 601051] (martin)
-
-2002-10-15 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdMZ.c:
- * tests/trace.test: applied patch from Hemang Levana to fix [Bug
- 615043] in execution traces with idle tasks firing.
-
-2002-10-14 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEnv.c (Tcl_PutEnv): correct possible mem leak. [Patch
- 623269] (brouwers)
-
-2002-10-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.h: Need a different strategy through the maze of
- #defines to let people building with Cygwin build correctly. Also made
- some comments less misleading...
-
-2002-10-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README: fixed minor nits [Bug 607776] (virden)
-
- * win/configure:
- * win/tcl.m4: enable USE_THREAD_ALLOC (new threaded allocator) by
- default in cygwin configure on Windows.
-
-2002-10-10 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Tcl.n: Clarified that namespace separators are legal in the
- variable names during $-subtitution. [Bug 615139]
-
- * doc/regexp.n: Typo correction. Thanks Ronnie Brunner. [Bug 606826]
-
-2002-10-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * unix/tclLoadAout.c
- * unix/tclLoadDl.c
- * unix/tclLoadDld.c
- * unix/tclLoadDyld.c
- * unix/tclLoadNext.c
- * unix/tclLoadOSF.c
- * unix/tclLoadShl.c
- * win/tclWinLoad.c: allow either full paths or simply dll names to be
- specified when loading files (the latter will be looked up by the OS
- on your PATH/LD_LIBRARY_PATH as appropriate). Fixes [Bug 611108]
-
-2002-10-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/README: doc'ed --enable-symbols options.
- * unix/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
- * unix/configure: regen
- * unix/configure.in: removed SC_ENABLE_MEMDEBUG call
- * unix/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
- SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
-
-2002-10-09 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinTime.c: Added code to set an exit handler that terminates
- the thread that calibrates the performance counter, so that the thread
- won't outlive unloading the Tcl DLL. [Bug 620735]
-
-2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/binary.n: More clarification of [binary scan]'s behaviour.
-
-2002-10-09 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclIntDecls.h: fixed botched regen.
-
-2002-10-09 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls: made TclSetPreInitScript() declaration
- generic as it is used on mac & aqua as well.
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c: regen.
- * generic/tclCompile.h: added prototype for TclCompileVariableCmd.
-
- * mac/tclMacPort.h: removed incorrect <fcntl.h> definitions and
- obsolete <stat.h> definitions.
- * mac/tclMacChan.c: removed obsolete GetOpenMode() and replaced
- associated constants with the <fcntl.h> analogues (they existing defs
- were inconsistent with <fcntl.h> which was causing havoc when
- Tcl_GetOpenMode was used instead of private GetOpenMode).
-
- * mac/tclMacFCmd.c: removed GenerateUniqueName(), use equivalent (and
- identically named) routine from MoreFiles instead.
-
- * mac/tclMacLoad.c: CONSTification, fixes to Vince's last changes.
-
- * mac/tclMacFile.c:
- * mac/tclMacTest.c:
- * mac/tclMacUnix.c: CONSTification.
-
- * mac/tclMacOSA.c: CONSTification, sprintf fixes, UH 3.4.x changes;
- fix for missing autoname token from TclOSACompileCmd. (bdesgraupes)
- * mac/AppleScript.html(AppleScript delete): doc fix. (bdesgraupes)
-
- * mac/tcltkMacBuildSupport.sea.hqx: updated MoreFiles to 1.5.3,
- updated build instructions for 8.4.
- * mac/tclMacProjects.sea.hqx: rebuilt archive.
-
-2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/Alloc.3: Added a note to mention that attempting to allocate a
- zero-length block can return NULL. [Tk Bug 619544]
-
-2002-10-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/binary.n: Doc improvements [Patch 616480]
-
- * tests/fCmd.test, tests/winFCmd.test:
- * tools/eolFix.tcl, tools/genStubs.tcl: [file exist] -> [file exists]
- Thanks to David Welton.
-
-2002-10-03 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: fixed typo [Bug 618018]. Thanks to "JJM".
-
-2002-10-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tools/man2help2.tcl:
- * tests/http.test, tests/httpd, tests/httpold.test:
- * tests/env.test, tests/binary.test, tests/autoMkindex.test:
- * library/init.tcl, library/http/http.tcl: [info exist] should really
- be [info exists]. [Bug 602566]
-
- * doc/lsearch.n: Better specification of what happens when -sorted is
- mixed with other options. [Bug 617816]
-
-2002-10-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclProc.c (TclCreateProc): mask out VAR_UNDEFINED for
- precompiled locals to support 8.3 precompiled code.
- (Tcl_ProcObjCmd): correct 2002-09-26 fix to look for tclProcBodyType.
-
-2002-10-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/socket.n: Mentioned that ports may be specified as serivce names
- as well as integers. [Bug 616843]
-
-2002-09-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c (TclCompileRegexpCmd): correct the checking
- for bad re's that didn't terminate the re string. Resultant compiles
- were correct, but much slower than necessary.
-
-2002-09-29 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c: Added proper exiting conditions using Win32
- console signals. This handles the existing lack of a Ctrl+C exit to
- call exit handlers when built for thread support. Also, properly
- handles exits from other conditions such as CTRL_CLOSE_EVENT,
- CTRL_LOGOFF_EVENT, and CTRL_SHUTDOWN_EVENT signals. In all cases,
- exit handlers will be called. [Bug 219355]
-
- * win/makefile.vc: Added missing tclThreadAlloc.c to the build rules
- and defines USE_THREAD_ALLOC when TCL_THREADS is defined to get the
- new behavior by default.
-
-2002-09-27 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bumped to version 8.4.1 to avoid confusion of
- * generic/tcl.h: CVS snapshots with the actual 8.4.0 release.
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf
- * win/configure:
-
-2002-09-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure: regen.
- * unix/tcl.m4: improve AIX-4/5 64bit compilation support.
-
- * generic/tclProc.c (Tcl_ProcObjCmd): correct overeager optimization
- of noop proc to handle the precompiled case. (sofer)
-
- * unix/ldAix (nmopts): add -X32_64 to make it work for 32 or 64bit
- mode compilation.
-
- * library/encoding/koi8-u.enc: removed extraneous spaces that confused
- encoding reader. [Bug 615115]
-
- * unix/Makefile.in: generate source dists with -src designator and do
- not generate .Z anymore (just .gz and .zip).
-
-2002-09-18 Mumit Khan <khan@nanotech.wisc.edu>
-
- Added basic Cygwin support.
-
- * win/tcl.m4 (SC_PATH_TCLCONFIG): Support one-tree build.
- (SC_PATH_TKCONFIG): Likewise.
- (SC_PROG_TCLSH): Likewise.
- (SC_CONFIG_CFLAGS): Assume real Cygwin port and remove -mno-cygwin
- flags. Add -mwin32 to extra_cflags and extra_ldflags. Remove ``-e
- _WinMain@16'' from LDFLAGS_WINDOW.
- * win/configure.in: Allow Cygwin build.
- (SEH test): Define to be 1 instead of empty value.
- (EXCEPTION_DISPOSITION): Add test.
- * win/configure: Regenerate.
-
- * generic/tcl.h: Don't explicitly define __WIN32__ for Cygwin, let the
- user decide whether to use Windows or POSIX personality.
- (TCL_WIDE_INT_TYPE, TCL_LL_MODIFIER, struct Tcl_StatBuf): Define for
- Cygwin.
- * generic/tclEnv.c (Tcl_CygwinPutenv): putenv replacement for Cygwin.
- * generic/tclFileName.c (Tcl_TranslateFileName): Convert POSIX to
- native format.
- (TclDoGlob): Likewise.
- * generic/tclPlatDecls.h (TCHAR): Define for Cygwin.
- * win/tclWinPort.h (putenv, TclpSysAlloc, TclpSysFree,
- (TclpSysRealloc): Define for Cygwin.
-
-2002-09-26 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: preserve environment value of INSTALL_ROOT. When
- embedding only use deployment build. Force relink before embedded
- build to ensure new linker flags are picked up.
-
- * macosx/Tcl.pbproj/project.pbxproj: add symbolic links to debug lib,
- stub libs and tclConfig.sh in framework toplevel. Configure target
- dependency fix. Fix to 'clean' action. Added private tcl headers to
- framework. Install tclsh symbolic link. Html doc build works when no
- installed tclsh available. Made html doc structure in framework more
- like in Apple frameworks.
-
-2002-09-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tcl.m4 (SC_TCL_64BIT_FLAGS): Yet more robust 64-bit value
- detection to close [Bug 613117] on more systems.
-
- * generic/tclCompile.c (TclPrintSource): More CONSTifying.
- * generic/tclExecute.c (EvalStatsCmd): Object-ify to reduce warnings.
- Thanks to 'CoderX2' on the chat for bringing this to my attention...
-
- * unix/tcl.m4: Forgot to define TCL_WIDE_INT_IS_LONG at the
- appropriate moment. I believe this is the cause of [Bug 613117]
-
- * doc/lset.n: Changed 'list' to 'varName' for consistency with lappend
- documentation. Thanks to Glenn Jackman [Bug 611719]
-
-2002-09-22 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected [puts -nonewline] within
- test bodies. Thanks to Harald Kirsch. [Bug 612786, Patch 612788] Also
- corrected reporting of body return code. Thanks to David Taback [Bug
- 611922]
- * library/tcltest/pkgIndex.tcl: Bump to version 2.2.1.
- * tests/tcltest.test: added tests for these bugs.
-
-2002-09-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add PEEK_XCLOSEIM define under
- Linux. This is used by Tk to double check that an X input context is
- cleaned up before it is closed.
-
-2002-09-12 David Gravereaux <davygrvy@pobox.com>
-
- * win/coffbase.txt: Added BLT to the virtual base address listings
- table should BLT's build tools decide to use it.
-
-2002-09-12 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.h:
- * mac/tclMacApplication.r:
- * mac/tclMacLibrary.r:
- * mac/tclMacResource.r: unified use of the two equivalent resource
- compiler header inclusion defines RC_INVOKED and RESOURCE_INCLUDED,
- now use RC_INVOKED throughout.
-
-2002-09-10 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/README: Add note about building extensions with the same
- compiler Tcl was built with. [Tk Bug 592096]
-
-2002-09-10 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: disabled building html
- documentation during embedded build.
-
-2002-09-10 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: added DYLIB_INSTALL_DIR variable for macosx and
- set it to default value ${LIB_RUNTIME_DIR}
- * unix/tcl.m4 (Darwin): use DYLIB_INSTALL_DIR instead of
- LIB_RUNTIME_DIR in the -install_name argument to ld.
- * unix/configure: regen.
-
- * macosx/Tcl.pbproj/project.pbxproj:
- * macosx/Makefile: added support for building Tcl as an embedded
- framework, i.e. using an dyld install_name containing
- @executable_path/../Frameworks via the new DYLIB_INSTALL_DIR
- unix/Makefile variable.
-
-2002-09-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.4.0 TAGGED FOR RELEASE ***
-
-2002-09-06 Don Porter <dgp@users.sourceforge.net>
-
- * doc/file.n: Format correction, and clarified [file normalize]
- returns an absolute path.
-
- * doc/tcltest.n: Added examples section, as long promised.
-
-2002-09-06 Reinhard Max <max@suse.de>
-
- * tests/tcltest.test: Added nonRoot flag to tests 8.3, 8.4, and 8.12.
-
-2002-09-05 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Clarified phrasing.
-
- * generic/tclBasic.c (TclRenameCommand,CallCommandTraces):
- * tests/trace.test (trace-27.1): Corrected memory leak when a rename
- trace deleted the command being traced. Test added. Thanks to Hemang
- Lavana for the fix. [Bug 604609]
-
- * generic/tclVar.c (TclDeleteVars): Corrected logic for setting the
- TCL_INTERP_DESTROYED flag when calling variable traces. [Tk Bug 605121]
-
-2002-09-04 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c (DeleteArray): leak plug [Bug 604239]. Thanks to
- dkf and dgp for the long and difficult discussion in the chat.
-
-2002-09-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclVar.c (Tcl_UpVar2): code cleanup to not use goto
-
- * unix/configure: remove -pthread from LIBS on FreeBSD in thread
- * unix/tcl.m4: enabled build. [Bug 602849]
-
-2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInterp.c (AliasCreate): a Tcl_Obj was leaked on error
- return from TclPreventAliasLoop.
-
-2002-09-03 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: Bumped version number to 8.4.0
- and updated copyright info.
-
-2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c (Tcl_UpVar2): a Tcl_Obj was being leaked on error
- return from TclGetFrame.
-
-2002-09-03 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated changes for 8.4.0 release.
-
-2002-09-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFile.c (TclpObjLink): removed unnecessary/unfreed extra
- native char*.
-
- * unix/tclUnixChan.c (Tcl_MakeTcpClientChannel): make sure to init
- flags field of TcpState ptr to 0.
-
- * unix/configure:
- * unix/tcl.m4: added 64-bit gcc compilation support on HP-11.
- [Patch 601051] (martin)
-
- * README: Bumped version number to 8.4.0
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure:
- * win/configure.in:
-
- * generic/tclInterp.c (SlaveCreate): make sure that the memory and
- checkmem commands are initialized in non-safe slave interpreters when
- TCL_MEM_DEBUG is used. [Bug 583445]
-
- * win/tclWinConsole.c (ConsoleCloseProc): only wait on writable pipe
- if there was something to write. This may prevent infinite wait on
- exit.
-
- * tests/exec.test: marked exec-18.1 unixOnly until the Windows
- incompatibility (in the test, not the core) can be resolved.
-
- * tests/http.test (http-3.11): added close $fp that was causing an
- error on Windows because the file was not closed before deleting.
-
- * unix/tclUnixInit.c (Tcl_MacOSXGetLibraryPath): made this static
- function only appear when HAVE_CFBUNDLE is defined.
-
-2002-08-31 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: added TK_SHLIB_LD_EXTRAS analogue of existing
- TCL_SHLIB_LD_EXTRAS for linker settings only used when linking Tk.
-
- * unix/configure: regen
-
-2002-08-31 Daniel Steffen <das@users.sourceforge.net>
-
- *** macosx-8-4-branch merged into the mainline [Patch 602770] ***
-
- * generic/tcl.decls: added new macosx specific entry to stubs table.
-
- * tools/genStubs.tcl: added generation of platform guards for
- macosx. This is a little more complex than it seems, because MacOS X
- IS "unix" plus a little bit, for the purposes of Tcl. BUT
- unfortunately, Tk uses "unix" to mean X11. So added platform keys for
- macosx (the little added to "unix"), "aqua" and "x11" to distinguish
- these for Tk.
-
- * generic/tcl.h: added a #ifnded RESOURCE_INCLUDED so that tcl.h can
- be passed to the resource compiler.
-
- * generic/tcl.h:
- * generic/tclNotify.c: added a few Notifier procs, to be able to
- modify more bits of the Tcl notifier dynamically. Required to get Mac
- OS X Tk to live on top of the Tcl Unix threaded notifier. Changes the
- size of the Tcl_NotifierProcs structure, but doesn't move any elements
- around.
-
- * unix/tclUnixNotfy.c: moved the call to Tcl_ConditionNotify till
- AFTER we are done mucking with the pointer swap. Fixes cases where the
- thread waiting on the condition wakes & accesses the waitingListPtr
- before it gets reset, causing a hang.
-
- * library/auto.tcl (tcl_findLibrary): added checking the directories
- in the tcl_pkgPath for library files on macosx to enable support of
- the standard Mac OSX library locations.
-
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/tcl.m4: added MAC_OSX_DIR. Added PLAT_OBJS to the OBJS: there
- are some MacOS X specific files now for Tcl, and when I get the
- resource & applescript stuff ported over, and restore support for
- FindFiles, etc, there will be a few more. Added LD_LIBRARY_PATH_VAR
- configure variable to avoid having to set all possible LD_LIBRARY_PATH
- analogues on all platforms. LD_LIBRARY_PATH_VAR is "LD_LIBRARY_PATH"
- by default, "LIBPATH" on AIX, "SHLIB_PATH" on HPUX and
- "DYLD_LIBRARY_PATH" on Mac OSX. Added configure option to package Tcl
- as a framework on Mac OSX.
-
- * macosx/tclMacOSXBundle.c (new): support for finding Tcl extension
- packaged as 'bundles' in the standard Mac OSX library locations.
-
- * unix/tclUnixInit.c: added support for findig the tcl script library
- inside Tcl packaged as a framework on Mac OSX.
-
- * macosx/Tcl.pbproj/jingham.pbxuser (new):
- * macosx/Tcl.pbproj/project.pbxproj (new): project for Apple's
- ProjectBuilder IDE.
-
- * macosx/Makefile (new): simple makefile for building the project from
- the command line via the ProjectBuilder tool 'pbxbuild'.
-
- * unix/configure:
- * generic/tclStubInit.c:
- * generic/tclPlatDecls.h: regen
-
-2002-08-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinThrd.c (TclpFinalizeThreadData, TclWinFreeAllocCache):
- Applied patch for [Bug 599428], provided by Miguel Sofer
- <msofer@users.sourceforge.net>.
-
-2002-08-28 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclEnv.c:
- * unix/configure.in:
- * win/tclWinPort.h: putenv() on some systems copies the buffer rather
- than taking reference to it. This causes memory leaks and is know to
- effect mswindows (msvcrt) and NetBSD 1.5.2 . This patch tests for this
- behavior and turns on -DHAVE_PUTENV_THAT_COPIES=1 when approriate.
- Thanks to David Welton for assistance. [Bug 414910]
-
- * unix/configure: regen'd
-
-2002-08-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/eval.n: Added mention of list command and corrected "SEE ALSO".
-
- * unix/configure.in: Cache handling of ac_cv_type_socklen_t was wrong.
- [Bug 600931] reported by John Ellson. Fixed by putting the brackets
- where they belong.
-
-2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c: fix for [Bug 599788] (error in element name
- causing segfault), reported by Tom Wilkason. Fixed by copying the
- tokens instead of the source string.
-
-2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclThreadAlloc.c: small optimisation, reducing the new
- allocator's overhead.
-
-2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclObj.c (USE_THREAD_ALLOC): fixed leak [Bug 597936]. Thanks
- to Zoran Vasiljevic.
-
-2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclThreadAlloc.c (USE_THREAD_ALLOC): moving objects between
- caches as a block, instead of one-by-one.
-
-2002-08-22 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c:
- * generic/tclCmdMZ.c: fix for freed memory r/w in delete traces [Bug
- 589863], patch by Hemang Lavana.
-
-2002-08-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/Makefile.in (CFLAGS):
- * unix/Makefile.in (MEM_DEBUG_FLAGS): Added usage of @MEM_DEBUG_FLAGS@.
- * win/configure.in:
- * unix/configure.in: Added usage of SC_ENABLE_MEMDEBUG.
- * win/tcl.m4:
- * unix/tcl.m4: Added macro SC_ENABLE_MEMDEBUG. Allows a user of
- configure to (de)activate memory validation and debugging
- (TCL_MEM_DEBUG). No need to modify the makefile anymore.
-
-2002-08-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCkalloc.c: CONSTified MemoryCmd and CheckmemCmd.
-
- * README: Bumped version number to 8.4b3 to distinguish
- * generic/tcl.h: HEAD from the 8.4b2 release.
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure.in:
-
- * unix/configure: autoconf
- * win/configure:
-
- * library/http/http.tcl: Corrected installation directory of
- * library/msgcat/msgcat.tcl: the package tcltest 2.2. Added
- * library/opt/optparse.tcl: comments in other packages to remind
- * library/tcltest/tcltest.tcl: that installation directories need
- * unix/Makefile.in: updates to match increasing version
- * win/Makefile.in: numbers. [Bug 597450]
- * win/makefile.bc:
- * win/makefile.vc:
-
-2002-08-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/tclUnixTest.c (TestfilehandlerCmd): Changed readable/writable
- to the more common readable|writable. Fixes [Bug 596034] reported by
- Larry Virden <lvirden@users.sourceforge.net>.
-
-2002-08-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/fCmd.test: Added test to make sure that the cause of the
- problem is detectable with an unpatched Tcl.
- * doc/ObjectType.3: Added note on the root cause of this problem to
- the documentation, since it is possible for user code to trigger this
- sort of behaviour too.
- * generic/tclIOUtil.c (SetFsPathFromAny): Objects should only have
- their old representation deleted when we know that we are about to
- install a new one. This stops a weird TclX bug under Linux with
- certain kinds of memory debugging enabled which essentally came down
- to a double-free of a string.
-
-2002-08-14 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tclObj.c: (code cleanup) factored the parts in the macros
- TclNewObj() / TclDecrRefCount() into a common part for all
- memory allocators and two new macros TclAllocObjStorage() /
- TclFreeObjStorage() that are specific to each allocator and fully
- describe the differences. Removed allocator-specific code from
- tclObj.c by using the macros.
-
-2002-08-12 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: fixing UMR in delete traces, [Bug 589863].
-
-2002-08-08 David Gravereaux <davygrvy@pobox.com>
-
- * tools/man2help.tcl: Fixed $argv handling bug where if -bitmap wasn't
- specified $argc was off by one.
-
-2002-08-08 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/uplevel.test: added 6.1 to test [uplevel] with shadowed
- commands [Bug 524383]
-
- * tests/subst.test: added 5.8-10 as further tests for [Bug 495207]
-
-2002-08-08 Don Porter <dgp@users.sourceforge.net>
-
- * tests/README: Noted removal of defs.tcl.
-
-2002-08-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/lsearch.n: corrected lsearch docs to use -inline in examples.
-
- *** 8.4b2 TAGGED FOR RELEASE ***
-
- * tests/fCmd.test:
- * tests/unixFCmd.test: updated tests for new link copy behavior.
- * generic/tclFCmd.c (CopyRenameOneFile): changed the behavior to
- follow links to endpoints and copy that file/directory instead of just
- copying the surface link. This means that trying to copy a link that
- has no endpoint (danling link) is an error. [Patch 591647] (darley)
- (CopyRenameOneFile): this is currently disabled by default until
- further issues with such behavior (like relative links) can be
- handled correctly.
-
- * tests/README: slight wording improvements
-
-2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * docs/BoolObj.3: added description of valid string reps for a
- boolean object. [Bug 584794]
- * generic/tclObj.c: optimised Tcl_GetBooleanFromObj and
- SetBooleanFromAny to avoid parsing the string rep when it can be
- avoided. [Bugs 584650, 472576]
-
-2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.h:
- * generic/tclObj.c: making tclCmdNameType static ([Bug 584567], Don
- Porter).
-
-2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclObj.c (Tcl_NewObj): added conditional code for
- USE_THREAD_ALLOC; objects allocated through Tcl_NewObj() were
- otherwise being leaked. [Bug 587488] reported by Sven Sass.
-
-2002-08-06 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * unix/tclUnixThrd.c: Added stubs and implementations for
- non-threaded build for the tclUnixThrd.c procs TclpReaddir,
- TclpLocaltime, TclpGmtime and TclpInetNtoa. Fixes link errors in
- stubbed & threaded extensions that include tclUnixPort.h and use any
- of the procs readdir, localtime, gmtime or inet_ntoa (e.g. TclX 8.4)
- [Bug 589526]
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: Regen.
-
-2002-08-05 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: The setup and cleanup scripts are now
- * library/tcltest/pkgIndex.tcl: skipped when a test is skipped, fixing
- * tests/tcltest.test: [Bug 589859]. Test for bug added, and
- corrected tcltest package bumped to version 2.2.
-
- * generic/tcl.decls: Restored Tcl_Concat to return (char *). Like
- * generic/tclDecls.h: Tcl_Merge, it transfers ownership of a dynamic
- * generic/tclUtil.c: allocated string to the caller.
-
-2002-08-04 Don Porter <dgp@users.sourceforge.net>
-
- * doc/CmdCmplt.3: Applied Patch 585105 to fully CONST-ify all
- * doc/Concat.3: remaining public interfaces of Tcl. Notably,
- * doc/CrtCommand.3: the parser no longer writes on the string it
- * doc/CrtSlave.3: is parsing, so it is no longer necessary for
- * doc/CrtTrace.3: Tcl_Eval() to be given a writable string. Also
- * doc/Eval.3: the refactoring of the Tcl_*Var* routines by
- * doc/ExprLong.3: by Miguel Sofer is included, so that the
- * doc/LinkVar.3: "part1" argument for them no longer needs to
- * doc/ParseCmd.3: be writable either.
- * doc/SetVar.3:
- * doc/TraceVar.3:
- * doc/UpVar.3: Compatibility support has been enhanced so
- * generic/tcl.decls: that a #define of USE_NON_CONST will remove
- * generic/tcl.h: all possible source incompatibilities with the
- * generic/tclBasic.c: 8.3 version of the header file(s). The new
- * generic/tclCmdMZ.c: #define of USE_COMPAT_CONST now does what
- * generic/tclCompCmds.c:USE_NON_CONST used to do -- disable only those
- * generic/tclCompExpr.c:new CONST's that introduce irreconcilable
- * generic/tclCompile.c: incompatibilities.
- * generic/tclCompile.h:
- * generic/tclDecls.h: Several bugs are also fixed by this patch.
- * generic/tclEnv.c: [Bugs 584051,580433] [Patches 585105,582429]
- * generic/tclEvent.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclInterp.c:
- * generic/tclLink.c:
- * generic/tclObj.c:
- * generic/tclParse.c:
- * generic/tclParseExpr.c:
- * generic/tclProc.c:
- * generic/tclTest.c:
- * generic/tclUtf.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
- * mac/tclMacTest.c:
- * tests/expr-old.test:
- * tests/parseExpr.test:
- * unix/tclUnixTest.c:
- * unix/tclXtTest.c:
- * win/tclWinTest.c:
-
-2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: bugfix (reading freed memory). Testsuite
- passed on linux/i386, compile-13.1 hung on linux/alpha.
-
-2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: added a reference count for the complete
- execution stack, instead of Tcl_Preserve/Tcl_Release.
-
-2002-08-01 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclCkalloc.c (TclFinalizeMemorySubsystem): Don't lock the
- ckalloc mutex before invoking the Tcl_DumpActiveMemory function since
- it also locks the same mutex. This code is only executed when "memory
- onexit filename" has been executed and Tcl is compiled with
- -DTCL_MEM_DEBUG.
-
-2002-08-01 Reinhard Max <max@suse.de>
-
- * win/tclWinPort.h: The windows headers don't provide socklen_t, so we
- have to do it.
-
-2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInt.h (USE_THREAD_ALLOC): for unshared objects,
- TclDecrRefCount now frees the internal rep before the string rep -
- just like the non-macro Tcl_DecrRefCount/TclFreeObj [Bug 524802]. For
- the other allocators the fix was done on 2002-03-06.
-
-2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInterp.c: signed/unsigned comparison warning fixed
- (Vince Darley).
-
-2002-07-31 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tcl.m4 (SC_BUGGY_STRTOD): Enabled caching of test results.
-
- * unix/tcl.m4 (SC_BUGGY_STRTOD): Solaris 2.8 still has a buggy
- strtod() implementation; make sure we detect it.
-
- * tests/expr.test (expr-22.*): Marked as non-portable because it seems
- that these tests have an annoying tendency to fail in unexpected ways.
- [Bugs 584825, 584950, 585986]
-
-2002-07-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/io.test:
- * generic/tclIO.c (WriteChars): Added flag to break out of loop if
- nothing of the input is consumed at all, to prevent infinite looping
- of called with a non-UTF-8 string. Fixes Bug 584603 (partially). Added
- new test "io-60.1". Might need additional changes to Tcl_Main so that
- unprintable results are printed as binary data.
-
-2002-07-29 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Use CC_SEARCH_FLAGS instead of LD_SEARCH_FLAGS
- when linking with ${CC}.
- * unix/configure: Regen.
- * unix/configure.in: Don't subst CC_SEARCH_FLAGS or LD_SEARCH_FLAGS
- since this is now done in tcl.m4.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Document and set CC_SEARCH_FLAGS
- whenever LD_SEARCH_FLAGS is set. [Patch 588290]
-
-2002-07-29 Reinhard Max <max@suse.de>
-
- * unix/tcl.m4 (SC_SERIAL_PORT): Fixed detection for cases when
- configure's stdin is not a tty.
-
- * unix/tclUnixPort.h:
- * generic/tclIOSock.c: Changed size_t to socklen_t in
- socket-related function calls.
-
- * unix/configure.in: Added test and fallback definition
- for socklen_t.
-
- * unix/configure: generated.
-
-2002-07-29 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclObj.c: fixed a comment
-
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclInterp.c: added the new flag TCL_EVAL_INVOKE to the
- interface of the Tcl_Eval* functions, removing the
- TCL_EVAL_NO_TRACEBACK added yesterday: alias invocations not only
- require no tracebacks, but also look up the command name in the global
- scope - see new test interp-9.4
- * tests/interp.test: added 9.3 to test for safety of aliases to hidden
- commands, 9.4 to test for correct command lookup scope.
-
-2002-07-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/regc_locale.c (cclass): [[:xdigit:]] is only a defined
- concept on western characters, so should not allow any unicode digit,
- and hence number of ranges in [[:xdigit:]] is fixed.
- * tests/reg.test: Added test to detect the bug.
- * generic/regc_cvec.c (newcvec): Corrected initial size value in
- character vector structure. [Bug 578363] Many thanks to
- pvgoran@users.sf.net for tracking this down.
-
-2002-07-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tcl.h:
- * generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to the
- interface of the Tcl_Eval* functions. Modified the error message for
- too many nested evaluations.
- * generic/tclInterp.h: changed the Alias struct to be of variable
- length and store the prefix arguments directly (instead of a pointer
- to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv instead of
- TclObjInvoke - thus making aliases trigger execution traces [Bug
- 582522].
- * tests/interp.test:
- * tests/stack.test: adapted to the new error message.
- * tests/trace.test: added tests for aliases firing the exec traces.
-
-2002-07-27 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Revert fix for Tcl bug 529801 since it was
- incorrect and broke the build on other systems. Fix [Bug 587299]. Add
- MAJOR_VERSION, MINOR_VERSION, PATCH_LEVEL, SHLIB_LD_FLAGS,
- SHLIB_LD_LIBS, CC_SEARCH_FLAGS, LD_SEARCH_FLAGS, and LIB_FILE
- variables to support more generic library build/install rules.
- * unix/configure: Regen.
- * unix/configure.in: Move AC_PROG_RANLIB into tcl.m4. Move shared
- build test and setting of MAKE_LIB and MAKE_STUB_LIB into tcl.m4. Move
- subst of a number of variables into tcl.m4 where they are defined.
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS): Subst vars where
- they are defined. Add MAKE_LIB, MAKE_STUB_LIB, INSTALL_LIB, and
- INSTALL_STUB_LIB rules to deal with the ugly details of running ranlib
- on static libs at build and install time. Replace TCL_SHLIB_LD_EXTRAS
- with SHLIB_LD_FLAGS and use it when building a shared library.
- * unix/tclConfig.sh.in: Add TCL_CC_SEARCH_FLAGS.
-
-2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: fixed Tcl_Obj leak in code corresponding to
- the macro NEXT_INST_V(x, 0, 1) [Bug 587495].
-
-2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c (TclObjLookupVar): leak fix and improved comments.
-
-2002-07-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclVar.c (TclLookupVar): removed early returns that
- prevented the parens from being restored. Also removed goto label as
- it was not necessary.
-
-2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c:
- * tests/expr-old.test: fix for erroneous error messages in [expr],
- [Bug 587140] reported by Martin Lemburg.
-
-2002-07-25 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclProc.c: fix for [Tk Bug 219218] "error handling with
- bgerror in Tk"
-
-2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: restoring full TCL_COMPILE_DEBUG
- functionality.
-
-2002-07-24 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test: relaxed unixInit-3.1 to accept iso8859-15 as a
- valid C encoding. [Bug 575336]
-
-2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: restoring the tcl_traceCompile functionality
- while I repair tcl_traceExec. The core now compiles and runs also
- under TCL_COMPILE_DEBUG, but execution in the bytecode engine can
- still not be traced.
-
-2002-07-24 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in:
- * unix/configure.in: corrected fix for [Bug 529801]: ranlib only
- needed for static builds on Mac OS X.
- * unix/configure: Regen.
- * unix/tclLoadDyld.c: fixed small bugs introduced by Vince,
- implemented library unloading correctly (needs OS X 10.2).
-
-2002-07-23 Joe English <jenglish@users.sourceforge.net>
-
- * doc/OpenFileChnl.3: (Updates from Larry Virden)
- * doc/open.n:
- * doc/tclsh.1: Fix section numbers in Unix man page references.
- * doc/lset.n: In EXAMPLES section, include command to set the initial
- value used in subsequent examples.
- * doc/http.n: Package version updated to 2.4.
-
-2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Enable 64 bit compilation when using
- the native compiler on a 64 bit version of IRIX. [Bug 219220]
-
-2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Combine ranlib tests and avoid printing unless
- ranlib is actually run.
-
-2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_PATH_X): Set XINCLUDES to "" instead of "# no
- special path needed" or "# no include files found" when x headers
- cannot be located.
-
-2002-07-22 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: made tclNativeFilesystem static (since 07-19
- changes removed its usage elsewhere), and added comments about its
- usage.
- * generic/tclLoad.c:
- * generic/tcl.h:
- * generic/tcl.decls:
- * doc/FileSystem.3: converted last load-related ClientData parameter
- to Tcl_LoadHandle opaque structure, removing a couple of casts in the
- process.
-
- * generic/tclInt.h: removed tclNativeFilesystem declaration since it
- is now static again.
-
-2002-07-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/expr.test (expr-22.*): Added tests to help detect the
- corrected handling.
- * generic/tclExecute.c (IllegalExprOperandType): Improved error
- message generated when attempting to manipulate Inf and NaN values.
- * generic/tclParseExpr.c (GetLexeme): Allowed parser to recognise
- 'Inf' as a floating-point number. [Bug 218000]
-
-2002-07-21 Don Porter <dgp@users.sourceforge.net>
-
- * tclIOUtil.c: Silence compiler warning. [Bug 584408].
-
-2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to GetFilesystemRecord
- * win/tclWinFile.c:
- * unix/tclUnixFile.c: fix to subtle problem with links shown up by
- latest tclkit builds.
-
-2002-07-19 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure:
- * unix/configure.in:
- * win/configure:
- * win/configure.in: Add AC_PREREQ(2.13) in an attempt to make it more
- clear that the configure scripts must be generated with autoconf
- version 2.13. [Bug 583573]
-
-2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * unix/Makefile.in: fix to build on MacOS X [Bug 529801], bug report
- and fix from jcw.
-
-2002-07-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * win/tclWinSerial.c (no_timeout): Made this variable static.
-
- * generic/tclExecute.c, generic/tclCompile.c, generic/tclBasic.c:
- * generic/tclCompile.h (builtinFuncTable, instructionTable): Added
- prefix to these symbols because they are visible outside the Tcl
- library.
-
- * generic/tclCompExpr.c (operatorTable):
- * unix/tclUnixTime.c (tmKey):
- * generic/tclIOUtil.c (theFilesystemEpoch, filesystemWantToModify,
- filesystemIteratorsInProgress, filesystemOkToModify): Made these
- variables static.
-
- * unix/tclUnixFile.c: Renamed nativeFilesystem to
- * win/tclWinFile.c: tclNativeFilesystem and declared
- * generic/tclIOUtil.c: it properly in tclInt.h
- * generic/tclInt.h:
-
- * generic/tclUtf.c (totalBytes): Made this array static and const.
-
- * generic/tclParse.c (typeTable): Made this array static and const.
- (Tcl_ParseBraces): Simplified error handling case so that scans are
- only performed when needed, and flags are simpler too.
-
- * license.terms: Added AS to list of copyright holders; it's only
- fair for the current gatekeepers to be listed here!
-
- * tests/cmdMZ.test: Renamed constraint for clarity. [Bug 583427]
- Added tests for the [time] command, which was previously only
- indirectly tested!
-
-2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tcl.h:
- * */*Load*.c: added comments on changes of 07/17 and replaced
- clientData with Tcl_LoadHandle in all locations.
-
- * generic/tclFCmd.c:
- * tests/fileSystem.test: fixed a 'knownBug' with 'file attributes ""'
- * tests/winFCmd.test:
- * tests/winPipe.test:
- * tests/fCmd.test:
- * tessts/winFile.test: added 'pcOnly' constraint to some tests to make
- for more useful 'tests skipped' log from running all tests on
- non-Windows platforms.
-
-2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (CallCommandTraces): delete traces now receive
- the FQ old name of the command. [Bug 582532] (Don Porter)
-
-2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/ioUtil.test: added constraints to 1.4,2.4 so they don't run
- outside of tcltest. [Bugs 583276, 583277]
-
-2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c (DupParsedVarName): nasty bug fixed, reported by
- Vince Darley.
-
-2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c (TclPtrIncrVar): missing CONST in declarations,
- inconsistent with tclInt.h. Thanks to Vince Darley for reporting, boo
- to gcc for not complaining.
-
-2002-07-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tclIOUtil.c:
- * generic/tclLoadNone.c:
- * unix/tclLoadAout.c:
- * unix/tclLoadDl.c:
- * unix/tclLoadDld.c:
- * unix/tclLoadDyld.c:
- * unix/tclLoadNext.c:
- * unix/tclLoadOSF.c:
- * unix/tclLoadShl.c:
- * mac/tclMacLoad.c:
- * win/tclWinLoad.c: modified to move more functionality to the generic
- code and avoid duplication. Partial replacement of internal uses of
- clientData with opaque Tcl_LoadHandle. A little further work still
- needed, but significant changes are done.
-
-2002-07-17 D. Richard Hipp <drh@hwaci.com>
-
- * library/msgcat/msgcat.tcl: fix a comment that was causing problems
- for programs (ex: mktclapp) that embed the initialization scripts in
- strings.
-
-2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclVar.c: removing the now redundant functions to access
- indexed variables: Tcl(Get|Set|Incr)IndexedScalar() and
- Tcl(Get|Set|Incr)ElementOfIndexedArray().
-
-2002-07-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Minor fixes to make this
- file compile with SunPro CC...
-
-2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: modified to do variable lookup explicitly, and
- then either inlining the variable access or else calling the new
- TclPtr(Set|Get|Incr)Var functions in tclVar.c
- * generic/tclInt.h: declare some functions previously local to
- tclVar.c for usage by TEBC.
- * generic/tclVar.c: removed local declarations; moved all special
- accessor functions for indexed variables to the end of the file -
- they are unused and ready for removal, but left there for the time
- being as they are in the internal stubs table.
-
- ** WARNING FOR BYTECODE MAINTAINERS **
- TCL_COMPILE_DEBUG is currently not functional; will be fixed ASAP.
-
-2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in:
- * win/Makefile.in: Add a more descriptive warning in the event `make
- genstubs` needs to be rerun.
-
-2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Use dltest.marker file to keep track of when the
- dltest package is up to date. This fixes [Bug 575768] since tcltest is
- no longer linked every time.
- * unix/dltest/Makefile.in: Create ../dltest.marker after a successful
- `make all` run in dltest.
-
-2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/configure.in: Remove useless subst of TCL_BIN_DIR.
-
-2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c: inaccurate comment fixed
-
-2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_AddObjErrorInfo):
- * generic/tclExecute.c (TclUpdateReturnInfo):
- * generic/tclInt.h:
- * generic/tclProc.c:
- Added two Tcl_Obj to the ExecEnv structure to hold the fully qualified
- names "::errorInfo" and "::errorCode" to cache the addresses of the
- corresponding variables. The two most frequent setters of these
- variables now profit from the new variable name caching.
-
-2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclVar.c: refactorisation to reuse already looked-up Var
- pointers; definition of three new Tcl_Obj types to cache variable name
- parsing and lookup for later reuse; modification of internal functions
- to profit from the caching.
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclNamesp.c: adding CONST qualifiers to variable names
- passed to Tcl_FindNamespaceVar and to variable resolvers; adding CONST
- qualifier to the 'msg' argument to TclLookupVar. Needed to avoid code
- duplication in the new tclVar.c code.
-
- * tests/set-old.test:
- * tests/var.test: slight modification of error messages due to the
- modifications in the tclVar.c code.
-
-2002-07-15 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test: Improved constraints to protect /tmp. [Bug
- 581403]
-
-2002-07-15 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/winFCmd.test: renamed 'win2000' and 'notWin2000' to more
- appropriate constraint names.
- * win/tclWinFile.c: updated comments to reflect 07-11 changes.
- * win/tclWinFCmd.c: made ConvertFileNameFormat static again, since no
- longer used in tclWinFile.c
- * mac/tclMacFile.c: completed TclpObjLink implementation which was
- previously lacking.
- * generic/tclIOUtil.c: comment cleanup and code speedup.
-
-2002-07-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Removed declarations that duplicated entries
- in the (internal) stub table.
-
- * library/tcltest/tcltest.tcl: Corrected errors in handling of
- configuration options -constraints and -limitconstraints.
-
- * README: Bumped HEAD to version 8.4b2 so we can
- * generic/tcl.h: distinguish it from the 8.4b1 release.
- * tools/tcl.wse.in:
- * unix/configure*:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure*:
-
-2002-07-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n:
- * win/tclWinFile.c: on Win 95/98/ME the long form of the path is used
- as a normalized form. This is required because short forms are not a
- robust representation. The file normalization function has been sped
- up, but more performance gains might be possible, if speed is still an
- issue on these platforms.
-
-2002-07-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected reaction to existing but
- false ::tcl_interactive.
-
- * doc/Hash.3: Overlooked CONST documentation update.
-
-2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCkalloc.c: ckalloc() and friends take the block size as
- an unsigned, so we should use %ud when reporting it in fprintf() and
- panic().
-
-2002-07-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.c: now setting local vars undefined at compile
- time, instead of waiting until the proc is initialized.
- * generic/tclProc.c: use macro TclSetVarUndefined instead of directly
- setting the flag.
-
-2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdAH.test: [file attr -perm] is Unix-only, so add [catch]
- when not inside a suitably-protected test.
-
-2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/unixFCmd.test, tests/fileName.test:
- * tests/fCmd.test: Removed [exec] of Unix utilities that have
- equivalents in standard Tcl. [Bug 579268] Also simplified some of
- unixFCmd.test while I was at it.
-
-2002-07-10 Don Porter <dgp@users.sourceforge.net>
-
- * tests/tcltest.test: Greatly reduced the number of [exec]s, using
- slave interps instead.
- * library/tcltest/tcltest.tcl: Fixed bug uncovered in the conversion
- where a message was written to stdout instead of [outputChannel].
-
- * tests/basic.test: Cleaned up, constrained, and reduced the
- * tests/compile.test: amount of [exec] usage in the test suite.
- * tests/encoding.test:
- * tests/env.test:
- * tests/event.test:
- * tests/exec.test:
- * tests/io.test:
- * tests/ioCmd.test:
- * tests/regexp.test:
- * tests/regexpComp.test:
- * tests/socket.test:
- * tests/tcltest.test:
- * tests/unixInit.test:
- * tests/winDde.test:
- * tests/winPipe.test:
-
-2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdAH.test: Removed [exec] of Unix utilities. [Bug 579211]
-
- * tests/expr.test: Added tests to make sure that this works.
- * generic/tclExecute.c (ExprCallMathFunc): Functions should also be
- able to return wide-ints. [Bug 579284]
-
-2002-07-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/socket.test: Fixed [Bug 578164]. The original reason for the
- was a DNS outage while running the testsuite. Changed [info hostname]
- to 127.0.0.1 to bypass DNS, knowing that we operate on the local host.
-
-2002-07-08 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Fixed incompatibility in [viewFile].
- * library/tcltest/tcltest.tcl: Corrected docs. Bumped to 2.2.1.
- * library/tcltest/pkgIndex.tcl: [Bug 578163]
-
-2002-07-08 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/cmdAH.test:
- * tests/fCmd.test:
- * tests/fileName.test: tests which rely on 'file link' need a
- constraint so they don't run on older Windows OS. [Bug 578158]
- * generic/tclIOUtil.c:
- * generic/tcl.h:
- * generic/tclInt.h:
- * generic/tclTest.c:
- * mac/tclMacChan.c:
- * unix/tclUnixChan.c:
- * win/tclWinChan.c:
- * doc/FileSystem.3: cleaned up internal handling of
- Tcl_FSOpenFileChannel to remove duplicate code, and make writing
- external vfs's clearer and easier. No functionality change. Also
- clarify that objects with refCount zero should not be passed in to the
- Tcl_FS API, and prevent segfaults from occuring on such user errors.
- [Bug 578617]
-
-2002-07-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/pkgMkIndex.test: Constrained tests of [load] package indexing
- to those platforms where the testing shared libraries have been built.
- [Bug 578166]
-
-2002-07-05 Don Porter <dgp@users.sourceforge.net>
-
- * changes: added recent changes
-
-2002-07-05 Reinhard Max <max@suse.de>
-
- * generic/tclClock.c (FormatClock): Convert the format string to utf-8
- before calling TclpStrftime, so that non-ASCII characters don't get
- mangled when the result string is being converted back.
- * tests/clock.test: Added a test for that.
-
-2002-07-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/Makefile.in (ro-test,ddd,GDB,DDD): Created new targets to
- allow running the test suite with a read-only current directory,
- running under ddd instead of gdb, and factored out some executable
- names for broken sites (like mine) where gdb and ddd are installed
- with non-standard names...
-
- * tests/httpold.test: Altered test names to httpold-* to avoid clashes
- with http.test, and stopped tests from failing when the current
- directory is not writable...
-
- * tests/event.test: Stop these tests from failing when the
- * tests/ioUtil.test: current directory is not writable...
- * tests/regexp.test:
- * tests/regexpComp.test:
- * tests/source.test:
- * tests/unixFile.test:
- * tests/unixNotfy.test:
-
- * tests/unixFCmd.test: Trying to make these test-files not
- * tests/macFCmd.test: bomb out with an error when the
- * tests/http.test: current directory is not writable...
- * tests/fileName.test:
- * tests/env.test:
-
-2002-07-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.4b1 TAGGED FOR RELEASE ***
-
-2002-07-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdMZ.test (cmdMZ-1.4):
- * tests/cmdAH.test: More fixing of writable-current-dir assumption.
- [Bug 575824]
-
-2002-07-04 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/basic.test: Same issue as below; fixed [Bug 575817]
-
-2002-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/socket.test:
- * tests/winPipe.test:
- * tests/pid.test: Fixed [Bug 575848]. See below for a description the
- general problem.
-
- * All the bugs below are instances of the same problem: The testsuite
- assumes [pwd] = [temporaryDirectory] and writable.
-
- * tests/iogt.test: Fixed [Bug 575860].
- * tests/io.test: Fixed [Bug 575862].
- * tests/exec.test:
- * tests/ioCmd.test: Fixed [Bug 575836].
-
-2002-07-03 Don Porter <dgp@users.sourceforge.net>
-
- * tests/pkg1/direct1.tcl: removed
- * tests/pkg1/pkgIndex.tcl: removed
- * tests/pkgMkIndex.test: Imported auxilliary files from tests/pkg1
- into the test file pkgMkIndex.test itself. Formatting fixes.
-
- * unix/Makefile.in: removed tests/pkg/* from `make dist`
-
- * tests/pkg/circ1.tcl: removed
- * tests/pkg/circ2.tcl: removed
- * tests/pkg/circ3.tcl: removed
- * tests/pkg/global.tcl: removed
- * tests/pkg/import.tcl: removed
- * tests/pkg/pkg1.tcl: removed
- * tests/pkg/pkg2_a.tcl: removed
- * tests/pkg/pkg2_b.tcl: removed
- * tests/pkg/pkg3.tcl: removed
- * tests/pkg/pkg4.tcl: removed
- * tests/pkg/pkg5.tcl: removed
- * tests/pkg/pkga.tcl: removed
- * tests/pkg/samename.tcl: removed
- * tests/pkg/simple.tcl: removed
- * tests/pkg/spacename.tcl: removed
- * tests/pkg/std.tcl: removed
- * tests/pkgMkIndex.test: Fixed [Bug 575857] where this test file
- expected to be able to write to [file join [testsDirectory] pkg]. Part
- of the fix was to import several auxilliary files into the test file
- itself.
-
- * tests/main.test: Cheap fix for [Bugs 575851, 575858]. Avoid
- * tests/tcltest.test: non-writable . by [cd [temporaryDirectory]].
-
- * library/auto.tcl: Fix [tcl_findLibrary] to be sure it sets $varName
- only if a successful library script is found. [Bug 577033]
-
-2002-07-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileCatchCmd): return
- TCL_OUT_LINE_COMPILE instead of TCL_ERROR: let the failure happen at
- runtime so that it can be caught [Bug 577015].
-
-2002-07-02 Joe English <jenglish@users.sourceforge.net>
-
- * doc/tcltest.n: Markup fixes, spellcheck.
-
-2002-07-02 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: more refinements of the documentation.
-
- * library/tcltest/tcltest.tcl: Added trace to be sure the stdio
- constraint is updated whenever the [interpreter] changes.
-
- * doc/tcltest.n: Reverted [makeFile] and [viewFile] to
- * library/tcltest/tcltest.tcl: their former behavior, and documented
- * tests/cmdAH.test: it. Corrected misspelling of hook
- * tests/event.test: procedure. Restored tests.
- * tests/http.test:
- * tests/io.test:
-
- * library/tcltest/tcltest.tcl: Simplified logic of [GetMatchingFiles]
- and [GetMatchingDirectories], removing special case processing.
-
- * doc/tcltest.n: More documentation updates. Reference sections are
- complete. Only examples need adding.
-
-2002-07-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fCmd.test:
- * generic/tclCmdAH.c: clearer error msgs for 'file link', as per the
- man page.
-
-2002-07-01 Joe English <jenglish@users.sourceforge.net>
-
- * doc/Access.3:
- * doc/AddErrInfo.3:
- * doc/Alloc.3:
- * doc/Backslash.3:
- * doc/CrtChannel.3:
- * doc/CrtSlave.3:
- * doc/Encoding.3:
- * doc/Eval.3:
- * doc/FileSystem.3:
- * doc/Notifier.3:
- * doc/OpenFileChnl.3:
- * doc/ParseCmd.3:
- * doc/RegExp.3:
- * doc/Tcl_Main.3:
- * doc/Thread.3:
- * doc/TraceCmd.3:
- * doc/Utf.3:
- * doc/WrongNumArgs.3:
- * doc/binary.n:
- * doc/clock.n:
- * doc/expr.n:
- * doc/fconfigure.n:
- * doc/glob.n:
- * doc/http.n:
- * doc/interp.n:
- * doc/lsearch.n:
- * doc/lset.n:
- * doc/msgcat.n:
- * doc/packagens.n:
- * doc/pkgMkIndex.n:
- * doc/registry.n:
- * doc/resource.n:
- * doc/safe.n:
- * doc/scan.n:
- * doc/tclvars.n: Spell-check, fixed typos (Updates from Larry Virden).
-
-2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Made Solaris use gcc for linking
- when building with gcc to resolve problems with undefined symbols
- being present when tcl library used with non-gcc linker at later
- stage. Symbols were compiler-generated, so it is the compiler's
- business to define them. [Bug 541181]
-
-2002-07-01 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: more work in progress updating tcltest docs.
-
- * library/tcltest/tcltest.tcl: Change [configure -match] to stop
- treating an empty list as a list of the single pattern "*". Changed
- the default value to [list *] so default operation remains the same.
-
- * tests/pkg/samename.tcl: restored. needed by pkgMkIndex.test.
-
- * library/tcltest/tcltest.tcl: restored writability testing of
- -tmpdir, augmented by a special exception for the deafault value.
-
-2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/concat.n: Documented the *real* behaviour of [concat]!
-
-2002-06-30 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: more work in progress updating tcltest docs.
-
- * tests/README: Updated the instructions on running and
- * tests/cmdMZ.test: adding to the test suite. Also updated
- * tests/encoding.test: several tests, mostly to correctly create
- * tests/fCmd.test: and destroy any temporary files in the
- * tests/info.test: [temporaryDirectory] of tcltest.
- * tests/interp.test:
-
- * library/tcltest/tcltest.tcl: Stopped checking for writability of
- -tmpdir value because no default directory can be guaranteed to be
- writable.
-
- * tests/autoMkindex.tcl: removed.
- * tests/pkg/samename.tcl: removed.
- * tests/pkg/magicchar.tcl: removed.
- * tests/pkg/magicchar2.tcl: removed.
- * tests/autoMkindex.test: Updated auto_mkIndex tests to use [makeFile]
- and [removeFile] so tests are done in [temporaryDirecotry] where write
- access is guaranteed.
-
- * library/tcltest/tcltest.tcl: Fixed [makeFile] and [viewFile] to
- * tests/cmdAH.test: accurately reflect a file's contents.
- * tests/event.test: Updated tests that depended on buggy
- * tests/http.test: behavior. Also added warning messages
- * tests/io.test: to "-debug 1" operations to debug test
- * tests/iogt.test: calls to (make|remove)(File|Directory)
-
- * unix/mkLinks: `make mklinks` on 6-27 commits.
-
-2002-06-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.h: modified the macro TclEmitPush to not call its
- first argument repeatedly or pass it to other macros, [Bug 575194]
- reported by Peter Spjuth.
-
-2002-06-28 Don Porter <dgp@users.sourceforge.net>
-
- * docs/tcltest.n: Doc revisions in progress.
- * library/tcltest/tcltest.tcl: Corrected -testdir default value. Was
- not reliable, and disagreed with docs! Thanks to Hemang Lavana. [Bug
- 575150]
-
-2002-06-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tclUnixThrd.c: Renamed the Tcl_Platform* #defines to TclOS*
- * unix/tclUnixPipe.c: because they are only used internally. Also
- * unix/tclUnixFile.c: stopped double-#def of TclOSlstat [Bug 566099,
- * unix/tclUnixFCmd.c: post-rename]
- * unix/tclUnixChan.c:
- * unix/tclUnixPort.h:
-
- * doc/string.n: Improved documentation for [string last] along lines
- described in [Bug 574799] so it indicates that the supplied index
- marks the end of the search space.
-
-2002-06-27 Don Porter <dgp@users.sourceforge.net>
-
- * doc/dde.n: Work in progress updating the documentation
- * doc/http.n: of the packages that come bundled with
- * doc/msgcat.n: the Tcl source distribution, notably tcltest.
- * doc/registry.n:
- * doc/tcltest.n:
-
- * library/tcltest/tcltest.tcl: Made sure that the TCLTEST_OPTIONS
- environment variablle configures tcltest at package load time.
-
-2002-06-26 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fileSystem.test:
- * generic/tclIOUtil.c: fix to handling of empty paths "" which are not
- claimed by any filesystem [Bug 573758]. Ensure good error messages
- are given in all cases.
- * tests/cmdAH.test:
- * unix/tclUnixFCmd.c: fix to bug reported as part of [Patch 566669].
- Thanks to Taguchi, Takeshi for the report.
-
-2002-06-26 Reinhard Max <max@suse.de>
-
- * unix/tclUnixTime.c: Make [clock format] respect locale settings.
- * tests/clock.test: [Bug 565880]. ***POTENTIAL INCOMPATIBILITY***
-
-2002-06-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/CrtInterp.3:
- * doc/StringObj.3: clarifications by Don Porter, [Bug 493995] and [Bug
- 500930].
-
-2002-06-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected suppression of -verbose skip
- * tests/tcltest.test: and start by [test -output]. Also
- corrected test suite errors exposed by corrected code. [Bug 564656]
-
-2002-06-25 Reinhard Max <max@suse.de>
-
- * unix/tcl.m4: New macro SC_CONFIG_MANPAGES.
- * unix/configure.in: Added support for symlinks and compression when
- * unix/Makefile.in: installing the manpages. [Patch 518052]
- * unix/mkLinks.tcl: Default is still hardlinks and no compression.
-
- * unix/mkLinks: generated
- * unix/configure:
-
- * unix/README: Added documentation for the new features.
-
- * unix/tcl.m4 (SC_PATH_TCLCONFIG): Replaced ${exec_prefix}/lib by
- ${libdir}.
-
-2002-06-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclUtil.c (TclGetIntForIndex): Fix of critical [Bug 533364]
- generated when the index is bad and the result is a shared object. The
- T_ASTO(T_GOR, ...) idiom likely exists elsewhere though. Also removed
- some cruft that just complicated things to no advantage.
- (SetEndOffsetFromAny): Same fix, though this wasn't on the path
- excited by the bug.
-
-2002-06-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Implementation of TIP 101. Adds abd
- * tests/parseOld.test: exports a [configure] command from
- * tests/tcltest.test: tcltest.
-
-2002-06-22 Don Porter <dgp@users.sourceforge.net>
-
- * changes: updated changes file for 8.4b1 release.
-
- * library/tcltest/tcltest.tcl: Corrections to tcltest and the Tcl
- * tests/basic.test: test suite so that a test with options
- * tests/cmdInfo.test: -constraints knownBug
- * tests/compile.test: -limitConstraints 1 only tests the
- * tests/encoding.test: knownBug tests. Mostly involves
- * tests/env.test: replacing direct access to the
- * tests/event.test: testConstraints array with calls to
- * tests/exec.test: the testConstraint command (which
- * tests/execute.test: requires tcltest version 2)
- * tests/fCmd.test:
- * tests/format.test:
- * tests/http.test:
- * tests/httpold.test:
- * tests/ioUtil.test:
- * tests/link.test:
- * tests/load.test:
- * tests/namespace.test:
- * tests/pkgMkIndex.test:
- * tests/reg.test:
- * tests/result.test:
- * tests/scan.test:
- * tests/stack.test:
-
-2002-06-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tools/tcl.wse.in (Disk Label), unix/tcl.spec (version):
- * win/README.binary, README, win/configure.in, unix/configure.in:
- * generic/tcl.h (TCL_RELEASE_*, TCL_PATCH_LEVEL): Bump to beta1.
-
-2002-06-21 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclCompExpr.c:
- * generic/tclParseExpr.c: LogSyntaxError() should reset the
- interpreter result [Bug 550142 "Tcl_ExprObj -> abort"]
-
-2002-06-21 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Updated all package install directories
- * win/Makefile.in: to match current Major.minor versions
- * win/makefile.bc: of the packages. Added tcltest package
- * win/makefile.vc: to installation on Windows.
-
- * library/init.tcl: Corrected comments and namespace style issues.
- Thanks to Bruce Stephens. [Bug 572025]
-
-2002-06-21 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/cmdAH.test: Added TIP#99 implementation of 'file
- * tests/fCmd.test: link'. Supports creation of symbolic and
- * tests/fileName.test: hard links in the native filesystems and
- * tests/fileSystem.test: in vfs's, when the individual filesystem
- * generic/tclTest.c: supports the concept.
- * generic/tclCmdAH.c:
- * generic/tclIOUtil.c:
- * generic/tcl.h:
- * generic/tcl.decls:
- * doc/FileSystem.3:
- * doc/file.n:
- * mac/tclMacFile.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: Also enhanced speed of 'file normalize' on
- Windows.
-
-2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (TclEvalObjvInternal): fix for [Bug 571385] in
- the implementation of TIP#62 (command tracing). Vince Darley, Hemang
- Lavana & Don Porter: thanks.
-
-2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclCompEvalObj): clarified and simplified the
- logic for compilation/recompilation.
-
-2002-06-19 Joe English <jenglish@users.sourceforge.net>
-
- * doc/file.n: Fixed indentation. No substantive changes.
-
-2002-06-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): get the resultPtr again as
- the Tcl_ObjSetVar2 may cause the result to change. [Patch 558324]
- (watson)
-
-2002-06-19 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TEBC): removing unused "for(;;)" loop;
- improved comments; re-indentation.
-
-2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TEBC):
- - elimination of duplicated code in the non-immediate INST_INCR
- instructions.
- - elimination of 103 (!) TclDecrRefCount macros. The different
- instructions now jump back to a common "DecrRefCount zone" at the
- top of the loop. The macro "ADJUST_PC" was replaced by two macros
- "NEXT_INST_F" and "NEXT_INST_V" that take three params
- (pcAdjustment, # of stack objects to discard, resultObjPtr handling
- flag). The only instructions that retain a TclDecrRefCount are
- INST_POP (for speed), the common code for the non-immediate
- INST_INCR, INST_FOREACH_STEP and the two INST_LSET.
-
- The object size of tclExecute.o was reduced by approx 20% since the
- start of the consolidation drive, while making room for some peep-hole
- optimisation at runtime.
-
-2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TEBC, INST_DONE): small bug in the panic code
- for tcl-stack corruption.
-
-2002-06-17 David Gravereaux <davygrvy@pobox.com>
-
- Trims to support the removal of RESOURCE_INCLUDED from rc scripts from
- [FRQ 565088].
-
- * generic/tcl.h: moved the #ifndef RC_INVOKED start block up in the
- file. rc scripts don't need to know thread mutexes.
-
- * win/tcl.rc:
- * win/tclsh.rc: removed the #define RESOURCE_INCLUDED to let the
- built-in -DRC_INVOKED to the work.
-
-2002-06-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/CrtTrace.3: Added TIP#62 implementation of command
- * doc/trace.n: execution tracing [FRQ 462580] (lavana).
- * generic/tcl.h: This includes enter/leave tracing as well
- * generic/tclBasic.c: as inter-procedure stepping.
- * generic/tclCmdMZ.c:
- * generic/tclCompile.c:
- * generic/tclExecute.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclVar.c:
- * tests/trace.test:
-
-2002-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinPipe.c (BuildCommandLine): Fixed [Bug 554068] ([exec] on
- windows did not treat { in filenames well.). Bug reported by Vince
- Darley <vincentdarley@users.sourceforge.net>, patch provided by Vince
- too.
-
-2002-06-17 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tcl.h: #ifdef logic for K&R C backwards compatibility
- changed to assume modern C by default. See [FRQ 565088] for full
- details.
-
-2002-06-17 Don Porter <dgp@users.sourceforge.net>
-
- * doc/msgcat.n: Corrected en_UK references to en_GB. UK is not a
- country designation recognized in ISO 3166.
-
- * library/msgcat/msgcat.tcl: More Windows Registry locale codes from
- Bruno Haible.
-
- * doc/msgcat.n:
- * library/msgcat/msgcat.tcl:
- * library/msgcat/pkgIndex.tcl:
- * tests/msgcat.test: Revised locale initialization to interpret
- environment variable locale values according to XPG4, and to recognize
- the LC_ALL and LC_MESSAGES values over that of LANG. Also added many
- Windows Registry locale values to those recognized by msgcat. Revised
- tests and docs. Bumped to version 1.3. Thanks to Bruno Haible for the
- report and assistance crafting the solution. [Bug 525522, 525525]
-
-2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.c (TclCompileTokens): a better algorithm for the
- previous bug fix.
-
-2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompile.c (TclCompileTokens):
- * tests/compile.test: [Bug 569438] in the processing of dollar
- variables; report by Georgios Petasis.
-
-2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: bug in the consolidation of the INCR_..._STK
- instructions; the bug could not be exercised as the (faulty)
- instruction INST_INCR_ARRAY_STK was never compiled-in (related to [Bug
- 569438]).
-
-2002-06-14 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole
- optimisation of variables (INST_STORE, INST_INCR) and commands
- (INST_INVOKE); faster check for the existence of a catch.
- (TclExecuteByteCode): runtime peep-hole optimisation of comparisons.
- (TclExecuteByteCode): runtime peep-hole optimisation of INST_FOREACH -
- relies on peculiarities of the code produced by the bytecode compiler.
-
-2002-06-14 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc: The test for compiler optimizations was in error.
- Thanks goes to Roy Terry <royterry@earthlink.net> for his assistance
- with this.
-
-2002-06-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/trace.n, tests/trace.test:
- * generic/tclCmdMZ.c (Tcl_TraceObjCmd,TclTraceCommandObjCmd)
- (TclTraceVariableObjCmd): Changed references to "trace list" to
- "trace info" as mandated by TIP#102.
-
-2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): consolidated code for the
- conditional branch instructions.
-
-2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): fixed the previous patch;
- wouldn't compile with TCL_COMPILE_DEBUG set.
-
-2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): consolidated the handling
- of exception returns to INST_INVOKE and INST_EVAL, as well as most of
- the code for INST_CONTINUE and INST_BREAK, in the new jump target
- "processExceptionReturn".
-
-2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): consolidated variable
- handling opcodes, replaced redundant code with some 'goto'. All
- store/append/lappend opcodes on the same data type now share the main
- code; same with incr opcodes.
- * generic/tclVar.c: added the bit TCL_TRACE_READS to the possible
- flags to Tcl_SetVar2Ex - it causes read traces to be fired prior to
- setting the variable. This is used in the core for [lappend].
-
- ***NOTE*** the usage of TCL_TRACE_READS in Tcl_(Obj)?GetVar.* is not
- documented; there, it causes the call to create the variable if it
- does not exist. The new usage in Tcl_(Obj)?SetVar.* remains
- undocumented too ...
-
-2002-06-13 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fCmd.test:
- * tests/winFile.test:
- * tests/fileSystem.test:
- * generic/tclTest.c:
- * generic/tclCmdAH.c:
- * generic/tclIOUtil.c:
- * doc/FileSystem.3:
- * mac/tclMacFile.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: fixed up further so both compiles and actually
- works with VC++ 5 or 6.
- * win/tclWinInt.h:
- * win/tclWin32Dll.c: cleaned up code and vfs tests and added tests for
- the internal changes of 2002-06-12, to see whether WinTcl on NTFS can
- coexist peacefully with links in the filesystem. Added new test
- command 'testfilelink' to enable the newer code to be tested.
- * tests/fCmd.test: (made certain tests of 'testfilelink' not run on
- unix).
-
-2002-06-12 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tclBasic.c (Tcl_DeleteTrace): fixed [Bug 568123] (thanks to Hemang
- Lavana)
-
-2002-06-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFile.c: corrected the symbolic link handling code to allow
- it to compile. Added real definition of REPARSE_DATA_BUFFER (found in
- winnt.h). Most of the added definitions appear to have correct,
- cross-Win-version equivalents in winnt.h and should be removed, but
- just making things "work" for now.
-
-2002-06-12 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c:
- * generic/tcl.decls:
- * generic/tclDecls.h: made code for Tcl_FSNewNativePath agree with man
- pages.
-
- * doc/FileSystem.3: clarified the circumstances under which certain
- functions are called in the presence of symlinks.
-
- * win/tclWinFile.c:
- * win/tclWinPort.h:
- * win/tclWinInt.h:
- * win/tclWinFCmd.c: Fix for Windows to allow 'file lstat', 'file
- type', 'glob -type l', 'file copy', 'file delete', 'file normalize',
- and all VFS code to work correctly in the presence of symlinks
- (previously Tcl's behaviour was not very well defined). This also
- fixes possible serious problems in all versions of WinTcl where 'file
- delete' on a NTFS symlink could delete the original, not the symlink.
- Note: symlinks cannot yet be created in pure Tcl.
-
-2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c:
- * generic/tclCompCmds.c:
- * generic/tclInt.h: reverted the new compilation functions; replaced
- by a more general approach described below.
-
- * generic/tclCompCmds.c:
- * generic/tclCompile.c: made *all* compiled variable access attempts
- create an indexed variable - even get or incr without previous set.
- This allows indexed access to local variables that are created and set
- at runtime, for example by [global], [upvar], [variable], [regexp],
- [regsub].
-
-2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/global.n:
- * doc/info.n:
- * test/info.test:
- * generic/tclCmdIL.c: fix for [Bug 567386], [info locals] was
- reporting some linked variables.
-
- * generic/tclBasic.c:
- * generic/tclCompCmds.c:
- * generic/tclInt.h: added compile functions for [global], [variable]
- and [upvar]. They just declare the new local variables, the commands
- themselves are not compiled-in. This gives a notably faster read
- access to these linked variables.
-
-2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: optimised algorithm for exception range
- lookup; part of [Patch 453709].
-
-2002-06-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * unix/tclUnixFCmd.c: fixed [Bug 566669]
- * generic/tclIOUtil.c: improved and sped up handling of native paths
- (duplication and conversion to normalized paths), particularly on
- Windows.
- * modified part of above commit, due to problems on Linux. Will
- re-examine bug report and evaluate more closely.
-
-2002-06-07 Don Porter <dgp@users.sourceforge.net>
-
- * tests/tcltest.test: More corrections to test suite so that tests of
- failing [test]s don't show up themselves as failing tests.
-
-2002-06-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c: Tidied up headers in relation to float.h to
- cut the cruft and ensure DBL_MAX is defined since doubles seem to be
- the same size everywhere; if the assumption isn't true, the variant
- platforms had better have run configure...
-
- * unix/tclUnixPort.h (EOVERFLOW): Added code to define it if it
- wasn't previously defined. Also some other general tidying and adding
- of comments. [Bugs 563122, 564595]
- * compat/tclErrno.h: Added definition for EOVERFLOW copied from
- Solaris headers; I've been unable to find any uses of EFTYPE, which
- was the error code previously occupying the slot, in Tcl, or any
- definition of it in the Solaris headers.
-
-2002-06-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/dltest/Makefile.in: Remove hard coded CFLAGS=-g and add
- CFLAGS_DEBUG, CFLAGS_OPTIMIZE, and CFLAGS_DEFAULT varaibles. [Bug
- 565488]
-
-2002-06-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/tcltest.test: Corrections to test suite so that tests of
- failing [test]s don't show up themselves as failing tests.
-
- * tests/io.test: Fixed up namespace variable resolution issues
- revealed by running test suite with "-singleproc 1".
-
- * doc/tcltest.n:
- * library/tcltest/tcltest.tcl:
- * tests/tcltest.test: Several updates to tcltest.
- 1) changed to lazy initialization of test constraints
- 2) deprecated [initConstraintsHook]
- 3) repaired badly broken [limitConstraints].
- 4) deprecated [threadReap] and [mainThread]
- [Patch 512214, Bug 558742, Bug 461000, Bug 534903]
-
-2002-06-06 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime): added
- mutex wrapped calls to readdir, localtime & gmtime in case their
- thread-safe *_r counterparts are not available.
- * unix/tcl.m4: added configure check for readdir_r
- * unix/tcl.m4 (Darwin): set TCL_DEFAULT_ENCODING to utf-8 on MacOSX
- (where Posix file apis expect utf-8, not iso8859-1).
- * unix/configure: regen
- * unix/Makefile.in: set DYLD_LIBRARY_PATH in parallel to
- LD_LIBRARY_PATH for MacOSX dynamic linker.
- * generic/tclEnv.c (TclSetEnv): fix env var setting on MacOSX (adapted
- from [Patch 524352] by jkbonfield).
-
-2002-06-05 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Tcl_Main.3: Documented $tcl_rcFileName and added more
- clarifications about the intended use of Tcl_Main(). [Bug 505651]
-
-2002-06-05 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclFileName.c (TclGlob): mac specific fix to recent changes
- in 'glob -tails' handling.
- * mac/tclMacPort.h:
- * mac/tclMacChan.c: fixed TIP#91 bustage.
- * mac/tclMacResource.c (Tcl_MacConvertTextResource): added utf
- conversion of text resource contents.
- * tests/macFCmd.test (macFCmd-1.2): allow CWIE creator.
-
-2002-06-04 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl:
- * tests/init.test:
- * tests/tcltest.test: Added more TIP 85 tests from Arjen Markus.
- Converted tcltest.test to use a private namespace. Fixed bugs in
- [tcltest::Eval] revealed by calling [tcltest::test] from a non-global
- namespace, and namespace errors in init.test.
-
-2002-06-04 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update msys+mingw URL.
-
-2002-06-03 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n:
- * library/tcltest/tcltest.tcl:
- * library/tcltest/pkgIndex.tcl:
- * tests/tcltest.test: Implementation of TIP 85. Allows tcltest users
- to add new legal values of the -match option to [test], associating
- each with a Tcl command that does the matching of expected results
- with actual results of tests. Thanks to Arjen Markus. => tcltest 2.1
- [Patch 521362]
-
-2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/namespace.n: added description of [namepace forget] behaviour
- for unqualified patterns. [Bug 559268]
-
-2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: reverting an accidental modification in the
- last commit.
-
-2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/Tcl.n: clarify the empty variable name issue ([Bug 549285]
- reported by Tom Krehbiel, patch by Don Porter).
-
-2002-05-31 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl: Fixed leak of slave interp in [pkg_mkIndex].
- Thanks to Helmut for report. [Bug 550534]
-
- * tests/io.test:
- * tests/main.test: Use the "stdio" constraint to control whether an
- [open "|[interpreter]"] is attempted.
-
- * generic/tclExecute.c (TclMathInProgress,TclExecuteByteCode
- (ExprCallMathFunc):
- * generic/tclInt.h (TclMathInProgress):
- * unix/Makefile.in (tclMtherr.*):
- * unix/configure.in (NEED_MATHERR):
- * unix/tclAppInit.c (matherr):
- * unix/tclMtherr.c (removed file):
- * win/tclWinMtherr.c (_matherr): Removed internal routine
- TclMathInProgress and Unix implementation of matherr(). These are now
- obsolete, dealing with very old versions of the C math library.
- Windows version is retained in case Borland compilers require it, but
- it is inactive. Thanks to Joe English. [Bug 474335, Patch 555635]
-
- * unix/configure: regen
-
-2002-05-30 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h: removed exprIsJustVarRef and
- exprIsComparison from the ExprInfo and CompileEnv structs. These
- were set, but not used since dec 1999 [Bug 562383].
-
-2002-05-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c (TclGlob): fix to longstanding 'knownBug' in
- fileName tests 15.2-15.4, and fix to a new Tcl 8.4 bug in certain uses
- of 'glob -tails'.
- * tests/fileName.test: removed 'knownBug' flag from some tests, added
- some new tests for above bugs.
-
-2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure: regen'ed
- * unix/configure.in: replaced bigendian check with autoconf standard
- AC_C_BIG_ENDIAN, which defined WORDS_BIGENDIAN on bigendian systems.
- * generic/tclUtf.c (Tcl_UniCharNcmp):
- * generic/tclInt.h (TclUniCharNcmp): use WORDS_BIGENDIAN instead of
- TCL_OPTIMIZE_UNICODE_COMPARE to enable memcmp alternative.
-
- * generic/tclExecute.c (TclExecuteByteCode INST_STR_CMP):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): changed the case for choosing
- the Tcl_UniCharNcmp compare to when both objs are of StringType, as
- benchmarks show that is the optimal check (both bigendian and
- littleendian systems).
-
-2002-05-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c: Removed "dummy" reference to Tcl_LinkVar. It is
- no longer needed since Tcl_Main() now actually calls Tcl_LinkVar().
- Thanks to Joe English for pointing that out.
-
-2002-05-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Use the macro version.
- * generic/tclInt.h (TclUniCharNcmp): Optimised still further with a
- macro for use in sensitive places like tclExecute.c
-
- * generic/tclUtf.c (Tcl_UniCharNcmp): Use new flag to figure out when
- we can use an optimal comparison scheme, and default to the old scheme
- in other cases which is at least safe.
- * unix/configure.in (TCL_OPTIMIZE_UNICODE_COMPARE): New optional flag
- that indicates when we can use memcmp() to compare Unicode strings
- (i.e. when the high-byte of a Tcl_UniChar precedes the low-byte.)
-
-2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclUtf.c: added TclpUtfNcmp2 private command that
- mirrors Tcl_UtfNcmp, but takes n in bytes, not utf-8 chars. This
- provides a faster alternative for comparing utf strings internally.
- (Tcl_UniCharNcmp, Tcl_UniCharNcasecmp): removed the explicit end of
- string check as it wasn't correct for the function (by doc and logic).
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): reworked the string equal
- comparison code to use TclpUtfNcmp2 as well as short-circuit for
- equal objects or unequal length strings in the equal case.
- Removed the use of goto and streamlined the other parts.
-
- * generic/tclExecute.c (TclExecuteByteCode): added check for object
- equality in the comparison instructions. Added short-circuit for !=
- length strings in INST_EQ, INST_NEQ and INST_STR_CMP. Reworked
- INST_STR_CMP to use TclpUtfNcmp2 where appropriate, and only use
- Tcl_UniCharNcmp when at least one of the objects is a Unicode obj with
- no utf bytes.
-
- * generic/tclCompCmds.c (TclCompileStringCmd): removed error creation
- in code that no longer throws an error.
-
- * tests/string.test:
- * tests/stringComp.test: added more string comparison checks.
-
- * tests/clock.test: better qualified 9.1 constraint check for %s.
-
-2002-05-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclThreadAlloc.c (TclpRealloc, TclpFree): protect
- against the case when NULL is based.
-
- * tests/clock.test: added clock-9.1
- * compat/strftime.c:
- * generic/tclClock.c:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * unix/tclUnixTime.c: fix for Windows msvcrt mem leak caused by using
- an env(TZ) setting trick for in clock format -gmt 1. This also makes
- %s seem to work correctly with -gmt 1 as well as making it a lot
- faster by avoid the env(TZ) hack. TclpStrftime now takes useGMT as an
- arg. [Bug 559376]
-
-2002-05-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fixes to Tcl_FSLoadFile when called on a file
- inside a vfs. This should avoid leaving temporary files sitting
- around on exit. [Bug 545579]
-
-2002-05-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * win/tclWinError.c: Added comment on conversion of
- ERROR_NEGATIVE_SEEK because that is a mapping that really belongs,
- and not a catch-all case.
- * win/tclWinPort.h (EOVERFLOW): Should be either EFBIG or EINVAL
- * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): EOVERFLOW can
- potentially be a synonym for EINVAL.
-
-2002-05-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- === Changes due to TIP#91 ===
-
- * win/tclWinPort.h: Added declaration of EOVERFLOW.
- * doc/CrtChannel.3: Added documentation of wideSeekProc.
- * generic/tclIOGT.c (TransformSeekProc, TransformWideSeekProc):
- Adapted to use the new channel mechanism.
- * unix/tclUnixChan.c (FileSeekProc, FileWideSeekProc): Renamed
- FileSeekProc to FileWideSeekProc and created new FileSeekProc which
- has the old-style interface and which errors out with EOVERFLOW when
- the returned file position can't fit into the return type (int for
- historical reasons).
- * win/tclWinChan.c (FileSeekProc, FileWideSeekProc): Renamed
- FileSeekProc to FileWideSeekProc and created new FileSeekProc which
- has the old-style interface and which errors out with EOVERFLOW when
- the returned file position can't fit into the return type (int for
- historical reasons).
- * mac/tclMacChan.c (FileSeek): Reverted to old interface; Macs lack
- large-file support because I can't see how to add it.
- * generic/tclIO.c (Tcl_Seek, Tcl_Tell): Given these functions
- knowledge of the new arrangement of channel types.
- (Tcl_ChannelVersion): Added recognition of new version code.
- (HaveVersion): New function to do version checking.
- (Tcl_ChannelBlockModeProc, Tcl_ChannelFlushProc)
- (Tcl_ChannelHandlerProc): Made these functions use HaveVersion for
- ease of future maintainability.
- (Tcl_ChannelBlockModeProc): Obvious lookup function.
- * generic/tcl.h (Tcl_ChannelType): New wideSeekProc field, and
- seekProc type restored to old interpretation.
- (TCL_CHANNEL_VERSION_3): New channel version.
-
-2002-05-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/winPipe.test: Applied patch for [Bug 549617]. Patch and bug
- report by Kevin Kenny <kennykb@users.sourceforge.net>.
-
- * win/tclWinSock.c (TcpWatchProc): Fixed [Bug 557878]. We are not
- allowed to mess with the watch mask if the socket is a server socket.
- I believe that the original reporter is George Peter Staplin.
-
-2002-05-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/configure.in: Invoke SC_ENABLE_SHARED before calling
- SC_CONFIG_CFLAGS so that the SHARED_BUILD variable can be checked
- inside SC_CONFIG_CFLAGS.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Pass -non_shared instead of -shared
- to ld when configured with --disable-shared under OSF. [Bug 540390]
-
-2002-05-20 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: added prototype for TclpFilesystemPathType().
- * mac/tclMacChan.c: use MSL provided creator type if available instead
- of the default 'MPW '.
-
-2002-05-16 Joe English <jenglish@users.sf.net>
-
- * doc/CrtObjCmd.3: Added Tcl_GetCommandFromObj, Tcl_GetCommandFullName
- [Bugs 547987, 414921]
-
-2002-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tclUnixChan.c (TtyOutputProc): #if/#endif-ed this function out
- to stop compiler warnings. Also much general tidying of comments in
- this file and removal of whitespace from blank lines.
-
-2002-05-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * unix/tclUnixChan.c (SETBREAK): Solaris thinks ioctl() takes a signed
- second argument, and Linux thinks ioctl() takes an unsigned second
- argument. So need a longer definition of this macro to get neither to
- spew warnings...
-
-2002-05-13 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclEvent.c:
- * generic/tclIOUtil.c:
- * generic/tclInt.h: clean up all memory allocated by the filesystem,
- via introduction of 'TclFinalizeFilesystem'.
- Move TclFinalizeLoad into TclFinalizeFilesystem so we can be sure it
- is called at just the right time.
- Fix bad comment also. [Bug 555078 and 'fs' part of 543549]
- * win/tclWinChan.c: fix comment referring to wrong function.
-
-2002-05-10 Don Porter <dgp@users.sourceforge.net>
-
- * tests/load.test:
- * tests/safe.test:
- * tests/tcltest.test: Corrected some list-quoting issues and other
- matters that cause tests to fail when the patch includes special
- characters. Report from Vince Darley. [Bug 554068]
-
-2002-05-08 David Gravereaux <davygrvy@pobox.com>
-
- * doc/file.n:
- * tools/man2tcl.c:
- * tools/man2help2.tcl: Thanks to Peter Spjuth
- <peter.spjuth@space.se>, again. My prior fix for single-quote macro
- mis-understanding was wrong. Reverted to reimpliment the 'macro2' proc
- which handles single-quote macros and restored file.n text arrangement
- to avoid single-quotes on the first line. Sorry for all the confusion.
-
-2002-05-08 David Gravereaux <davygrvy@pobox.com>
-
- * tools/man2tcl.c:
- * tools/man2help2.tcl: Proper source of macro error misunderstanding
- single-quote as the leading macro command found and repaired.
-
- * doc/file.n: Reverted to prior state before I messed with it.
-
-2002-05-08 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected [uplevel] quoting when
- [source]-ing test script in subdirectories.
- * tests/fileName.test:
- * tests/load.test:
- * tests/main.test:
- * tests/tcltest.test:
- * tests/unixInit.test: Fixes to test suite when there's a space in the
- working path. Thanks to Kevin Kenny.
-
-2002-05-07 David Gravereaux <davygrvy@pobox.com>
-
- -- Changes from Peter Spjuth <peter.spjuth@space.se>
- * tools/man2tcl.c: Increased line buffer size and a bail-out if that
- should ever be over-run.
- * tools/man2help.tcl: Include Courier New font in rtf header.
- * tools/man2help2.tcl: Improved handling of CS/CE fields. Use Courier
- New for code samples and indent better.
-
- * doc/file.n:
- * doc/TraceCmd.3: winhelp conversion tools where understanding
- a ' as the first character on a line to be an unknown macro.
- Not knowing how to repair tools/man2tcl.c, I decided to rearrange
- the text in the docs instead.
-
-2002-05-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: fix to similar segfault when using 'glob
- -types nonsense -dir dirname -join * *'. [Bug 553320]
-
- * doc/FileSystem.3: further documentation on vfs.
- * tests/cmdAH.test:
- * tests/fileSystem.test:
- * tests/pkgMkindex.test: Fix to testsuite bugs when running out of
- directory whose name contains '{' or '['.
-
-2002-05-07 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/basic.test: Fix for [Bug 549607]
- * tests/encoding.test: Fix for [Bug 549610]
- These are testsuite bugs that caused failures when the filename
- contained spaces. Report & fix by Kevin Kenny.
-
-2002-05-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: fix to freeing a bad object (i.e. segfault)
- when using 'glob -types nonsense -dir dirname'.
- * generic/tclWinFile.c: fix to [Bug 551306], also wrapped some long
- lines.
- * tests/fileName.test: added several tests for the above bugs.
- * doc/FileSystem.3: clarified documentation on refCount requirements
- of the object returned by the path type function.
- * generic/tclIOUtil.c:
- * win/tclWinFile.c:
- * unix/tclUnixFile.c:
- * mac/tclMacFile.c: moved TclpFilesystemPathType to the platform-
- specific directories, so we can add missing platform-specific
- implementations. On Windows, 'file system' now returns useful results
- like "native NTFS", "native FAT" for that system. Unix and MacOS still
- only return "native".
- * doc/file.n: clarified documentation.
- * tests/winFile.test: test for 'file system' returning correct values.
- * tests/fileSystem.test: test for 'file system' returning correct
- values. Clean up after failed previous test run.
-
-2002-04-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: change HP-11 SHLIB_LD_LIBS from "" to ${LIBS} so that
- the .sl knows its dependent libs.
-
-2002-04-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/obj.test (obj-11.[56]): Test conversion to boolean more
- thoroughly.
- * generic/tclObj.c (SetBooleanFromAny): Was not calling an integer
- parsing function on native 64-bit platforms! [Bug 548686]
-
-2002-04-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.h: corrected TclRememberJoinableThread decl to use
- VOID instead of void.
- * generic/tclThreadJoin.c: noted that this code isn't needed on Unix.
-
-2002-04-23 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/exec.n:
- * doc/tclvars.n: doc updates [Patch 509426] (gravereaux)
-
-2002-04-24 Daniel Steffen <das@users.sourceforge.net>
-
- * mac/tclMacResource.r: added check of TCLTK_NO_LIBRARY_TEXT_RESOURCES
- #define to allow disabling the inclusion of the tcl library code in
- the resource fork of Tcl executables and shared libraries.
-
-2002-04-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/TraceCmd.3: New file that documents Tcl_CommandTraceInfo,
- Tcl_TraceCommand and Tcl_UntraceCommand [Bug 414927]
-
-2002-04-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclAlloc.c:
- * generic/tclInt.h:
- * generic/tclThreadAlloc.c (new):
- * unix/Makefile.in:
- * unix/tclUnixThrd.c:
- * win/Makefile.in:
- * win/tclWinInt.h:
- * win/tclWinThrd.c: added new threaded allocator contributed by AOL
- that significantly reduces lock contention when multiple threads are
- in use. Only Windows and Unix implementations are ready, and the
- Windows one may need work. It is only used by default on Unix for now,
- and requires that USE_THREAD_ALLOC be defined (--enable-threads on
- Unix will define this).
-
- * generic/tclIOUtil.c (Tcl_FSRegister, Tcl_FSUnregister): corrected
- calling of Tcl_ConditionWait to ensure that there would be a condition
- to wait upon.
-
- * generic/tclCmdAH.c (Tcl_FileObjCmd): added cast in FILE_SIZE.
-
- * win/tclWinFCmd.c (DoDeleteFile): check return of setattr API calls
- in file deletion for correct Win32 API handling.
-
- * win/Makefile.in: correct dependencies for shell, gdb, runtest
- targets.
-
- * doc/clock.n:
- * compat/strftime.c (_fmt): change strftime to correctly handle
- localized %c, %x and %X on Windows. Added some notes about how the
- other values could be further localized.
-
-2002-04-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c (Tcl_Main): Free the memory allocated for the
- startup script path. [Bug 543549]
-
- * library/msgcat/msgcat.tcl: [mcmax] wasn't using the caller's
- namespace when determining the max translated length. Also made
- revisions for better use of namespace variables and more efficient
- [uplevel]s.
-
- * doc/msgcat.n:
- * library/msgcat/msgcat.tcl:
- * library/msgcat/pkgIndex.tcl: Added [mcload] to the export list of
- msgcat; bumped to 1.2.3. [Bug 544727]
-
-2002-04-20 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * mac/tclMacFCmd.c:
- * mac/tclMacFile.c:
- * mac/tclMacUtil.c: Modified TclpObjNormalizePath to be alias file
- aware, and replaced various calls to FSpLocationFrom*Path by calls to
- new alias file aware versions FSpLLocationFrom*Path. The alias file
- aware routines don't resolve the last component of a path if it is an
- alias. This allows [file copy/delete] etc. to act correctly on alias
- files. (c.f. discussion in [Bug 511666])
-
-2002-04-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/lindex.test (lindex-3.7):
- * generic/tclUtil.c (TclGetIntForIndex): Stopped indexes from hitting
- wide ints. [Bug 526717]
-
-2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclNamesp.c:
- * tests/info.test: [Bug 545325] info level didn't report namespace
- eval, bug report by Richard Suchenwirth.
-
-2002-04-18 Don Porter <dgp@users.sourceforge.net>
-
- * doc/subst.n: Clarified documentation on handling unusual return
- codes during substitution, and on variable substitutions implied by
- command substitution, and vice versa. [Bug 536838]
-
-2002-04-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdIL.c (InfoBodyCmd):
- * tests/info.test (info-2.6): Proc bodies without string reps would
- report as empty. [Bug 545644]
-
- * generic/tclCmdMZ.c (Tcl_SubstObj): More clarification for comment on
- behaviour when substitutions are not well-formed, prompted by [Bug
- 536831]; alas, removing the ill-defined behaviour is a lot of work.
-
-2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c:
- * tests/expr-old.test: fix for [Bug 542588] (Phil Ehrens), where "too
- large integers" were reported as "floating-point value" in [expr]
- error messages.
-
-2002-04-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEncoding.c (EscapeFromUtfProc):
- * generic/tclIO.c (WriteChars, Tcl_Close): corrected the handling of
- outputting end escapes for escape-based encodings.
- [Bug 526524] (yamamoto)
-
-2002-04-17 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Removed [saveState] and [restoreState] from tcltest
- 2 documentation, effectively deprecating them. [Bug 495660]
- * library/tcltest/tcltest.tcl: Made separate export for commands kept
- only for tcltest 1 compatibility.
-
- * tests/iogt.test: Revised to run tests in a namespace, rather than
- use the useless and buggy [saveState] and [restoreState] commands of
- tcltest. Updated to use tcltest 2 as well. [Patch 544911]
-
-2002-04-16 Don Porter <dgp@users.sourceforge.net>
-
- * tests/io.test: Revised to run tests in a namespace, rather than use
- the useless and buggy [saveState] and [restoreState] commands of
- tcltest. Updated to use tcltest 2 as well. [Patch 544546]
-
-2002-04-15 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclProc.c:
- * tests/proc-old.test: Improved stack trace for TCL_BREAK and
- TCL_CONTINUE returns from procs. Patch by Don Porter [Bug 536955].
-
- * generic/tclExecute.c:
- * tests/compile.test: made bytecodes check for a catch before
- returning; the compiled [return] is otherwise non-catchable. [Bug
- 542142] reported by Andreas Kupries.
-
-2002-04-15 Don Porter <dgp@users.sourceforge.net>
-
- * tests/socket.test: Increased timeout values so that tests have
- time to successfully complete even on slow/busy machines. [Bug 523470]
-
- * doc/tcltest.n:
- * library/tcltest/tcltest.tcl:
- * tests/tcltest.test: Revised [tcltest::test] to return errors when
- called with invalid syntax and to accept exactly two arguments as
- documented. Improved error messages. [Bug 497446, Patch 513983]
- ***POTENTIAL INCOMPATIBILITY***: Incompatible with previous tcltest
- 2.* releases, found only in alpha releases of Tcl 8.4.
-
-2002-04-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclNotify.c (TclFinalizeNotifier): remove remaining
- unserviced events on finalization.
-
- * win/tcl.m4: Enabled COFF as well as CV style debug info with
- --enable-symbols to allow Dr. Watson users to see function info. More
- info on debugging levels can be obtained at:
- http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp
-
- * tests/ioCmd.test: fixed iocmd-8.15 to have mac and unixPc variants.
-
- * generic/tclParse.c (Tcl_ParseVar): conditionally incr obj refcount
- to prevent possible mem leak.
-
-2002-04-08 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.h: no <sys/types.h> on mac.
- * mac/tclMacFile.c: minor fixes to Vince's changes from 03-24.
- * mac/tclMacOSA.c:
- * mac/tclMacResource.c: added missing Tcl_UtfToExternalDString
- conversions of resource file names.
- * mac/tclMacSock.c (TcpGetOptionProc): fixed bug introduced by Andreas
- on 02-25; changed strcmp's to strncmp's so that option comparison
- behaves like on other platforms.
- * mac/tcltkMacBuildSupport.sea.hqx (CW Pro6 changes): added support to
- allow Tk to hookup C library stderr/stdout to TkConsole.
- * tests/basic.test:
- * tests/cmdAH.test:
- * tests/encoding.test:
- * tests/fileSystem.test:
- * tests/ioCmd.test: fixed tests failing on mac: check for existence of
- [exec], changed some result strings.
-
-2002-04-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFCmd.c (Realpath): added a little extra code to
- initialize a realpath arg when compiling in PURIFY mode in order to
- prevent spurious purify warnings. We should really create our own
- realpath implementation, but this will at least quiet purify for now.
-
-2002-04-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (Tcl_SubstObj):
- * tests/subst.test: Corrected [subst] so that return codes TCL_BREAK
- and TCL_CONTINUE returned by variable substitution have the same
- effect as when those codes are returned by command substitution. [Bug
- 536879]
-
-2002-04-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/tcltest/tcltest.tcl: added getMatchingFiles back (alias to
- GetMatchingFiles), which was a public function in tcltest 1.0.
-
-2002-04-01 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclEnv.c:
- * generic/tclIOUtil.c: invalidate filesystem cache when the user
- changes env(HOME). Fixes [Bug 535621]. Also cleaned up some of the
- documentation.
- * tests/fileSystem.test: added test for bug just fixed.
-
-2002-04-01 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWinTime.c (Tcl_GetTime): made the checks of clock frequency
- more permissive to cope with the fact that Win98SE is observed to
- return 1.19318 in place of 1.193182 for the performance counter
- frequency.
-
-2002-03-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (Tcl_TraceObjCmd, TraceVarProc)
- (TraceCommandProc, TclTraceCommandObjCmd): corrected potential
- double-free of traces on variables by flagging in Trace*Proc that it
- will free the var in case the eval wants to delete the var trace as
- well. [Bug 536937] Also converted Tcl_UntraceVar -> Tcl_UntraceVar2
- and Tcl_Eval to Tcl_EvalEx in Trace*Proc for slight efficiency
- improvement.
-
-2002-03-29 Don Porter <dgp@users.sourceforge.net>
-
- * doc/AllowExc.3:
- * generic/tclBasic.c (Tcl_EvalObjv,Tcl_EvalEx,Tcl_EvalObjEx):
- * generic/tclCompile.h (TclCompEvalObj):
- * generic/tclExecute.c (TclCompEvalObj,TclExecuteByteCode):
- * tests/basic.test: Corrected problems with Tcl_AllowExceptions having
- influence over the wrong scope of Tcl_*Eval* calls. Patch from Miguel
- Sofer. Report from Jean-Claude Wippler. [Bug 219181]
-
-2002-03-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclVar.c: Refactored CallTraces to collect repeated handling
- of its returned value into CallTraces itself.
-
-2002-03-28 David Gravereaux <davygrvy@pobox.com>
-
- * tools/feather.bmp:
- * tools/man2help.tcl:
- * tools/man2help2.tcl:
- * win/makefile.vc: More winhelp target fixups. Added a feather bitmap
- to the non-scrollable area and changed the color to be yellow from a
- plain white. The colors can be whatever we want them to be, but
- thought I would start with something bold. [Bug 527941]
-
- * doc/SetVar.3:
- * doc/TraceVar.3:
- * doc/UpVar.3: .AP macro syntax repair.
-
-2002-03-27 David Gravereaux <davygrvy@pobox.com>
-
- * tools/man2help.tcl:
- * win/makefile.vc: winhelp target now copies all needed files from
- tools/ to a workarea under $(OUT_DIR) and builds it from there. No
- build cruft is left in tools/ anymore. All paths used in man2help.tcl
- are now relative to where the script is. [Bug 527941]
-
-2002-03-27 David Gravereaux <davygrvy@pobox.com>
-
- * win/.cvsignore:
- * win/buildall.vc.bat:
- * win/coffbase.txt:
- * win/makefile.vc:
- * win/nmakehlp.c (new):
- * win/rules.vc: First draft fix for [Bug 527941]. More changes need
- to done to the makehelp target to get to stop leaving build files in
- the tools/ directory. This does not address the syntax errors in the
- man files. Having the contents of tcl.hpj(.in) inside makefile.vc
- allows for version numbers to be replaced with macros.
-
- The new nmakehlp.c is built by rules.vc in preprocessing and removes
- the need to use tricky shell syntax that wasn't compatible on Win9x
- systems. Clean targets made Win9x complient. This is a first draft
- repair for [Bug 533862].
-
-2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalEx): passing the correct commandSize to
- TclEvalObjvInternal. [Bug 219362], fix by David Knoll.
-
-2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalEx):
- * tests/basic.test: avoid exceptional returns at level 0. [Bug 219181]
-
-2002-03-27 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n ([mainThread]):
- * library/tcltest/tcltest.tcl:
- * tests/tcltest.test: Major code cleanup to deal with whitespace,
- coding conventions, and namespace issues, with several minor bugs
- fixed in the process.
-
- * tests/main.test: Added missing [after cancel]s.
-
-2002-03-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/main.test: Removed workarounds for Bug 495977.
-
- * library/tcltest/tcltest.tcl: Keep the value of $::auto_path
- unchanged, so that the tcltest package can test code that depends on
- auto-loading. If a testing application needs $::auto_path pruned, it
- should do that itself. [Bug 495726]
- Improve the processing of the -constraints option to [test] so that
- constraint lists can have arbitrary whitespace, and non-lists don't
- blow things up. [Bug 495977]
- Corrected faulty variable initialization. [Bug 534845]
-
-2002-03-25 Miguel Sofer <msofer@users.sourceforge.net>
-
- * doc/CrtTrace.3: small doc correction
- * generic/tclBasic.c (Tcl_DeleteTrace): Allow NULL callback on trace
- deletions. [Bug 534728] (Hemang Lavana)
-
-2002-03-24 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalObjv): replaced obscure, incorrect code
- as described in [Bug 533907] (Don Porter).
-
-2002-03-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Use [interpreter] to set/query the
- executable currently running the tcltest package. [Bug 454050]
-
- * library/tcltest/tcltest.tcl: Allow non-proc commands to be used as
- the customization hooks. [Bug 495662]
-
-2002-03-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFilename.c:
- * generic/tclFCmd.c:
- * generic/tclTest.c:
- * generic/tcl.h:
- * generic/tclIOUtil.c:
- * win/tclWinFile.c:
- * win/tclWinFCmd.c:
- * win/tclWinPipe.c:
- * unix/tclUnixFile.c:
- * unix/tclUnixFCmd.c:
- * mac/tclMacFile.c:
- * doc/FileSystem.3:
- * doc/file.n:
- * tests/cmdAH.test:
- * tests/fileName.test:
- * tests/fileSystem.test: (new file)
- * tests/winFCmd.test: fix [Bug 511666] and [Bug 511658], and improved
- documentation of some aspects of the filesystem, particularly
- 'Tcl_FSMatchInDirectory' which now might match a single file/directory
- only, and 'file normalize' which wasn't very clear before. Removed
- inconsistency betweens docs and the Tcl_Filesystem structure. Also
- fixed [Bug 523217] and corrected file normalization on Unix so that
- it expands symbolic links. Added some new tests of the filesystem
- code (in the new file 'fileSystem.test'), and some extra tests for
- correct handling of symbolic links. Fix to [Bug 530960] which shows up
- on Win98. Made comparison with ".com" case insensitive in tclWinPipe.c
-
- ***POTENTIAL INCOMPATIBILITY***: But only between alpha releases
- (users of the new Tcl_Filesystem lookup table in Tcl 8.4a4 need to
- handle the new way in which Tcl may call Tcl_FSMatchInDirectory, and
- 'file normalize' on unix now behaves correctly). Only known impact is
- with the 'tclvfs' extension.
-
-2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
-
- * tests/basic.test (basic-46.1): adding test for [Bug 533758], fixed
- earlier today.
-
-2002-03-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinInt.h: moved undef of TCL_STORAGE_CLASS. [Bug 478579]
-
-2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalObjEx):
- * generic/tclExecute.c (TclCompEvalObj): fixed the errorInfo for
- return codes other than (TCL_OK, TCL_ERROR) to runLevel 0.[Bug 533758]
- Removed the static RecordTracebackInfo(), as its functionality is
- easily replicated by Tcl_LogCommandInfo. Bug and redundancy noted by
- Don Porter.
-
-2002-03-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/expr.n: Improved documentation for ceil and floor. [Bug 530535]
-
-2002-03-20 Don Porter <dgp@users.sourceforge.net>
-
- * doc/SetVar.3:
- * doc/TraceVar.3:
- * doc/UpVar.3:
- * generic/tcl.h (Tcl_VarTraceProc):
- * generic/tcl.decls (Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2,
- (Tcl_UnsetVar2, Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2,
- (Tcl_GetVar2Ex, TclSetVar2Ex):
- * generic/tclCmdMZ.c (TraceVarProc):
- * generic/tclEnv.c (EnvTraceProc):
- * generic/tclEvent.c (VwaitVarProc):
- * generic/tclInt.decls (TclLookupVar,TclPrecTraceProc):
- * generic/tclLink.c (LinkTraceProc):
- * generic/tclUtil.c (TclPrecTraceProc):
- * generic/tclVar.c (CallTraces, MakeUpvar, VarErrMsg, TclLookupVar,
- (Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2, Tcl_UnsetVar2,
- (Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2, Tcl_GetVar2Ex,
- (TclSetVar2Ex): Updated interfaces of generic/tclVar.c according to
- TIP 27. In particular, the "part2" arguments were CONSTified. [Patch
- 532642]
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
-2002-03-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/compile.test (compile-12.3): Test to detect bug 530320.
- * generic/tclCompile.c (TclCompileTokens): Fixed buffer overrun
- reported in bug 530320.
-
-2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Add configure time test for SEH support in the
- compiler.
- * win/tclWin32Dll.c (ESP, EBP, TclpCheckStackSpace,
- (_except_checkstackspace_handler):
- * win/tclWinChan.c (ESP, EBP, Tcl_MakeFileChannel,
- (_except_makefilechannel_handler):
- * win/tclWinFCmd.c (ESP, EBP, DoRenameFile, DoCopyFile,
- (_except_dorenamefile_handler, _except_docopyfile_handler):
- Implement SEH support under gcc using inline asm. Tcl and Tk should
- now compile with Mingw 1.1. [Patch 525746]
-
-2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Handle an SEH exception
- with EXCEPTION_EXECUTE_HANDLER instead of restarting the faulting
- instruction with EXCEPTION_CONTINUE_EXECUTION. [Bug 466102] provides
- an example of how restarting could send Tcl into an infinite loop.
- [Patch 525746]
-
-2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinFCmd.c (DoRenameFile, DoCopyFile, DoDeleteFile,
- (DoRemoveJustDirectory): Make sure we don't pass NULL or "" as a path
- name to Win32 API functions since this was crashing under Windows 98.
-
-2002-03-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl:
- * library/tcltest/pkgIndex.tcl: Bumped tcltest package to 2.0.2.
-
-2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl (getMatchingFiles): Pass a proper list
- to foreach to avoid munging a Windows patch like D:\Foo\Bar into
- D:FooBar before the glob.
-
-2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclEncoding.c: Fix typo in comment.
- * generic/tclIO.c (DoReadChars, ReadBytes, ReadChars): Use NULL value
- instead of pointer set to NULL to make things more clear. Reorder
- arguments so that they match the function signatures. Cleanup little
- typos and add more descriptive comment.
-
-2002-03-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update to indicate that Mingw 1.1 is required to build
- Tcl. Add section describing new msys based build process. Update
- Cygwin build instructions so users know where to find Mingw 1.1.
-
-2002-03-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFCmd.c (DoCopyFile): correctly set retval to TCL_OK.
-
-2002-03-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWin32Dll.c (TclpCheckStackSpace):
- * win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Replace hard coded
- constants with Win32 symbolic names. Move control flow statements out
- of __try blocks since the documentation indicates it is frowned upon.
-
-2002-03-07 Don Porter <dgp@users.sourceforge.net>
-
- * doc/interp.n:
- * generic/tclInterp.c (Tcl_InterpObjCmd, SlaveObjCmd,
- (SlaveRecursionLimit):
- * generic/tclTest.c:
- * tests/interp.test: Added the [interp recursionlimit] command to
- set/query the recursion limit of an interpreter. Proposal and
- implementation from Stephen Trier. [TIP 87, Patch 522849]
-
-2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.h, tools/tcl.wse.in, unix/configure.in,
- * unix/tcl.spec, win/README.binary, win/configure.in, README:
- Bumped patchlevel; this might need to change in the future, but it
- will help us distinguish between the CVS version and the most recent
- released version.
-
-2002-03-06 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclInt.h: for unshared objects, TclDecrRefCount now frees
- the internal rep before the string rep - just like the non-macro
- Tcl_DecrRefCount/TclFreeObj. [Bug 524802]
-
-2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/lsearch.n: Documentation of new features, plus examples.
- * tests/lsearch.test: Tests of new features.
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): TIP#80 support. See
- http://purl.org/tcl/tip/80 for details.
-
-2002-03-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.4a4 TAGGED FOR RELEASE ***
-
- * unix/tclUnixChan.c: initial remedy for [Bug 525783] flush problem
- introduced by TIP #35. This may not satisfy true serial channels, but
- it restores the correct flushing of std* channels on exit.
-
- * unix/README: added --enable-langinfo doc.
-
- * unix/tcl.spec:
- * tools/tcl.wse.in: fixed URL refs to use www.tcl.tk or SF.
-
-2002-03-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README:
- * mac/README:
- * unix/Makefile.in:
- * unix/README:
- * win/README:
- * win/README.binary: updated to use www.tcl.tk URL.
-
- * unix/Makefile.in: added older ChangeLogs to dist target.
-
- * tests/io.test:
- * tests/encoding.test: corrected iso2022 encoding results.
- added encoding-24.*
- * generic/tclEncoding.c (EscapeFromUtfProc): corrected output of
- escape codes as per RFC 1468. [Patch 474358] (taguchi)
- (TclFinalizeEncodingSubsystem): corrected potential double-free
- when encodings were finalized on exit. [Bugs 219314, 524674]
-
-2002-03-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/encoding/iso2022-jp.enc:
- * library/encoding/iso2022.enc:
- * tools/encoding/iso2022-jp.esc:
- * tools/encoding/iso2022.esc: gave <ESC>$B precedence over <ESC>$@,
- based on comments (point 1) in [Bug 219283] (rfc 1468)
-
- * tests/encoding.test: added encoding-23.* tests
- * generic/tclIO.c (FilterInputBytes): reset the TCL_ENCODING_START
- flags in the ChannelState when using 'gets'. [Bug 523988]
- Also reduced the value of ENCODING_LINESIZE from 30 to 20 as this
- seems to improve the performance of 'gets' according to tclbench.
-
-2002-02-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (TraceCommandProc): ensure that TraceCommandInfo
- structure was also deleted when a command was deleted to prevent a
- mem leak.
-
- * generic/tclBasic.c (Tcl_CreateObjTrace): set tracePtr->flags
- correctly.
-
- * generic/tclTimer.c (TimerExitProc): remove remaining events in
- tls on thread exit.
-
-2002-02-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclNamesp.c: allow cached fully-qualified namespace names to
- be usable from different namespaces within the same interpreter
- without forcing a new lookup [Patch 458872].
-
-2002-02-28 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclExecute.c: Replaced a few direct stack accesses with the
- POP_OBJECT() macro [Bug 507181] (Don Porter).
-
-2002-02-27 Don Porter <dgp@users.sourceforge.net>
-
- * doc/GetIndex.3:
- * generic/tcl.decls (Tcl_GetIndexFromObjStruct):
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Revised the
- prototype of the Tcl_GetIndexFromObjStruct to take its struct table as
- a (CONST VOID *) argument, better describing what it is, maintaining
- source compatibility, and adding CONST correctness according to TIP
- 27. Thanks to Joe English for an elegant solution. [Bug 520304]
-
- * generic/tclDecls.h: make genstubs
-
- * generic/tclMain.c (Tcl_Main,StdinProc): Corrected some reference
- count management errors on the interactive command Tcl_Obj found by
- Purify. Thanks to Jeff Hobbs for the report and assistance.
-
-2002-02-27 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclBasic.c (Tcl_EvalTokensStandard): corrected mem leak in
- error case.
-
- * generic/tclTest.c (TestStatProc[123]): correct harmless UMRs.
-
- * generic/tclLink.c (Tcl_LinkVar): correct mem leak in error case.
-
-2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/socket.test (2.7): Accepted and applied patch for [Bug 523470]
- provided by Don Porter <dgp@users.sourceforge.net> to avoid timing
- problems in that test.
-
- * unix/tclUnixChan.c (TclpOpenFileChannel): Added code to regonize
- "/dev/tty" (by name) and to not handle it as tty / serial line. This
- is the controlling terminal and is special. Setting it into raw mode
- as is done for other tty's is a bad idea. This is a hackish fix for
- expect [Bug 520624]. The fix has limitation: Tcl_MakeFileChannel
- handles tty's specially too, but is unable to recognize /dev/tty as it
- only gets a file descriptor, and no name for it.
-
-2002-02-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdAH.c (StoreStatData): corrected mem leak.
-
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): prevent obj leak in
- remedial regsub case.
-
- * generic/tclFileName.c (Tcl_TranslateFileName): decr refcount for
- error case to prevent mem leak.
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): removed extra obj allocation.
-
- * unix/tclUnixSock.c (Tcl_GetHostName): added an extra
- gethostbyname check to guard against failure with truncated
- names returned by uname.
-
- * unix/configure:
- * unix/tcl.m4 (SC_SERIAL_PORT): added sys/modem.h check and defined
- _XOPEN_SOURCE_EXTENDED for HP-11 to get updated header decls.
-
- * unix/tclUnixChan.c: added Unix implementation of TIP #35, serial
- port support. [Patch 438509] (schroedter)
-
-2002-02-26 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCmpCmds.c: (bugfix to the bugfix, hopefully the last)
- Bugfix to the new [for] compiling code: was setting a exceptArray
- parameter using another param which wasn't yet initialised, thus
- filling it with noise.
-
-2002-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * mac/tclMacSock.c (TcpGetOptionProc): Changed to recognize the option
- "-error". Essentially ignores the option, always returning an empty
- string.
-
-2002-02-25 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/Alloc.3:
- * doc/LinkVar.3:
- * doc/ObjectType.3:
- * doc/PkgRequire.3:
- * doc/Preserve.3:
- * doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc,
- ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and
- to accurately describe when and how they are used. [Bug 497459] (dgp)
-
- * generic/tclHash.c (AllocArrayEntry, AllocStringEntry):
- Before invoking ckalloc when creating a Tcl_HashEntry,
- check that the amount of memory being allocated is
- at least as large as sizeof(Tcl_HashEntry). The previous
- code was allocating memory regions that were one
- or two bytes short. [Bug 521950] (dejong)
-
-2002-02-25 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalEx): avoiding a buffer overrun
- reported by Joe English, and restoring tcl7.6 behaviour for
- [subst]: badly terminated nested scripts will raise an error
- and not be evaluated. [Bug 495207]
-
-2002-02-25 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixPort.h: corrected strtoll prototype mismatch on Tru64.
- * compat/strtod.c (strtod): simplified #includes
- * compat/strtol.c (strtol): gather result in a long before returning
- as a long: necessary on platforms where sizeof(int) != sizeof(long).
-
-2002-02-25 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclLoadDyld.c: updated to use Mac OS X 10.1 dyld APIs that
- have more libdl-like semantics. [Bug 514392]
-
-2002-02-25 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds: fixing a bug in patch dated 2002-02-22, in the
- code for [for] and [while]. Under certain conditions, for long bodies,
- the exception range parameters were badly computed. Tests forthcoming:
- I still can't reproduce the conditions in the testsuite (!), although
- the bug (with assorted segfault or panic!) can be triggered from the
- console or with the new parse.bench in tclbench.
-
-2002-02-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * compat/strtoul.c, compat/strtol.c, compat/strtod.c: Added UCHAR,
- CONST and #includes to clean up GCC output.
-
-2002-02-23 Don Porter <dgp@users.sourceforge.net>
-
- * compat/strtoull.c (strtoull):
- * compat/strtoll.c (strtoll):
- * compat/strtoul.c (strtoul): Fixed failure to handle leading
- sign symbols '+' and '-' and '0X' and raise overflow errors.
- [Bug 440916] Also corrects prototype and errno problems.
-
-2002-02-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Link with -n32 instead of -32 when
- building on IRIX64-6.* system. [Bug 521707]
-
-2002-02-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h:
- * generic/tclObj.c: renamed global variable emptyString ->
- tclEmptyString because it is no longer static.
- * generic/tclPkg.c: Fix for panic when library is loaded on a
- platform without backlinking without proper use of stubs. [Bug 476537]
-
-2002-02-22 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/regexpComp.test: updated regexp-11.[1-4] to match changes in
- regexp.test for new regsub syntax
-
- * unix/configure:
- * unix/tcl.m4: added --enable-64bit support for AIX-4 (using -q64
- flag) when using IBM's xlc compiler.
-
- * tests/safe.test: updated safe-8.5 and safe-8.7
- * library/safe.tcl (CheckFileName): removed the limit on
- sourceable file names (was only *.tcl or tclIndex files with no more
- than one dot and 14 chars). There is enough internal protection in a
- safe interpreter already. [Tk Bug 521560]
-
-2002-02-22 Miguel Sofer <msofer@users.sourceforge.net>
-
- * generic/tclCompCmds: [FR 465811]. Optimising [if], [for] and [while]
- for constant conditions; in addition, [for] and [while] are now
- compiled with the "loop rotation" optimisation (thanks to Kevin
- Kenny).
-
-2002-02-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- --- TIP#76 CHANGES ---
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): Final-argument-less
- [regsub] returns the modified string.
- * doc/regsub.n: Updated docs.
- * tests/regexp.test: Updated and added tests.
-
- * compat/strtoll.c (strtoll):
- * compat/strtoull.c (strtoull):
- * unix/tclUnixPort.h:
- * win/tclWinPort.h: Const-ing 64-bit compatibility declarations. Note
- that the return pointer is non-const because it is entirely legal for
- the functions to be called from somewhere that owns the string being
- passed. Fixes problem reported by Larry Virden.
-
-2002-02-21 David Gravereaux <davygrvy@pobox.com>
-
- * win/mkd.bat (removed):
- * win/coffbase.txt (new):
- * win/makefile.bc:
- * win/makefile.vc: Changed the 'setup' target to stop using the
- mkd.bat file and just make the directory right in the rule. Same
- change to makefile.bc. Neither configure.in nor Makefile.in use it.
-
- coffbase.txt will be the master list for our "prefered base addresses"
- set by the linker. This should improve load-time (NT only) by avoiding
- relocations. Submissions to the list by extension authors are
- encouraged.
-
- Added a 'tidy' target to compliment 'clean' and 'hose' to remove just
- the outputs. Also removed the $(winlibs) macro as it wasn't being
- used.
-
- Stuff left to do:
- 1) get the winhelp target to stop building in the tools/ directory.
- 2) stop using rmd.bat
- 3) add more dependacy rules.
-
- * win/tclAppInit.c: Reverted back to -r1.6, as the header file change
- to tclPort.h won't allow for easy embedded support outside of the
- source dist. Thanks to Don Porter for pointing this out to me.
-
-2002-02-21 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc:
- * win/rules.vc: Added a new "loimpact" option that sets the
- -ws:aggressive linker option. Off by default. It's said to keep the
- heap use low at the expense of alloc speed.
-
- * win/tclAppInit.c: Changed #include "tcl.h" to be tclPort.h to remove
- the raw windows.h include. tclPort.h brings in windows.h already and
- lessens the precompiled-header mush and the randomly useless #pragma
- comment (lib,...) references throughout the big windows.h tree (as
- observed at high linker warning levels).
-
-2002-02-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.h: Better guessing of LP64/ILP32 architecture, but now
- sensitive to presence of (suitable) <limits.h>
-
-2002-02-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.decls (Tcl_RegExpRange,Tcl_GetIndexFromObjStruct):
- Overlooked a few source incompatibilities. Now using CONST84.
- * generic/tclDecls.h: make genstubs
- * generic/tcl.h (Tcl_CmdObjTraceProc): silence warning from Sun
- Workshop compiler.
-
-2002-02-20 David Gravereaux <davygrvy@pobox.com>
-
- * win/buildall.vc.bat:
- * win/makefile.vc:
- * win/rules.vc: General clean-ups. Added compiler and linker tests for
- a) the pentium 0x0F errata, b) optimizing (not all have this), and c)
- linker v6 section alignment confusion. All these are tested first to
- make sure any D4002 or LNK1117 warnings aren't displayed. The pentium
- 0x0F errata is a recommended switch. The v5 linker's section alignment
- default is 512, but the v6 linker was changed to 4096 in an attempt to
- speed loading on Win98. I changed the default to always be 512 across
- both linkers, unless linking statically, then 4096 is used for the
- claimed speed effect. Using a 512 alignment saves 12k bytes of dead
- space in the DLL.
-
- Added IA64 B-stepping errata switch when the compiler supports it.
-
- Added profiling to $(lflags) when requested and also removed the
- explict -entry option as the default works fine as is.
-
- Removed win/tclWinInit.c from the special case section to let it use
- the common implicit rule as the $(EXTFLAGS) macro it had was never
- referenced anywhere.
-
-2002-02-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tcl.h: Added code to guess the correct settings for
- TCL_WIDE_INT_IS_LONG and TCL_WIDE_INT_TYPE when configure doesn't tell
- us them, as can happen with extensions.
-
-2002-02-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/format.n: Updated docs to list the specification.
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): Made behaviour on 64-bit
- platforms correctly meet the specification, that %d works with the
- native word-sized integer, instead of trying to guess (wrongly)
- from the value being passed.
-
-2002-02-19 Don Porter <dgp@users.sourceforge.net>
-
- * changes: First draft of updated changes for 8.4a4 release.
-
-2002-02-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixPort.h: add strtoll/strtoull declarations for
- platforms that do not define them.
-
- * generic/tclIndexObj.c (STRING_AT): removed ptrdiff_t cast and
- use of VOID* in default case (GNU-ism).
-
-2002-02-15 Kevin Kenny <kennykb@acm.org>
-
- * compat/strtoll.c:
- * compat/strtoul.c:
- * compat/strtoull.c:
- * generic/tclIOUtil.c:
- * generic/tclPosixStr.c:
- * generic/tclTest.c:
- * generic/tclTestObj.c:
- * tests/get.test:
- * win/Makefile.vc: Further tweaks to the TIP 72 patch to make it
- compile under VC++.
-
-2002-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tclExecute.c:
- * tclIOGT.c:
- * tclIndexObj.c: Touchups to the TIP 72 patch to make it compileable
- under Windows again. The changes are not complete, there is one nasty
- regarding _stati64
-
-2002-02-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- +----------------------+
- | TIP #72 IMPLEMENTED. |
- +----------------------+
-
- There are a lot of changes from this TIP, so please see
- http://purl.org/tcl/tip/72.html for discussion of
- backward-compatibility issues, but the main ones modifications are in:
-
- * generic/tcl.h: New types.
- * generic/tcl.decls: New public functions.
- * generic/tclExecute.c: 64-bit aware bytecode engine.
- * generic/tclBinary.c: 64-bit handling in [binary] command.
- * generic/tclScan.c: 64-bit handling in [scan] command.
- * generic/tclCmdAH.c: 64-bit handling in [file] and [format]
- commands.
- * generic/tclBasic.c: New "wordSize" entry in ::tcl_platform.
- * generic/tclFCmd.c: Large-file support (with many consequences.)
- * generic/tclIO.c: Large-file support (with many consequences.)
- * compat/strtoll.c, compat/strtoull.c: New support functions.
- * unix/tcl.m4, unix/configure: 64-bit support and greatly enhanced
- caching.
-
- Most other changes, including all those in doc/* and test/* as well as
- the majority in the platform directories, follow on from these.
-
- Also coming out of the woodwork:
- * generic/tclIndex.c: Better support for Cray PVP.
- * win/tclWinMtherr.c: Better Borland support.
-
- Note that, in a number of places through the Unix part of the platform
- support, there are Tcl_Platform* references. These are expanded into
- the correct way to call that particular underlying function, i.e. with
- or without a '64' suffix, and should be used by people working on the
- core in preference to the API functions they overlay so that the code
- remains portable depending on the presence or absence of 64-bit
- support on the underlying platform.
-
- ***POTENTIAL INCOMPATIBILITY***: Extracted from the TIP
-
- SUMMARY OF INCOMPATIBILITIES AND FIXES
- ======================================
-
- The behaviour of expressions containing constants that appear positive
- but which have a negative internal representation will change, as
- these will now usually be interpreted as wide integers. This is always
- fixable by replacing the constant with int(constant).
-
- Extensions creating new channel types will need to be altered as
- different types are now in use in those areas. The change to the
- declaration of Tcl_FSStat and Tcl_FSLstat (which are the new preferred
- API in any case) are less serious as no non-alpha releases have been
- made yet with those API functions.
-
- Scripts that are lax about the use of the l modifier in format and
- scan will probably need to be rewritten. This should be very uncommon
- though as previously it had absolutely no effect.
-
- Extensions that create new math functions that take more than one
- argument will need to be recompiled (the size of Tcl_Value changes),
- and functions that accept arguments of any type (TCL_EITHER) will need
- to be rewritten to handle wide integer values. (I do not expect this
- to affect many extensions at all.)
-
-2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIOCmd.c (Tcl_GetsObjCmd): Trivial fix for [Bug 517503], a
- memory leak reported by Miguel Sofer <msofer@users.sf.net>. The leak
- happens if an error occurs for "set var [gets $chan]" and leak one
- empty object.
-
-2002-02-12 David Gravereaux <davygrvy@pobox.com>
-
- * djgpp/ (new directory)
- * djgpp/Makefile (new):
- * unix/tclAppInit.c:
- * unix/tclMtherr.c:
- * unix/tclUnixFCmd.c:
- * unix/tclUnixFile.c:
- * unix/tclUnixInit.c:
- * unix/tclUnixPort.h: Early stage of DJGPP support for building Tcl
- on DOS. Dynamic loading isn't working, yet. Requires watt32 for the
- TCP/IP stack. No autoconf, yet. Barely tested, but makes a working exe
- that runs Tcl in protected-mode, flat memory. [exec] and pipes will
- need the most work as multi-tasking on DOS has to be carefully.
-
-2002-02-10 Kevin Kenny <kennykb@acm.org>
-
- * doc/CrtObjCmd.3:
- * doc/CrtTrace.3:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * generic/tclTest.c:
- * tests/basic.test: Added Tcl_CreateObjTrace,
- Tcl_GetCommandInfoFromToken and Tcl_SetCommandInfoFromToken.
- (TIPs #32 and #79.)
-
- * generic/tclDecls.h:
- * generic/tclStubInit.c: Regenerated Stubs tables.
-
-2002-02-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: added -pthread for FreeBSD to EXTRA_CFLAGS and
- LDFLAGS. Also triggered nodots only for FreeBSD-3. Added
- AC_DEFINE(_POSIX_PTHREAD_SEMANTICS) for Solaris.
-
- * unix/tclUnixPort.h:
- * unix/tclUnixThrd.c: added thread-safe versions of readdir,
- localtime, gmtime and inet_ntoa for threaded build. (jgdavidson)
-
- * generic/tclScan.c (Tcl_ScanObjCmd): prevented ckfree being called on
- a pointer to NULL.
-
-2002-02-07 Don Porter <dgp@users.sourceforge.net>
-
- * doc/DString.3:
- * doc/Encoding.3:
- * doc/GetCwd.3:
- * doc/SplitPath.3:
- * doc/Translate.3:
- * doc/Utf.3:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclEncoding.c:
- * generic/tclEnv.c:
- * generic/tclFileName.c:
- * generic/tclIOUtil.c:
- * generic/tclUtf.c:
- * generic/tclUtil.c:
- * mac/tclMacInit.c:
- * unix/tclUnixFile.c:
- * unix/tclUnixInit.c:
- * unix/tclUnixPipe.c:
- * win/tclWin32Dll.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclWinInit.c: Partial TIP 27 rollback. Following routines
- restored to return (char *): Tcl_DStringAppend,
- Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName,
- Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString,
- Tcl_UniCharToUtfDString, Tcl_GetCwd, Tcl_WinTCharToUtf. Also restored
- Tcl_WinUtfToTChar to return (TCHAR *) and Tcl_UtfToUniCharDString to
- return (Tcl_UniChar *). Modified some callers. This change recognizes
- that Tcl_DStrings are de-facto white-box objects.
-
- * generic/tclDecls.h:
- * generic/tclPlatDecls.h: make genstubs
-
- * generic/tclCmdMZ.c: corrected use of C++-style comment.
-
-2002-02-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/scan.test:
- * generic/tclScan.c (Tcl_ScanObjCmd): corrected scan 0x... %x handling
- that didn't accept the 0x as a prelude to a base 16 number. [Bug
- 495213]
-
- * generic/tclCompCmds.c (TclCompileRegexpCmd): made early check for
- bad RE to stop checking further.
-
- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): added special case to search
- for simple 'string map' style regsub calls. Delayed creation of
- resultPtr object until an initial match is made, as the input string
- object can then be reused for no matches.
- (Tcl_StringObjCmd): optimization improvements to the STR_MAP
- algorithm for zero-length and nocase cases.
-
- * tests/regexp.test:
- * tests/regexpComp.test: extra code coverage tests.
-
- * tests/string.test: added 10.18 and 10.19 extra tests.
-
- * generic/regc_locale.c (casecmp): slight performance improvement.
-
-2002-02-05 Don Porter <dgp@users.sourceforge.net>
-
- * library/http/http.tcl:
- * library/http/pkgIndex.tcl: Corrected use of http::error when
- ::error was intended. Bump to http 2.4.2.
-
-2002-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/tclUnixChan.c (FileOutputProc): Fixed [bug 465765] reported by
- Dale Talcott <daletalcott@users.sourceforge.net>. Avoid writing
- nothing into a file as STREAM based implementations will consider this
- a EOF (if the file is a pipe). Not done in the generic layer as this
- type of writing is actually useful to check the state of a socket.
-
- * doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid' as
- the command to use to retrieve the pid of a command pipeline created
- via 'open'.
-
-2002-02-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): handle quirky about case
- earlier to avoid shimmering problem.
-
-2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * tests/io.test: io-39.22 split into two tests, one platform
- dependent, the other not. -eofchar is not empty on the windows
- platform.
-
-2002-02-01 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclTest.c: fix to picky windows compiler problem with the
- 'MainLoop' function declaration.
-
-2002-01-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinFCmd.c: TIP 27: Applied patch fixing CONST warnings on
- behalf of Don Porter <dgp@users.sourceforge.net>.
-
-2002-01-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclInt.h: For each interface identified in the TIP 27
- changes below as a POTENTIAL INCOMPATIBILITY, the source of the
- incompatibility has been parameterized so that it can be removed. When
- compiling extension code against the Tcl header files, use the
- compiler flag -DUSE_NON_CONST to remove the irresolvable source
- incompatibilities introduced by the TIP 27 changes. Resolvable changes
- are left for extension authors to resolve.
- * generic/tclDecls.h: make genstubs
-
-2002-01-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3: added documentation for 3 public functions which
- had been overlooked. [Bug 507701]
- * unix/mkLinks: make mklinks
-
-2002-01-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/regexpComp.test:
- * generic/tclCompCmds.c (TclCompileRegexpCmd): enhanced to support
- -nocase and -- options.
-
-2002-01-28 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_LOAD_TCLCONFIG):
- * win/tcl.m4 (SC_LOAD_TCLCONFIG): Set TCL_LIB_SPEC, TCL_STUB_LIB_SPEC,
- and TCL_STUB_LIB_PATH to the values of TCL_BUILD_LIB_SPEC,
- TCL_BUILD_STUB_LIB_SPEC, and TCL_BUILD_STUB_LIB_PATH when tclConfig.sh
- is loaded from the build directory. A Tcl extension should make use of
- the non-build versions of these variables since they will work in both
- cases. This modification was described in TIP 34.
-
-2002-01-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey)
- (DeleteKey,GetKeyNames,GetType,GetValue,OpenSubKey,SetValue):
- redid the CONSTification as previous changes caused failing tests.
-
- * tests/regexpComp.test (new):
- * generic/tclInt.h:
- * generic/tclBasic.c: added TclCompileRegexpCmd entry
- * generic/tclCompCmds.c (TclCompileStringCmd): corrected to return
- TCL_OUT_LINE_COMPILE instead of TCL_ERROR for parsing errors, so
- it only throws the error for runtime compile, in case the user
- modifies 'string'.
- (TclCompileRegexpCmd): first try at a byte-compiled regexp command. It
- handles static strings and ^$ bounded static strings.
- (TclCompileAppendCmd): made TclPushVarName call always use
- TCL_CREATE_VAR as numWords is always > 2 at that point.
-
- * generic/tclExecute.c (TclExecuteByteCode:INST_LIST): correct
- possibly dangerous decr in macro call.
-
- * win/tclWinInit.c (TclpFindVariable): CONSTification touch-up
-
- * win/tclWinReg.c (OpenSubKey): corrected bug introduced in
- CONSTification that dropped pointer reference.
-
- * ChangeLog.2000 (new file):
- * ChangeLog: broke changes from 2000 into ChangeLog.2000 to reduce
- size of the main ChangeLog.
-
-2002-01-28 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclPlatDecls.h: Added preprocessor logic to force a
- typedef of TCHAR when __STDC__ is defined when using the uncommon
- -Za compiler switch with the microsoft compiler.
-
-2002-01-27 Don Porter <dgp@users.sourceforge.net>
-
- * doc/package.n: Documented global namespace context for script
- evaluation by [package require].
-
-2002-01-27 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * mac/tclMacChan.c:
- * mac/tclMacFCmd.c:
- * mac/tclMacFile.c:
- * mac/tclMacInit.c:
- * mac/tclMacLoad.c:
- * mac/tclMacResource.c:
- * mac/tclMacSock.c: TIP 27 CONSTification induced changes
-
- * tests/event.test:
- * tests/main.test: added catches/constraints to test that
- use features that don't exist on the mac.
-
-2002-01-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- Make -eofchar and -translation options read only for server sockets.
- [Bug 496733]
-
- * generic/tclIO.c (Tcl_GetChannelOption, Tcl_SetChannelOption):
- Instead of returning nothing for the -translation option on a server
- socket, always return "auto". Return the empty string enclosed in
- quotes for the -eofchar option on a server socket. Fixup -eofchar
- usage message so that it matches the implementation.
- * tests/io.test: Add -eofchar tests and -translation tests to ensure
- options are read only on server sockets.
- * tests/socket.test: Update tests to account for -eofchar and
- -translation option changes.
-
-2002-01-25 Don Porter <dgp@users.sourceforge.net>
-
- * compat/strstr.c (strstr):
- * generic/tclCmdAH.c (Tcl_FormatObjCmd):
- * generic/tclCmdIL.c (InfoNameOfExecutableCmd):
- * generic/tclEnv.c (ReplaceString):
- * generic/tclFileName.c (ExtractWinRoot):
- * generic/tclIO.c (FlushChannel,Tcl_BadChannelOption):
- * generic/tclStringObj.c (AppendUnicodeToUtfRep):
- * generic/tclThreadTest.c (TclCreateThread):
- * generic/tclUtf.c (Tcl_UtfPrev):
- * mac/tclMacFCmd.c (TclpObjListVolumes):
- * mac/tclMacResource.c (TclMacRegisterResourceFork,
- (BuildResourceForkList):
- * win/tclWinInit.c (AppendEnvironment): Sought out and eliminated
- instances of CONST-casting that are no longer needed after the
- TIP 27 effort.
-
- * Following is [Patch 501006]
- * generic/tclInt.decls (Tcl_AddInterpResolvers, Tcl_Export,
- (Tcl_FindNamespace, Tcl_GetInterpResolvers, Tcl_ForgetImport,
- (Tcl_Import, Tcl_RemoveInterpResolvers):
- * generic/tclNamesp.c (Tcl_Export, Tcl_Import, Tcl_ForgetImport,
- (Tcl_FindNamespace):
- * generic/tclResolve.c (Tcl_AddInterpResolvers,Tcl_GetInterpResolvers,
- (Tcl_RemoveInterpResolvers): Updated APIs in generic/tclResolve.c and
- generic/tclNamesp.c according to the guidelines of TIP 27.
- * generic/tclIntDecls.h: make genstubs
-
- * Following is [Patch 505630]
- * doc/AddErrorInfo.3:
- * generic/tcl.decls (Tcl_LogCommandInfo):
- * generic/tclBasic.c (Tcl_LogCommandInfo): Updated interfaces
- of generic/tclBasic.cc according to TIP 27.
- * generic/tclDecls.h: make genstubs
-
- * Following is [Patch 506818]
- * doc/Hash.3:
- * generic/tcl.decls (Tcl_HashStats):
- * generic/tclHash.c (Tcl_HashStats): Updated APIs of generic/tclHash.c
- according to guidelines of TIP 27.
- * generic/tclDecls.h: make genstubs
- * generic/tclVar.c (Tcl_ArrayObjCmd): Updated callers.
-
- * Following is [Patch 506807]
- * doc/ObjectType.3:
- * generic/tcl.decls (Tcl_GetObjType):
- * generic/tclObj.c (Tcl_GetObjType): Updated APIs of generic/tclObj.c
- according to guidelines of TIP 27.
- * generic/tclDecls.h: make genstubs
-
- * Following is [Patch 507304]
- * doc/Encoding.3:
- * generic/tcl.decls (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
- * win/tclWin32Dll.c (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
- Updated interfaces in win/tclWin32Dll.c according to TIP 27.
- * generic/tclPlatDecls.h: make genstubs
- * generic/tclIOUtil.c (TclpNativeToNormalized):
- * win/tclWinFCmd.c (TclpObjNormalizePath):
- * win/tclWinFile.c (TclpFindExecutable,TclpMatchInDirectory,
- (NativeIsExec,NativeStat):
- * win/tclWinLoad.c (TclpLoadFile):
- * win/tclWinPipe.c (TclpOpenFile,ApplicationType):
- * win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey,DeleteKey,
- (GetKeyNames,GetType,GetValue,OpenSubKey,SetValue):
- * win/tclWinSerial.c (SerialSetOptionProc): Update callers.
-
- * Following is [Patch 505072]
- * doc/Concat.3:
- * doc/Encoding.3:
- * doc/Filesystem.3:
- * doc/Macintosh.3:
- * doc/OpenFileChnl.3
- * doc/SetResult.3:
- * doc/SetVar.3:
- * doc/SplitList.3:
- * doc/SplitPath.3:
- * doc/Translate.3:
- * generic/tcl.h (Tcl_FSMatchInDirectoryProc):
- * generic/tclInt.h (TclpMatchInDirectory):
- * generic/tcl.decls (Tcl_Concat,Tcl_GetStringResult,Tcl_GetVar,
- (Tcl_GetVar2,Tcl_JoinPath,Tcl_Merge,Tcl_OpenCommandChannel,Tcl_SetVar,
- (Tcl_SetVar2,Tcl_SplitList,Tcl_SplitPath,Tcl_TranslateFileName,
- (Tcl_ExternalToUtfDString,Tcl_GetEncodingName,Tcl_UtfToExternalDString,
- (Tcl_GetDefaultEncodingDir,Tcl_SetDefaultEncodingDir,
- (Tcl_FSMatchInDirectory,Tcl_MacEvalResource,Tcl_MacFindResource):
- * generic/tclInt.decls (TclCreatePipeline,TclGetEnv,TclpGetCwd,
- (TclpCreateProcess):
- * mac/tclMacFile.c (TclpGetCwd):
- * generic/tclEncoding.c (Tcl_GetDefaultEncodingDir,
- (Tcl_SetDefaultEncodingDir,Tcl_GetEncodingName,
- (Tcl_ExternalToUtfDString,Tcl_UtfToExternalDString, OpenEncodingFile,
- (LoadEscapeEncoding):
- * generic/tclFileName.c (DoTildeSubst,Tcl_JoinPath,Tcl_SplitPath,
- (Tcl_TranslateFileName):
- * generic/tclIOUtil.c (Tcl_FSMatchInDirectory):
- * generic/tclPipe.c (FileForRedirect,TclCreatePipeline,
- (Tcl_OpenCommandChannel):
- * generic/tclResult.c (Tcl_GetStringResult):
- * generic/tclUtil.c (Tcl_Concat,Tcl_SplitList,Tcl_Merge):
- * generic/tclVar.c (Tcl_GetVar,Tcl_GetVar2,Tcl_SetVar,Tcl_SetVar2):
- * mac/tclMacResource.c (Tcl_MacEvalResource,Tcl_MacFindResource):
- Updated interfaces of generic/tclEncoding, generic/tclFilename.c,
- generic/tclIOUtil.c, generic/tclPipe.c, generic/tclResult.c,
- generic/tclUtil.c, generic/tclVar.c and mac/tclMacResource.c according
- to TIP 27. Tcl_TranslateFileName rewritten as wrapper around VFS-aware
- version.
- ***POTENTIAL INCOMPATIBILITY***
- Includes source incompatibilities: argv arguments of Tcl_Concat,
- Tcl_JoinPath, Tcl_OpenCommandChannel, Tcl_Merge; argvPtr arguments of
- Tcl_SplitList and Tcl_SplitPath.
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
- * generic/tclCkalloc.c (MemoryCmd):
- * generic/tclClock.c (FormatClock):
- * generic/tclCmdAH.c (Tcl_CaseObjCmd,Tcl_EncodingObjCmd,Tcl_FileObjCmd):
- * generic/tclCmdIL.c (InfoLibraryCmd,InfoPatchLevelCmd,
- (InfoTclVersionCmd):
- * generic/tclCompCmds.c (TclCompileForeachCmd):
- * generic/tclCompCmds.h (TclCompileForeachCmd):
- * generic/tclCompile.c (TclFindCompiledLocal):
- * generic/tclEnv.c (TclSetupEnv,TclSetEnv,Tcl_PutEnv,TclGetEnv,
- (EnvTraceProc):
- * generic/tclEvent.c (Tcl_BackgroundError):
- * generic/tclIO.c (Tcl_BadChannelOption,Tcl_SetChannelOption):
- * generic/tclIOCmd.c (Tcl_ExecObjCmd,Tcl_OpenObjCmd):
- * generic/tclIOSock.c (TclSockGetPort):
- * generic/tclIOUtil.c (SetFsPathFromAny):
- * generic/tclLink.c (LinkTraceProc):
- * generic/tclMain.c (Tcl_Main):
- * generic/tclNamesp.c (TclTeardownNamespace):
- * generic/tclProc.c (TclCreateProc):
- * generic/tclTest.c (TestregexpObjCmd,TesttranslatefilenameCmd,
- (TestchmodCmd,GetTimesCmd,TestsetCmd,TestOpenFileChannelProc1,
- (TestOpenFileChannelProc2,TestOpenFileChannelProc3,AsyncHandlerProc,
- (TestpanicCmd):
- * generic/tclThreadTest.c (ThreadErrorProc,ThreadEventProc):
- * generic/tclUtil.c (TclPrecTraceProc):
- * mac/tclMacFCmd.c (GetFileSpecs):
- * mac/tclMacFile.c (TclpMatchInDirectory):
- * mac/tclMacInit.c (TclpInitLibraryPath,Tcl_SourceRCFile):
- * mac/tclMacOSA.c (tclOSAStore,tclOSALoad):
- * mac/tclMacResource.c (Tcl_MacEvalResource):
- * unix/tclUnixFCmd.c (TclpObjNormalizePath):
- * unix/tclUnixFile.c (TclpMatchInDirectory,TclpGetUserHome,TclpGetCwd,
- (TclpReadLink):
- * unix/tclUnixInit.c (TclpInitLibraryPath,TclpSetVariables,
- (Tcl_SourceRCFile):
- * unix/tclUnixPipe.c (TclpOpenFile,TclpCreateTempFile,
- (TclpCreateProcess):
- * win/tclWinFile.c (TclpGetCwd,TclpMatchInDirectory):
- * win/tclWinInit.c (TclpInitLibraryPath,Tcl_SourceRCFile,
- (TclpSetVariables):
- * win/tclWinPipe.c (TclpCreateProcess): Updated callers.
-
-2002-01-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c (SetFsPathFromAny): Corrected tilde-substitution
- of pathnames where > 1 separator follows the ~. [Bug 504950]
-
-2002-01-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/pkgIndex.tcl:
- * library/http/http.tcl: don't add port in default case to handle
- broken servers. http bumped to 2.4.1 [Bug 504508]
-
-2002-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * unix/mkLinks: Regenerated.
- * doc/CrtChannel.3:
- * doc/ChnlStack.3: Moved documentation for 'Tcl_GetTopChannel' from
- 'CrtChannel' to 'ChnlStack'. Added documentation of
- 'Tcl_GetStackedChannel'. [Bug 506147] reported by Mark Patton
- <msp@users.sourceforge.net>.
-
-2002-01-23 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinFile.c (NativeAccess,NativeStat,NativeIsExec,
- (TclpGetUserHome):
- * win/tclWinPort.h (TclWinSerialReopen):
- * win/tclWinSerial.c (TclWinSerialReopen):
- * win/tclWinSock.c (Tcl_OpenTcpServer): Corrections to earlier TIP 27
- changes. Thanks to Andreas Kupries for the feedback.
- * generic/tclPlatDecls.h: make genstubs
-
- * doc/GetHostName.3:
- * doc/GetOpnFl.3:
- * doc/OpenTcp.3:
- * tcl.decls (Tcl_GetHostName,Tcl_GetOpenFile,Tcl_OpenTcpClient,
- (Tcl_OpenTclServer):
- * mac/tclMacSock.c (CreateSocket,Tcl_OpenTcpClient,Tcl_OpenTcpServer,
- (Tcl_GetHostName,GetHostFromString):
- * unix/tclUnixChan.c (CreateSocket,CreateSocketAddress,
- (Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetOpenFile):
- * unix/tclUnixSock.c (Tcl_GetHostName):
- * win/tclWinSock.c (CreateSocket,CreateSocketAddress,
- (Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetHostName):
- Updated socket interfaces according to TIP 27.
- * generic/tclCmdIL.c (InfoHostnameCmd): Updated callers.
- * generic/tclDecls.h: make genstubs
-
-2002-01-21 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclLoadNone.c: TclpLoadFile() didn't match proto of typedef
- Tcl_FSLoadFileProc. OK'd by vincentdarley. [Patch 502488]
-
-2002-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIO.c (WriteChars): Fix for [Bug 506297], reported by
- Martin Forssen <ruric@users.sourceforge.net>. The encoding chosen in
- the script exposing the bug writes out three intro characters when
- TCL_ENCODING_START is set, but does not consume any input as
- TCL_ENCODING_END is cleared. As some output was generated the
- enclosing loop calls UtfToExternal again, again with START set. Three
- more characters in the out and still no use of input ... To break this
- infinite loop we remove TCL_ENCODING_START from the set of flags after
- the first call (no condition is required, the later calls remove an
- unset flag, which is a no-op). This causes the subsequent calls to
- UtfToExternal to consume and convert the actual input.
-
-2002-01-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTest.c: Converted declarations of TestReport file system
- to more portable form. [Bug 501417]
-
- * generic/tcl.decls (Tcl_TraceCommand,Tcl_UntraceCommand,
- (Tcl_CommandTraceInfo):
- * generic/tclCmdMZ.c (Tcl_TraceCommand,Tcl_UntraceCommand,
- (Tcl_CommandTraceInfo): Updated APIs in generic/tclCmdMZ.c according
- to the guidelines of TIP 27.
- * generic/tclDecls.h: make genstubs
-
-2002-01-18 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c: Overlooked callers of Tcl_FSGetNativePath
-
- * win/tclWinDde.c:
- * win/tclWinReg.c: Overlooked callers of Tcl_GetIndexFromObj
-
-2002-01-18 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclThreadTest.c:
- * mac/tclMacChan.c:
- * mac/tclMacFCmd.c:
- * mac/tclMacFile.c:
- * mac/tclMacLoad.c:
- * mac/tclMacResource.c: TIP 27 CONSTification broke the mac build in a
- number of places.
-
-2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIOCmd.c (Tcl_GetsObjCmd): Fixed [Bug 504642] as reported
- by Brian Griffin <bgriffin@users.sourceforge.net>, using his
- patch. Before the patch the generic I/O layer held an unannounced
- reference to the interp result to store the read line into. This
- unfortunately has disastrous results if the channel driver executes a
- tcl script to perform its operation, this freeing the interp
- result. In that case we are dereferencing essentially a dangling
- reference. It is not truly dangling because the object is in the free
- list, but this only causes us to smash the free list and have the
- error occur later somewhere else. The patch simply creates a new
- object for the line and later sets it into the interp result when we
- are done with reading.
-
-2002-01-16 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_LOAD_TCLCONFIG):
- * win/tcl.m4 (SC_LOAD_TCLCONFIG): Subst TCL_DBGX into
- TCL_STUB_LIB_FILE and TCL_STUB_LIB_FLAG variables so that an extension
- does not need to subst TCL_DBGX into its makefile. [Tk Bug 504356]
-
-2002-01-16 Don Porter <dgp@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * doc/GetCwd.3:
- * doc/GetIndex.3:
- * generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
- (Tcl_GetCwd, Tcl_FSFileAttrStrings, Tcl_FSGetNativePath,
- (Tcl_FSGetTranslatedStringPath):
- * generic/tcl.h (Tcl_FSFileAttrStringsProc):
- * generic/tclFCmd.c (TclFileAttrsCmd):
- * generic/tclIOUtil.c (Tcl_GetCwd,NativeFileAttrStrings,
- (Tcl_FSFileAttrStrings,Tcl_FSGetTranslatedStringPath,
- (Tcl_FSGetNativePath):
- * generic/tclIndexObj.c (Tcl_GetIndexFromObj,
- (Tcl_GetIndexFromObjStruct):
- More TIP 27 updates in tclIOUtil.c and tclIndexObj.c that were
- overlooked before. [Patch 504671]
- ***POTENTIAL INCOMPATIBILITY***
- Includes a source incompatibility in the tablePtr arguments of the
- Tcl_GetIndexFromObj* routines.
- * generic/tclDecls.h: make genstubs
-
- * generic/tclBinary.c (Tcl_BinaryObjCmd):
- * generic/tclClock.c (Tcl_ClockObjCmd):
- * generic/tclCmdAH.c (Tcl_EncodingObjCmd, Tcl_FileObjCmd):
- * generic/tclCmdIL.c (Tcl_InfoObjCmd,Tcl_LsearchObjCmd,Tcl_LsortObjCmd):
- * generic/tclCmdMZ.c (Tcl_TraceObjCmd,Tcl_RegexpObjCmd,Tcl_RegsubObjCmd,
- (Tcl_StringObjCmd,Tcl_SubstObjCmd,Tcl_SwitchObjCmd,
- (TclTraceCommandObjCmd,TclTraceVariableObjCmd):
- * generic/tclCompCmds.c (TclCompileStringCmd):
- * generic/tclEvent.c (Tcl_UpdateObjCmd):
- * generic/tclFileName.c (Tcl_GlobObjCmd):
- * generic/tclIO.c (Tcl_FileEventObjCmd):
- * generic/tclIOCmd.c (Tcl_SeekObjCmd,Tcl_ExecObjCmd,Tcl_SocketObjCmd,
- (Tcl_FcopyObjCmd):
- * generic/tclInterp.c (Tcl_InterpObjCmd,SlaveObjCmd):
- * generic/tclNamesp.c (Tcl_NamespaceObjCmd):
- * generic/tclPkg.c (Tcl_PackageObjCmd):
- * generic/tclTest.c (Tcltest_Init,TestencodingObjCmd,TestgetplatformCmd,
- (TestlocaleCmd,TestregexpObjCmd,TestsaveresultCmd,
- (TestGetIndexFromObjStructObjCmd,TestReportFileAttrStrings):
- * generic/tclTestObj.c (TestindexObjCmd,TeststringObjCmd):
- * generic/tclTimer.c (Tcl_AfterObjCmd):
- * generic/tclVar.c (Tcl_ArrayObjCmd):
- * mac/tclMacFCmd.c (SetFileFinderAttributes):
- * unix/tclUnixChan.c (TclpOpenFileChannel):
- * unix/tclUnixFCmd.c (tclpFileAttrStrings):
- * unix/tclUnixFile.c (TclpObjAccess,TclpObjChdir,TclpObjStat,
- (TclpObjLstat):
- * win/tclWinFCmd.c (tclpFileAttrStrings): Updated callers.
-
- * doc/RegExp.3:
- * doc/Utf.3:
- * generic/tcl.decls:
- * generic/tclInt.decls:
- * generic/tclRegexp.c:
- * generic/tclUtf.c: Updated APIs in generic/tclUtf.c and
- generic/tclRegexp.c according to the guidelines of TIP 27.
- [Patch 471509]
-
- * generic/regc_locale.c (element,cclass):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * generic/tclFileName.c (TclpGetNativePathType,SplitMacPath):
- * generic/tclIO.c (ReadChars):
- * mac/tclMacLoad.c (TclpLoadFile):
- * win/tclWinFile.c (TclpGetUserHome): Updated callers.
-
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
- * doc/ParseCmd.3 (Tcl_ParseVar):
- * generic/tcl.decls (Tcl_ParseVar):
- * generic/tclParse.c (Tcl_ParseVar):
- * generic/tclTest.c (TestparsevarObjCmd): Updated APIs in
- generic/tclParse.c according to the guidelines of TIP 27. Updated
- callers. [Patch 501046]
- * generic/tclDecls.h: make genstubs
-
- * generic/tcl.decls (Tcl_RecordAndEval):
- * generic/tclDecls.h: make genstubs
- * generic/tclHistory.c (Tcl_RecordAndEval): Updated APIs in
- generic/tclHistory.c according to the guidelines of TIP 27.
- [Patch 504091]
-
- * doc/CrtSlave.3:
- * generic/tcl.decls (Tcl_CreateAlias, Tcl_CreateAliasObj,
- (Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
- * generic/tclInterp.c (Tcl_CreateAlias, Tcl_CreateAliasObj,
- (Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
- Updated APIs in the file generic/tclInterp.c according to the
- guidelines of TIP 27. [Patch 501371]
- ***POTENTIAL INCOMPATIBILITY***
- Includes a source incompatibility in the targetCmdPtr arguments of the
- Tcl_GetAlias* routines.
-
- * generic/tclDecls.h: make genstubs
-
-2002-01-15 Don Porter <dgp@users.sourceforge.net>
-
- * doc/SetErrno.3 (Tcl_ErrnoMsg): Corrected documentation for
- Tcl_ErrnoMsg; it takes an integer argument. Thanks to Georgios
- Petasis. [Bug 468183]
-
- * doc/AddErrInfo.3 (Tcl_PosixError):
- * doc/Eval.3 (Tcl_EvalFile):
- * doc/FileSystem.c (Tcl_FSOpenFileChannel,Tcl_FSOpenFileChannelProc):
- * doc/OpenFileChnl.3 (Tcl_OpenFileChannel):
- * doc/SetErrno.3 (Tcl_ErrnoId,Tcl_ErrnoMsg):
- * doc/Signal.3 (Tcl_SignalId,Tcl_SignalMsg):
- * generic/tcl.decls (Tcl_ErrnoId,TclErrnoMsg,Tcl_EvalFile,
- (Tcl_OpenFileChannel,Tcl_PosixError,Tcl_SignalId,Tcl_SignalMsg,
- (Tcl_FSOpenFileChannel):
- * generic/tcl.h (Tcl_FSOpenFileChannelProc):
- * generic/tclIO.c (FlushChannel):
- * generic/tclIOUtil.c (Tcl_OpenFileChannel,Tcl_EvalFile,TclGetOpenMode,
- (Tcl_PosixError,Tcl_FSOpenFileChannel):
- * generic/tclInt.decls (TclGetOpenMode):
- * generic/tclInt.h (TclOpenFileChannelProc_,TclGetOpenMode,
- (TclpOpenFileChannel):
- * generic/tclPipe.c (TclCleanupChildren):
- * generic/tclPosixStr.c (Tcl_ErrnoId,Tcl_ErrnoMsg,Tcl_SignalId,
- (Tcl_SignalMsg):
- * generic.tclTest.c (PretendTclpOpenFileChannel,
- (TestOpenFileChannelProc1,TestOpenFileChannelProc2,
- (TestOpenFileChannelProc3,TestReportOpenFileChannel):
- * mac/tclMacChan.c (TclpOpenFileChannel):
- * unix/tclUnixChan.c (TclpOpenFileChannel):
- * win/tclWinChan.c (TclpOpenFileChannel): Updated APIs in
- generic/tclIOUtil.c and generic/tclPosixStr.c according to the
- guidelines of TIP 27. Updated callers. [Patch 499196]
-
- * generic/tclDecls.h:
- * generic/tclIntDecls.h: make genstubs
-
- * doc/CrtChannel.3:
- * doc/OpenFileChnl.3:
- * generic/tcl.decls:
- * generic/tclIO.h:
- * generic/tclIO.c (DoWrite, Tcl_RegisterChannel, Tcl_GetChannel,
- (Tcl_CreateChannel, Tcl_GetChannelName, CloseChannel, Tcl_Write,
- (Tcl_WriteRaw, Tcl_Ungets, Tcl_BadChannelOption, Tcl_GetChannelOption,
- (Tcl_SetChannelOption, Tcl_GetChannelNamesEx, Tcl_ChannelName):
- Updated APIs in the file generic/tclIO.c according to the guidelines
- of TIP 27. Several minor documentation corrections as well.
- [Patch 503565]
- * generic/tclDecls.h: make genstubs
-
- * generic/tcl.h (Tcl_DriverOutputProc, Tcl_DriverGetOptionProc,
- (Tcl_DriverSetOptionProc):
- * generic/tclIOGT.c (TransformOutputProc, TransformGetOptionProc,
- (TransformSetOptionProc):
- * mac/tclMacChan.c (FileOutput, StdIOOutput):
- * man/tclMacSock.c (TcpGetOptionProc, TcpOutput):
- * unix/tclUnixChan.c (FileOutputProc, TcpGetOptionProc, TcpOutputProc,
- (TtyGetOptionProc, TtySetOptionProc):
- * unix/tclUnixPipe.c (PipeOuputProc):
- * win/tclWinChan.c (FileOutputProc):
- * win/tclWinConsole.c (ConsleOutputProc):
- * win/tclWinPipe.c (PipeOuputProc):
- * win/tclWinSerial.c (SerialOutputProc, SerialGetOptionProc,
- (SerialSetOptionProc):
- * win/tclWinSock.c (TcpGetOptionProc, TcpOutput): Updated channel
- driver interface according to the guidelines of TIP 27. See also
- [Bug 500348].
-
- * doc/CrtChannel.3:
- * generic/tcl.h:
- * generic/tclIO.c:
- * generic/tclIO.h:
- * generic/tclInt.h:
- * tools/checkLibraryDoc.tcl:
- Moved Tcl_EolTranslation enum declaration from generic/tcl.h to
- generic/tclInt.h (renamed to TclEolTranslation). It is not used
- anywhere in Tcl's public interface.
-
-2002-01-14 Don Porter <dgp@users.sourceforge.net>
-
- * doc/GetIndex.3:
- * doc/WrongNumArgs.3:
- * generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
- (Tcl_WrongNumArgs):
- * generic/tclIndexObj.c (Tcl_GetIndexFromObj,Tcl_GetIndexFromObjStruct,
- (Tcl_WrongNumArgs): Updated APIs in the file generic/tclIndexObj.c
- according to the guidelines of TIP 27. [Patch 501491]
- * generic/tclDecls.h: make genstubs
-
-2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/configure.in:
- * win/configure: Regen.
- * win/configure.in: Use ${libdir} instead of ${exec_prefix}/lib
- to properly support the --libdir option to configure. [Bug 489370]
-
-2002-01-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * win/tclWinSerial.c (SerialSetOptionProc): Applied patch for [Bug
- 500348] supplied by Rolf Schroedter <schroedter@users.sf.net>. The
- function modified the contents of the the 'value' string and now does
- not do this anymore. This is a followup to the change made on
- 2001-12-17.
-
-2002-01-11 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Removed -GD compiler option. It was intended for
- future use, but MS is again changing the future at their whim. The
- D4002 warning was harmless though, but someone using VC .NET logged it
- as a concern. [Bug 501565]
-
-2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Burn Tcl build directory into tcltest executable
- to avoid crashes caused by ld loading a previously installed version
- of the tcl shared library. [Bug 218110]
-
-2002-01-10 Don Porter <dgp@users.sourceforge.net>,
- Kevin Kenny <kennykb@users.sourceforge.net>
-
- * unix/tclLoadDld.c (TclpLoadFile): syntax error: unbalanced parens.
- Kevin notes that it's far from clear that this file is ever included
- in an actual build; Linux without dlopen appears to be a nonexistent
- configuration.
-
-2002-01-08 Don Porter <dgp@users.sourceforge.net>,
- Kevin Kenny <kennykb@users.sourceforge.net>
-
- * doc/StaticPkg.3 (Tcl_StaticPackage):
- * generic/tcl.decls (Tcl_StaticPackage):
- * generic/tclDecls.h (Tcl_StaticPackage):
- * generic/tclInt.decls (TclGuessPackageName):
- * generic/tclInt.h (TclGuessPackageName):
- * generic/tclLoad.c (Tcl_StaticPackage):
- * generic/tclLoadNone.c (TclGuessPackageName):
- * mac/tclMacLoad.c (TclGuessPackageName):
- * unix/tclLoadAout.c (TclGuessPackageName):
- * unix/tclLoadDl.c (TclGuessPackageName):
- * unix/tclLoadDld.c (TclGuessPackageName):
- * unix/tclLoadDyld.c (TclGuessPackageName):
- * unix/tclLoadNext.c (TclGuessPackageName):
- * unix/tclLoadOSF.c (TclGuessPackageName):
- * unix/tclLoadShl.c (TclGuessPackageName):
- * win/tclWinLoad.c (TclGuessPackageName): Updated APIs in the files
- */tcl*Load*.c according to the guidelines of TIP 27. [Patch 501096]
-
-2002-01-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTest.c (MainLoop):
- * tests/main.test (Tcl_Main-1.{3,4,5,6}): Corrected some non-portable
- tests from the new Tcl_Main changes. Thanks to Kevin Kenny.
-
-2002-01-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEvent.c (TclInExit):
- * generic/tclIOUtil.c (SetFsPathFromAbsoluteNormalized,
- (SetFsPathFromAny,Tcl_FSNewNativePath,DupFsPathInternalRep):
- * generic/tclListObj.c (TclLsetList,TclLsetFlat): Added some type
- casts to satisfy picky compilers.
-
- * generic/tclMain.c: Bug fix: neglected the NULL case in
- TclGetStartupScriptFileName(). Broke Tk/wish.
-
-2002-01-05 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Tcl_Main.3:
- * generic/tclMain.c: Substantial rewrite and expanded documentation
- of Tcl_Main to correct a number of bugs and flaws:
-
- - Interactive Tcl_Main can now enter a main loop, exit that loop and
- continue interactive operations. The loop may even exit in the
- midst of interactive command typing without loss of the partial
- command. [Bugs 486453, 474131]
- - Tcl_Main now gracefully handles deletion of its master
- interpreter.
- - Interactive Tcl_Main can now operate with non-blocking stdin
- - Interactive Tcl_Main can now detect EOF on stdin even in
- mid-command. [Bug 491341]
- - Added VFS-aware internal routines for managing the startup script
- selection.
- - Tcl variable 'tcl_interactive' is now linked to C variable 'tty'
- so that one can disable/enable interactive prompts at the script
- level when there is no startup script. This is meant for use by
- the test suite.
- - Consistent use of the Tcl libraries standard channels as returned
- by Tcl_GetStdChannel(); as opposed to the channels named 'stdin',
- 'stdout', and 'stderr' in the master interp, which can be
- different or unavailable.
- - Tcl_Main now calls Tcl_Exit() if evaluation of [exit] in the
- master interpreter returns, assuring Tcl_Main does not return.
- - Documented Tcl_Main's absence from public stub table
- - Documented that Tcl_Main does not return.
- - Documented Tcl variables set by Tcl_Main.
- - All prompts are done from a single procedure, Prompt.
- - Use of Tcl_Obj-enabled interfaces everywhere.
-
- * generic/tclInt.decls (TclGetStartupScriptPath,
- (TclSetStartupScriptPath): New internal VFS-aware routines for
- managing the startup script of Tcl_Main.
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c: make genstubs
-
- * generic/tclTest.c (TestsetmainloopCmd,TestexitmainloopCmd,
- (Tcltest_Init,TestinterpdeleteCmd):
- * tests/main.test (new): Added new file to test suite that thoroughly
- tests generic/tclMain.c; added some new test commands for testing
- Tcl_SetMainLoop().
-
-2002-01-04 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Alloc.3:
- * doc/Concat.3:
- * doc/CrtMathFnc.3:
- * doc/Hash.3:
- * doc/Interp.3:
- * doc/LinkVar.3:
- * doc/ObjectType.3:
- * doc/PkgRequire.3:
- * doc/Preserve.3:
- * doc/SetResult.3:
- * doc/SplitList.3:
- * doc/SplitPath.3:
- * doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc,
- ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and
- to accurately describe when and how they are used. [Bug 497459]
-
- * generic/tclThreadJoin.c (TclRememberJoinableThread,TclJoinThread):
- Replaced Tcl_Alloc and Tcl_Free calls with ckalloc and ckfree so that
- memory debugging is supported.
-
-2002-01-04 Daniel Steffen <das@users.sourceforge.net>
-
- * mac/tclMacTime.c (TclpGetTZName): fix for daylight savings TZName bug
-
-2002-01-03 Don Porter <dgp@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * generic/tclIOUtil.c: Updated some old uses of "fileName" to
- new VFS terminology, "pathPtr".
-
-2002-01-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/basic.test (basic-39.4): Greatly simplified test while
- still leaving it so that it crashes when run without the fix to
- the [foreach] implementation.
- * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Stopped [Bug 494348] from
- happening by not trying to be so clever with cacheing; if nothing
- untoward is happening anyway, the less efficient technique will
- only add a few instruction cycles (one function call and a few
- derefs/assigns per list per iteration, with no change in the
- number of tests) and if something odd *is* going on, the code is
- now far more robust.
-
- * tests/basic.test (basic-39.4): Reproducable script from [Bug 494348]
-
-2002-01-02 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/util.test (Wrapper_Tcl_StringMatch,util-5.*): Rewrote so the
- test is performed with the right internal function since [string
- match] no longer uses Tcl_StringCaseMatch internally.
-
- * tests/string.test (string-11.51):
- * generic/tclUtf.c (Tcl_UniCharCaseMatch):
- * generic/tclUtil.c (Tcl_StringCaseMatch): Fault with matching
- case-insensitive non-ASCII patterns containing upper case characters.
- [Bug 233257]
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2003 b/ChangeLog.2003
deleted file mode 100644
index acdf81d..0000000
--- a/ChangeLog.2003
+++ /dev/null
@@ -1,3349 +0,0 @@
-2003-12-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWin32Dll.c (DllMain): Add HAVE_NO_SEH blocks in place of
- __try and __except statements to support gcc builds. This is needed
- after David's changes on 2003-12-21. [Patch 858493]
-
-2003-12-23 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclAlloc.c: All uses of 'panic' (the macro) changed to
- * generic/tclBasic.c: 'Tcl_Panic' (the function). The #define of
- * generic/tclBinary.c: panic in tcl.h clearly states it is deprecated
- * generic/tclCkalloc.c: in the comments. [Patch 865264]
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclCompCmds.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclConfig.c:
- * generic/tclDictObj.c:
- * generic/tclEncoding.c:
- * generic/tclEvent.c:
- * generic/tclExecute.c:
- * generic/tclHash.c:
- * generic/tclInterp.c:
- * generic/tclIO.c:
- * generic/tclIOCmd.c:
- * generic/tclIOUtil.c:
- * generic/tclListObj.c:
- * generic/tclLiteral.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclParse.c:
- * generic/tclPathObj.c:
- * generic/tclPkg.c:
- * generic/tclPreserve.c:
- * generic/tclProc.c:
- * generic/tclStringObj.c:
- * generic/tclTest.c:
- * generic/tclThreadAlloc.c:
- * generic/tclTimer.c:
- * generic/tclTrace.c:
- * generic/tclVar.c:
- * mac/tclMacChan.c:
- * mac/tclMacOSA.c:
- * mac/tclMacResource.c:
- * mac/tclMacSock.c
- * mac/tclMacThrd.c:
- * unix/tclUnixChan.c:
- * unix/tclUnixNotfy.c:
- * unix/tclUnixThrd.c:
- * unix/tclXtNotify.c:
- * win/tclWin32Dll.c:
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
- * win/tclWinNotify.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c:
- * win/tclWinThrd.c:
-
- * generic/tclInt.h: Deprecated use of Tcl_Ckalloc changed to
- Tcl_Alloc in the TclAllocObjStorage macro.
-
-2003-12-22 David Gravereaux <davygrvy@pobox.com>
-
- * win/nmakehlp.c:
- * win/rules.vc: New feature for extensions that use rules.vc. Now
- reads header files for version strings. No more hard coding
- TCL_VERSION = 8.5 and having to edit it when you swap cores.
-
- * win/makefile.vc: VERSION macro now set by reading tcl.h for it.
-
- * generic/tcl.h: Removed note that makefile.vc needs to have a version
- number changed.
-
-2003-12-21 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWin32Dll.c: Structured Exception Handling added around
- Tcl_Finalize called from DllMain's DLL_PROCESS_DETACH. We can't be
- 100% assured that Tcl is being unloaded by the OS in a stable
- condition and we need to protect the exit handlers should the stack be
- in a hosed state. AT&T style assembly for SEH under MinGW has not been
- added yet. This is a first part change for [Patch 858493]
-
-2003-12-17 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclBinary.c (DeleteScanNumberCache): fixed crashing bug when
- numeric scan-value cache contains NULL value.
-
-2003-12-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdAH.c:
- * unix/tclUnixFile.c:
- * win/tclWinFCmd.c:
- * tests/fCmd.test:
- * tests/fileSystem.test:
- * doc/file.n: final fix to support for relative links and its
- implications on normalization and other parts of the filesystem code.
- Fixes [Bug 859251] and some Windows problems with recursive file
- delete/copy and symbolic links.
-
-2003-12-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c:
- * tests/fileSystem.test: fix and tests for [Bug 860402] in new file
- normalization code.
-
-2003-12-17 Zoran Vasiljevic <zv@archiware.com>
-
- * generic/tclIOUtil.c: fixed 2 memory (object) leaks. [Bug 839519]
-
- * generic/tclPathObj.c: fixed Tcl_FSGetTranslatedPath to always return
- properly refcounted path object. [Bug 861515]
-
-2003-12-16 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fCmd.test: marking fCmd-9.14.2, as nonPortable, since on
- Solaris one can change the name of the current directory with 'file
- rename'.
- * doc/FileSystem.3: clarified documentation on ownership of return
- objects/strings of some Tcl_FS* calls.
-
-2003-12-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclThreadAlloc.c (binfo): Made variable file-local.
-
-2003-12-15 David Gravereaux <davygrvy@pobox.com>
-
- * win/tcl.rc:
- * win/tclsh.rc: Slight modification to the STRINGIFY macro to support
- Borland's rc tool.
-
- * win/tclWinFile.c (TclpUtime) : utimbuf struct not a problem with
- Borland.
-
- * win/tclWinTime.c (TclpGetDate) : Borland's localtime() has a slight
- behavioral difference.
-
- From Helmut Giese <hgiese@ratiosoft.com> [Patch 758097].
-
-2003-12-14 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclInt.decls: commented-out entry for TclpCheckStackSpace,
- removing it from the Stubs table. It's already declared in tclInt.h
- and labeled as a function that is not to be exported. Regened tables.
-
-2003-12-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): TIP#75 Implementation
- * tests/switch.test: Can now get submatch information when using
- * doc/switch.n: -regexp matching in [switch].
-
-2003-12-14 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: complete rewrite of generic file normalization
- code to cope with links followed by '..'. [Bug 849514], and parts of
- [Bug 859251]
-
-2003-12-12 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinChan.c: Win32's SetFilePointer() takes LONGs not DWORDs (a
- signed/unsigned mismatch). Redid local vars to avoid all casting
- except where truly required.
-
-2003-12-12 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdAH.c: fix to normalization of non-existent user name
- ('file normalize ~nobody') [Bug 858937]
- * doc/file.n: clarify behaviour of 'file link' when the target is not
- an absolute path.
- * doc/filename.n: correct documentation to say that Windows Tcl does
- handle '~user', for recent Windows releases, and clarified distinction
- between MacOS 'classic' and MacOS X.
- * doc/glob.n: clarification of glob's behaviour when returning
- filenames starting with a '~'.
-
- * tests/fileSystem.test:
- * tests/fileName.test: new tests added for the normalization problem
- above and other recentlt reported issues.
-
- * win/tclWinFile.c: corrected unclear comments
-
- * unix/tclUnixFile.c: allow creation of relative links. [Bug 833713]
-
-2003-12-11 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinSock.c (SocketThreadExitHandler) : added a TerminateThread
- fallback just in case the socket handler thread is really in a paused
- state. This can happen when Tcl is being unloaded by the OS from an
- exception handler. See MSDN docs on DllMain, it states this behavior.
-
-2003-12-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: updated OpenBSD build configuration based on
- [Patch #775246] (cassoff)
-
-2003-12-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixPort.h: #ifdef'd out declarations of errno which are
- * tools/man2tcl.c: known to cause problems with recent glibc.
- [Bug 852369]
-
-2003-12-09 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFile.c: fix to NT file permissions code [Bug 855923]
- * tests/winFile.test: added tests for NT file permissions - patch and
- test scripts supplied by Benny.
-
- * tests/winFCmd.test: fixed one test for when not running in C:/
-
-2003-12-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclBinary.c (DeleteScanNumberCache, ScanNumber): Made the
- numeric scan-value cache have proper references to the objects within
- it so strange patterns of writes won't cause references to freed
- objects. Thanks to Paul Obermeir for the report. [Bug 851747]
-
-2003-12-01 Miguel Sofer <msofer@users.sf.net>
-
- * doc/lset.n: fix typo [Bug 852224]
-
-2003-11-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c: Corrected faulty check for trailing white
- space in {expand} parsing. Thanks Andreas Leitgeb. [Bug 848262]
- * tests/parse.test: New tests for the bug.
-
-2003-11-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix to [Bug 845778] - Infinite recursion on
- [cd] (Windows only bug), for which new tests have just been added.
-
-2003-11-21 Don Porter <dgp@users.sourceforge.net>
-
- * tests/winFCmd.test (winFCmd-16.10,11): Merged new tests from
- core-8-4-branch.
-
-2003-11-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: fix flag bit collision between LOOKUP_FOR_UPVAR
- and TCL_PARSE_PART1 (deprecated) [Bug 835020]
-
-2003-11-19 Don Porter <dgp@users.sourceforge.net>
-
- * tests/compile.test (compile-16.22.0): Improved test for the recent
- fix for Bug 845412.
-
-2003-11-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompile.c (TclCompileScript): Added a guard for the
- expansion code so that long non-expanding commands don't get expansion
- infrastructure inserted in them, especially when that infrastructure
- isn't initialised. [Bug 845412]
-
-2003-11-18 David Gravereaux <davygrvy@pobox.com>
-
- * contrib/djgpp/Makefile: Changes from Victor Wagner
- * contrib/djgpp/langinfo.c (new): <vitus@45.free.net> for better
- * contrib/djgpp/langinfo.h (new): DJGPP support.
- * unix/tclUnixInit.c: .
- * unix/tclUnixChan.c: .
- * unix/tclUnixFCmd.c: .
-
-2003-11-17 Don Porter <dgp@users.sourceforge.net>
-
- * tests/reg.test: Added tests for [Bugs 230589, 504785, 505048, 840258]
- recently fixed by 2003-11-15 commit to regcomp.c by Pavel Goran. His
- notes on the fix: This bug results from an error in code that splits
- states into "progress" and "no-progress" ones. This error causes an
- interesting situation with the precollected single-linked list of
- states to be splitted: many items were added to the list, but only
- several of them are accessible from the list beginning, since the
- "tmp" member of struct state (which is used here to hold a pointer to
- the next list item) gets overwritten, which results in a "looped"
- chain. As a result, not all of states are splitted, and one state is
- splitted two times, causing incorrect "no-progress" flag values.
-
-2003-11-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Make sure that
- Tcl_AsyncInvoke is called regularly when processing bytecodes.
- * generic/tclTest.c (AsyncThreadProc, TestasyncCmd): Extended testing
- harness to send an asynchronous marking without relying on UNIX
- signals.
- * tests/async.test (async-4.*): Tests to check that async events are
- handled by the bytecode core. [Bug 746722]
-
-2003-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclTest.c (TestHashSystemHashCmd): Removed 'const' modifier
- from hash type structure; it should be const and the hash code assumes
- it behaves like const, but that's not how the API is defined. Like
- this, we are following in the same footsteps as Tcl_RegisterObjType()
- which has the same conditions on its argument. Stops VC++5.2 warning.
- [Bug 842511]
-
-2003-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclHash.c (Tcl_DeleteHashTable,Tcl_HashStats,RebuildTable):
- * generic/tclTest.c (TestHashSystemHashCmd): TIP#138 implementation,
- * tests/misc.test: plus a new chunk of stuff to test the hash
- functions more thoroughly in the test suite.
- [Patch 731356, modified]
-
- * doc/Tcl.n: Updated Tcl version number and changebars.
-
-2003-11-14 Don Porter <dgp@users.sourceforge.net>
-
- * doc/ParseCmd.3: Implementation of TIP 157. Adds recognition
- * doc/Tcl.n: of the new leading {expand} syntax on words.
- * generic/tcl.h: Parses such words as the new Tcl_Token type
- * generic/tclBasic.c: TCL_TOKEN_EXPAND_WORD. Updated Tcl_EvalEx and
- * generic/tclCompile.c: the bytecode compiler/execution engine to
- * generic/tclCompile.h: recognize the new token type. New opcodes
- * generic/tclExecute.c: INST_LIST_VERIFY and INST_INVOKE_EXP and a new
- * generic/tclParse.c: operand type OPERAND_ULIST1 are defined. Docs
- * generic/tclTest.c: and tests are included.
- * tests/basic.test:
- * tests/compile.test:
- * tests/parse.test:
-
- * library/auto.tcl: Replaced several [eval]s used to perform
- * library/package.tcl: argument expansion with the new syntax. In the
- * library/safe.tcl: test files lindex.test and lset.test, replaced
- * tests/cmdInfo.test: use of [eval] to force direct string
- * tests/encoding.test: evaluation with use of [testevalex] which more
- * tests/execute.test: directly and robustly serves the same purpose.
- * tests/fCmd.test:
- * tests/http.test:
- * tests/init.test:
- * tests/interp.test:
- * tests/io.test:
- * tests/ioUtil.test:
- * tests/iogt.test:
- * tests/lindex.test:
- * tests/lset.test:
- * tests/namespace-old.test:
- * tests/namespace.test:
- * tests/pkg.test:
- * tests/pkgMkIndex.test:
- * tests/proc.test:
- * tests/reg.test:
- * tests/trace.test:
- * tests/upvar.test:
- * tests/winConsole.test:
- * tests/winFCmd.test:
-
-2003-11-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/cmdMZ.test (cmdMZ-1.4): change to nonPortable as more systems
- are using permissions caching, and this isn't really a Tcl controlled
- issue.
-
-2003-11-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure:
- * unix/tcl.m4: improve AIX --enable-64bit handling
- remove -D__NO_STRING_INLINES -D__NO_MATH_INLINES from CFLAGS_OPTIMIZE
- on Linux. Make default opt -O2 (was -O).
-
-2003-11-11 David Gravereaux <davygrvy@pobox.com>
-
- * contrib/djgpp/Makefile: Suggested changes from vitus@45.free.net
- (Victor Wagner)
-
- * unix/tclUnixPort.h: added socklen_t typedef for DJGPP
-
-2003-11-10 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixInit.c (TclpInitLibraryPath):
- * win/tclWinInit.c (TclpInitLibraryPath): Fix for [Bug 832657]
- that should not run afoul of startup constraints.
-
- * library/dde/pkgIndex.tcl: Added safeguards so that registry and
- * library/reg/pkgIndex.tcl: dde packages are not offered on
- * win/tclWinDde.c: non-Windows platforms. Bumped to
- * win/tclWinReg.c: registry 1.1.3 and dde 1.3.
- * win/Makefile.in:
- * win/configure.in:
- * win/makefile.bc:
- * win/makefile.vc:
-
- * win/configure: autoconf (2.57)
-
-2003-11-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/cmdIL.test: Stopped cmdIL-5.5 from stomping over the test
- command, and updated the tests to use some tcltest2 features in
- relation to cleanup. [Bug 838384]
-
-2003-11-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdAH.c:
- * tests/fCmd.test: fix to misleading error message in 'file link'.
- [Bug 836208]
-
-2003-11-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to compiler warning/error with some
- compilers. [Bug 835918]
-
-2003-11-07 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: optimized builds define NDEBUG to turn off
- ThreadAlloc range checking.
-
-2003-11-05 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-2.10): New test to expose [Bug 832657]
- failure of TclpInitLibraryPath() to properly handle .. in the path
- of the executable.
-
-2003-11-04 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: added 'test' target.
-
-2003-11-03 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c
- * generic/tclInt.h: added comments and re-arranged code to clarify
- distinction between Tcl_LoadHandle, ClientData for 'load'ed code, and
- point out limitations of the design introduced with Tcl 8.4.
-
- * unix/tclUnixFile.c: fix to memory leak
-
- * generic/tclCmdIL.c: removed warning on Windows.
-
-2003-11-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LrepeatObjCmd): Check for sensible list
- lengths and allow for soft failure of the memory subsystem in the
- [lconcat] command [Bug 829027]. Uses direct list creation to avoid
- extra copies when working near the limit of available memory. Also
- reorganized to encourage optimizing compilers to optimize heavily.
- * generic/tclListObj.c (TclNewListObjDirect): New list constructor
- that does not copy the array of objects. Useful for creating
- potentially very large lists or where you are about to throw away the
- array argument which is being used in its entirety.
-
-2003-10-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (NEXT_INST macros): replaced macro variable
- "result" by "resultHandling" to avoid confusion.
-
-2003-10-23 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixChan.c (Tcl_MakeFileChannel): Applied [Patch 813606]
- fixing [Bug 813087]. Detection of sockets was off for Mac OS X which
- implements pipes as local sockets. The new code ensures that only IP
- sockets are detected as such.
-
- * win/tclWinSock.c (TcpWatchProc): Watch for FD_CLOSE too when asked
- for writable events by the generic layer.
- (SocketEventProc): Generate a writable event too when a close is
- detected.
-
- Together the changes fix [Bug 599468].
-
-2003-10-23 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/resource.test:
- * mac/tclMacResource.c: fix to resource freeing problem in 'resource'
- command reported by Bernard Desgraupes.
-
- * doc/FileSystem.3: updated documentation for 'glob' fix on 2003-10-13
- below
-
-2003-10-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_FileObjCmd): Changed FILE_ prefix to FCMD_
- to stop symbol/#def clashes on Cygwin/Mingw32 on NT. [Bug 822528]
-
-2003-10-21 Daniel Steffen <das@users.sourceforge.net>
-
- * tools/tcltk-man2html.tcl: fixed incorrect html generated for
- .IP/.TP lists, now use <DL><DT>...<DD>...<P><DT>...<DD>...</DL>
- instead of illegal <DL><P><DT>...<DD>...<P><DT>...<DD>...</DL>.
- Added skipping of directives directly after .TP to avoid them being
- used as item descriptions, e.g. .TP\n.VS in clock.n.
-
-2003-10-21 Andreas Kupries <andreask@pliers.activestate.com>
-
- * win/tclWinPipe.c (BuildCommandLine): Applied the patch coming with
- [Bug 805605] to the code, fixing the incorrect use of ispace noted by
- Ronald Dauster <ronaldd@users.sourceforge.net>.
-
-2003-10-20 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * doc/msgcat.n:
- * library/msgcat/msgcat.tcl (mclocale,mcload):
- * tools/tcl.wse.in:
- * unix/Makefile.in: Implementation of TIP#156, add a "root locale"
- * win/makefile.bc: to the 'msgcat' package. Advanced msgcat
- * win/Makefile.in: version number to 1.4
- * win/Makefile.vc:
-
-2003-10-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdIL.c (SortInfo,etc): Reorganized so that SortInfo
- carries an array of integer indices instead of a Tcl list. This nips
- shimmering problems in the bud and simplifies SelectObjFromSublist at
- the cost of making setup slightly more complex. [Bug 823768]
-
-2003-10-14 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c (sigHandler): Punt gracefully if exitToken has
- already been destroyed.
-
-2003-10-14 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclCmdMZ.c:
- * tests/regexp.test: fix to [Bug 823524] in regsub; added three new
- tests.
-
-2003-10-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclAppendObjToErrorInfo): New internal routine
- that appends a Tcl_Obj to the errorInfo, saving the caller the trouble
- of extracting the string rep.
-
- * generic/tclStringObj.c (TclAppendLimitedToObj): New internal
- routine that supports truncated appends with optional ellipsis marking.
- This single routine supports UTF-8-safe truncated appends needed in
- several places throughout the Tcl source code, mostly for error and
- stack messages. Clean fix for [Bug 760872].
-
- * generic/tclInt.h: Declarations for new internal routines.
-
- * generic/tclCmdMZ.c: Updated callers to use the new routines.
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclExecute.c:
- * generic/tclIOUtil.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclParseExpr.c:
- * generic/tclProc.c:
- * generic/tclStringObj.c:
- * mac/tclMacResource.c:
-
- * library/init.tcl: Updated ::errorInfo cleanup in [unknown] to
- reflect slight modifications to Tcl_LogCommandInfo(). Corrects failing
- init-4.* tests.
-
-2003-10-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- TIP#127 IMPLEMENTATION FROM JOE MICHAEL SCHLENKER
-
- * generic/tclCmdIL.c (SelectObjFromSublist): Element selection engine.
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd):
- * tests/lsearch.test: Set up and use of element selection engine,
- * tests/cmdIL.test: plus tests and documentation.
- * doc/lsearch.n: Based on [Patch 693836]
- * doc/lsort.n:
-
-2003-10-13 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tcl.h:
- * generic/tclFileName.c:
- * generic/tclIOUtil.c:
- * generic/tclPathObj.c:
- * generic/tclTest.c:
- * mac/tclMacFile.c:
- * tests/fileName.test: better tests for [Bug 813273]
- * unix/tclUnixFCmd.c:
- * unix/tclUnixFile.c:
- * win/tclWin32Dll.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclFileInt.h:
-
- Fixed [Bug 800106] in which 'glob' was incapable of merging the
- results of a directory listing (real or virtual) and any virtual
- filesystem mountpoints in that directory (the latter were ignored).
- This meant boundaries between different filesystems were not seamless
- (e.g. 'glob */*' across a filesystem boundary was wrong). Added new
- entry to Tcl_GlobTypeData in a totally backwards compatible way. To
- allow listing of mounts, registered filesystems must support the
- 'TCL_GLOB_TYPE_MOUNT' flag. If this is not supported (e.g. in tclvfs
- 1.2) then mounts will simply not be listed for that filesystem.
-
- Fixed [Bug 749876] 'file writable/readable/etc' (NativeAccess) using
- correct permission checking code for Windows NT/2000/XP where more
- complex user-based security/access priveleges are available,
- particularly on shared volumes. The performance impact of this extra
- checking will need further investigation. Note: Win 95,98,ME have no
- support for this.
-
- Also made better use of normalized rather than translated paths in the
- platform specific code.
-
-2003-10-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixTest.c (TestalarmCmd): don't bother checking return
- value of alarm. [Bug #664755] (english)
-
-2003-10-09 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Applied patches for bug #801467 by Joe Mistachkin
- * win/tclAppInit.c: to fix incompatible TCL_MEM_DEBUG handling in
- * generic/tclObj.c: Win32 VC builds.
-
-2003-10-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Save and restore the iPtr->flag bits that
- control the state of errorCode and errorInfo management when calling
- "leave" execution traces, so that all error information of the traced
- command is still available whether traced or not. [Bug 760947]
- Thanks to Yahalom Emet.
-
-2003-10-08 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclTest.c (TestNumUtfCharsCmd): Command to allow finer
- access to Tcl_NumUtfChars for testing.
- * generic/tclUtf.c (Tcl_NumUtfChars): Corrected string length
- determining when the length parameter is negative; the terminator is a
- zero byte, not (necessarily) a \u0000 character. [Bug 769812]
-
-2003-10-07 Don Porter <dgp@users.sourceforge.net>
-
- * tests/cmdAH.test:
- * tests/exec.test: Corrected temporary file management
- * tests/fileSystem.test: issues uncovered by -debug 1 test
- * tests/io.test: operations. Also backported some
- * tests/ioCmd.test: other fixes from the HEAD.
- * tests/main.test:
- * tests/pid.test: [Bugs 675605, 675655, 675659]
- * tests/socket.test:
- * tests/source.test:
-
- * tests/fCmd.test: Run tests with the [temporaryDirectory] as the
- current directory, so that tests can depend on ability to write files.
- [Bug 575837]
-
- * doc/OpenFileChnl.3: Updated Tcl_Tell and Tcl_Seek documentation to
- reflect that they now return Tcl_WideInt (TIP 72). [Bug 787537]
-
- * tests/io.test: Corrected several tests that failed when paths
- * tests/ioCmd.test: included regexp-special chars. [Bug 775394]
-
-2003-10-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure:
- * win/tcl.m4: removed incorrect checks for existence of optimization.
- TCL_CFG_OPTIMIZED is now defined whenever the user does not build with
- --enable-symbols.
-
-2003-10-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/regexp.test: Matched [makeFile] with [removeFile].
- * tests/regexpComp.test: [Bug 675652]
-
- * tests/fCmd.test (fCmd-8.2): Test only that tilde-substitution
- happens, not for any particular result. [Bug 685991]
-
- * unix/tcl.m4 (SC_PATH_TCLCONFIG): Corrected search path so that
- alpha and beta releases of Tcl are not favored. [Bug 608698]
-
- * tests/reg.test: Corrected duplicate test names.
- * tests/resource.test: [Bugs 710370, 710358]
- * tests/dict.test:
-
- * tests/dict.test: Updated [package require tcltest] lines to
- * tests/fileSystem.test: indiciate that these test files
- * tests/lrepeat.test: use features of tcltest 2. [Bug 706114]
- * tests/notify.test:
- * tests/parseExpr.test:
- * tests/unixNotfy.test:
- * tests/winDde.test:
-
-2003-10-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC):
- * tests/execute.test (execute-8.2): fix for [Bug 816641] - faulty
- execution and catch stack management.
-
-2003-10-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Fixed error in ref count management of command
- * generic/tclCmdMZ.c: and execution traces that caused access to
- freed memory in trace-32.1. [Bug 811483]
-
-2003-10-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c: Corrected comingling of introspection results of
- [trace info command] and [trace info execution]. [Bug 807243]
- Thanks to Mark Saye.
-
-2003-10-01 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: fixed redo prebinding bug when DESTDIR="".
- * mac/tclMacResource.c: fixed possible NULL dereference (bdesgraupes).
-
-2003-09-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c:
- * tests/fileName.test: fix to inconsistent handling of backslash
- path separators on Windows in 'file join' [Bug 813273]
-
-2003-09-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclPathObj.c (TclNativePathInFilesystem,TclFSGetPathType):
- * generic/tclIOUtil.c (TclNativeDupInternalRep,TclGetPathType): Rename
- to make sure function names won't interfere with other non-Tcl code
- (reported by George Staplin)
-
- TIP#121 IMPLEMENTATION FROM JOE MISTACHKIN
-
- * generic/tclEvent.c (Tcl_SetExitProc,Tcl_Exit): Implementation of
- application exit handler scheme.
- * generic/tcl.decls (Tcl_SetExitProc): Public declaration.
- * doc/Exit.3: Documentation of new API function.
-
- TIP#112 IMPLEMENTATION
-
- * generic/tclNamesp.c: Core of implementation.
- * generic/tclInt.h (Namespace,TclInvalidateNsCmdLookup): Add command
- list epoch counter and list of ensembles to namespace structure, and
- define a macro to ease update of the epoch counter.
- * generic/tclBasic.c (Tcl_CreateObjCommand,etc.): Update epoch counter
- when list of commands in a namespace changes.
- * generic/tclObj.c (TclInitObjSubsystem): Register ensemble subcommand
- type.
- * tests/namespace.test (42.1-47.6): Tests.
- * doc/namespace.n: Documentation.
-
- * library/http/http.tcl (geturl): Correctly check the type of
- boolean-valued options. [Bug 811170]
-
- * unix/tcl.m4 (SC_ENABLE_FRAMEWORK): Added note to make it clearer
- that this is an OSX feature, not a general Unix feature. [Bug 619440]
-
-2003-09-28 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c: The windows port of expect can call
- TclWinAddProcess before any of the other pipe functions. Added a
- missing PipeInit() call to make sure the initialization happens.
-
-2003-09-25 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: ensure SYMROOT exists if OBJROOT is overridden on
- command line. Replaced explict use of /usr/bin by ${BINDIR}.
-
-2003-09-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * library/package.tcl (tcl::MacPkgUnknown, tcl::MacOSXPkgUnknown):
- Minor performance tweaks to reduce the number of [file] invocations.
- Meant to improve startup times, at least a little bit. (The generic
- equivalent patch was applied on 2003-02-21).
-
-2003-09-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * trace.test: removed 'knownBug' from a test which doesn't illustrate
- a bug, just a bad test.
-
-2003-09-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c:
- * generic/tclInt.h: changed the evaluation-stack addressing mode, from
- array-style to pointer-style; the catch stack and evaluation stack are
- now contiguous in memory. [Patch 457449]
-
-2003-09-23 Don Porter <dgp@users.sourceforge.net>
-
- * tests/trace.test (trace-31,32-*): Added tests for [Bug 807243] and
- [Bug 811483].
-
- * library/init.tcl (auto_load, auto_import): Expanded Eric Melski's
- 2000-01-28 fix for [Bug 218871] to all potentially troubled uses of
- [info commands] on input data, where glob-special characters could
- cause problems.
-
-2003-09-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/expr.test (expr-23.4): Prevented accidental wrapping round of
- exponential operation; it isn't portable, and not what I intended to
- test either. [Bug 808244]
-
-2003-09-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: adding (DE)CACHE_STACK_INFO() pairs to protect
- all calls that may cause traces on ::errorInfo or ::errorCode to
- corrupt the stack. [Bug 804681]
-
-2003-09-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tclPathObj.c: fix to test-suite problem introduced by the bug fix
- below. No problem in ordinary code, just test suite code which
- manually adjusts tclPlatform. [Bug 808247]
-
-2003-09-16 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/filename.n: documentation of Windows-specific feature as
- discussed in [Bug 541989]
- * generic/tclPathObj.c: fix for normalization of volume-relative paths
- [Bug 767834]
- * tests/winFCmd.test: new tests for both of the above.
- * tests/cmdAH.test: fix for AFS problem in test suite [Bug 748960]
-
-2003-09-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- TIP#123 IMPLEMENTATION BASED ON WORK BY ARJEN MARKUS
-
- * generic/tclCompile.h (INST_EXPON): Implementation of
- * generic/tclCompile.c (tclInstructionTable): exponential operator.
- * generic/tclCompExpr.c (operatorTable):
- * generic/tclParseExpr.c (ParseExponentialExpr, GetLexeme):
- * generic/tclExecute.c (TclExecuteByteCode, ExponWide, ExponLong):
- (IllegalExprOperandType):
- * tests/expr.test:
- * tests/compExpr-old.test:
- * doc/expr.n:
-
-2003-09-10 Don Porter <dgp@users.sourceforge.net>
-
- * library/opt/optparse.tcl: Latest revisions caused [OptGuessType]
- to guess "int" instead of "string" for empty strings. Missed the
- required "-strict" option to [string is]. Thanks to Revar Desmera.
- [Bug 803968]
-
-2003-09-08 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinLoad.c (TclpDlopen): Changed the error message for
- ERROR_PROC_NOT_FOUND to be a bit more helpful in giving us clues.
- "can't find specified procedure" means a function in the import table,
- for implicit loading, couldn't be resolved and that's why the load
- failed.
-
-2003-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Tcl_Main.3:
- * doc/FileSystem.3: Implementation of
- * doc/source.n: TIPs 137/151. Adds a
- * doc/tclsh.1: -encoding option to
- * generic/tcl.decls: the [source] command
- * generic/tclCmdMZ.c (Tcl_SourceObjCmd): and a new C routine,
- * generic/tclIOUtil.c (Tcl_FSEvalFileEx): Tcl_FSEvalFileEx(),
- * generic/tclMain.c (Tcl_Main): that provides C access
- * mac/tclMacResource.c (Tcl_MacSourceObjCmd): to the same function.
- * tests/cmdMZ.test: Also adds command line
- * tests/main.test: option handling in Tcl_Main() so that tclsh
- * tests/source.test: and other apps built on Tcl_Main() respect a
- -encoding command line option before a script filename. Docs and tests
- updated as well. [Patch 742683]
- This is a ***POTENTIAL INCOMPATIBILITY*** only for those C programs
- that embed Tcl, build on Tcl_Main(), and make use of Tcl_Main's former
- ability to pass a leading "-encoding" option to interactive shell
- operations.
-
- * generic/tclInt.decls: Added internal stub
- * generic/tclMain.c (Tcl*StartupScript*): table entries for two
- new functions Tcl_SetStartupScript() and Tcl_GetStartupScript() that
- set/get the path and encoding for the startup script to be evaluated
- by either Tcl_Main() or Tk_Main(). Given public names in anticipation
- of their exposure by a followup TIP.
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
-2003-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * doc/SplitList.3: Implementation of TIP 148. Fixes [Bug 489537].
- * generic/tcl.h: Updated Tcl_ConvertCountedElement() to quote
- * generic/tclUtil.c: the leading "#" character of all list elements
- unless the TCL_DONT_QUOTE_HASH flag is passed in.
-
- * generic/tclDictObj.c: Updated Tcl_ConvertCountedElement() callers
- * generic/tclListObj.c: to pass in the TCL_DONT_QUOTE_HASH flags
- * generic/tclResult.c: when appropriate.
-
-2003-08-31 Don Porter <dgp@users.sourceforge.net>
-
- * doc/return.n: Updated [return] docs to cover new TIP 90 features.
-
- * doc/break.n: Added SEE ALSO references to return.n
- * doc/continue.n:
-
-2003-09-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/Namespace.3: Basic documentation for the TIP#139 functions. This
- will need improving, but the basic bits are there at least.
-
-2003-08-31 Don Porter <dgp@users.sourceforge.net>
-
- * doc/catch.n: Updated [catch] docs to cover new TIP 90 features.
-
-2003-08-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c: Corrected bug in TIP 90 implementation where
- * tests/cmdMZ.test: the default -errorcode NONE value was not
- copied into the return options dictionary. This correction modified
- one test result.
-
-2003-08-27 David Gravereaux <davygrvy@pobox.com>
-
- * compat/strftime.c (_fmt): Removed syst array intializer that
- couldn't take variables within it under the watcom compiler:
- 'Initializers must be constant'. I believe Borland has this strictness
- as well. VC++ must be non-standard about this.
-
- Changed Win32 platform #ifdef from 'WIN32' to '__WIN32__' as this is
- the correct one to use across the Tcl sources. Even though we do force
- it in tcl.h, the true parent one is __WIN32__.
-
- Added missing CONST'ification usage to match prototype listed in
- tclInt.decls.
-
- * win/tclWinPort.h: Added a block for OpenWatcom adjustments that
- fixes 1) the same issue Mo did for MinGW lack of missing LPFN_*
- typedefs in their WINE derived <winsock2.h> and 2) The need to be
- strict about how the char type needs to be signed by default.
-
- * win/tclWinSock.c: Added OpenWatcom to the commentary about the
- #ifdef HAVE_NO_LPFN_DECLS block.
-
- * win/tclWinTime.c: Changed use of '_timezone' to 'timezone' as this
- difference is already adjusted for in tclWinPort.h. Removed
- unreferenced posixEpoch file-scope global.
-
- * win/tclWinFile.c (WinReadLinkDirectory): Fix for 'Initializers must
- be constant' with the driveSpec array using OpenWatcom.
-
-2003-08-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: Corrected [Bug 411825] and other bugs in
- TclNeedSpace() where non-breaking space (\u00A0) and backslash-escaped
- spaces were handled incorrectly.
- * tests/util.test: Added new tests util-8.[2-6].
-
-2003-08-26 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tcl.h: Added some support for the LCC-Win32 compiler.
- Unfortunetly, this compiler has a bug in its preprocessor and can't
- build Tcl even with this minor patch. Also added some support for the
- OpenWatcom compiler. A new win/makefile.wc to follow soon.
-
-2003-08-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tools/genStubs.tcl (genStubs::makeDecl): A more subtle way of
- generating stubbed declarations allows us to have declarations of a
- function in multiple interfaces simultaneously.
-
- * generic/tcl.decls: Duplicated some namespace declarations from
- tclInt.decls here, as mandated by TIP #139. This is OK since the
- declarations match and will end up using the declarations in the
- public code from now on because of #include ordering. Keeping the old
- declarations in tclInt.decls; there's no need to gratuitously break
- compatibility for those extensions which are already clients of the
- namespace code.
-
-2003-08-23 Zoran Vasiljevic <zoran@archiwrae.com>
-
- * generic/tclIOUtil.c: merged fixes for thread-unsafe handling of
- filesystem records [Bug 753315]. This also fixed the [Bug 788780]
- * generic/tclPathObj.c: merged fixes for thread-unsafe handling of
- filesystem records. [Bug 753315]
-
- * generic/tclFileSystem.h: merged fixes for thread-unsafe handling of
- filesystem records. [Bug 753315]
-
-2003-08-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinSerial.c (SerialErrorStr): Fixed a syntax error created in
- the previous code cleanup.
-
-2003-08-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * win/tclWinSerial.c: Adjusted commenting and spacing usage to follow
- the principles of the Style Guide better.
-
-2003-08-18 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_ENABLE_SYMBOLS): Use test instead of -eq, which does
- not work. [Bug 781109]
-
-2003-08-13 Chengye Mao <chengye.geo@yahoo.com>
-
- * win/tclWinPipe.c: fixed a bug in BuildCommandLine. This bug built a
- command line with a missing space between tclpipe.dll and the
- following arguments. It caused error in Windows 98 when exec
- command.com (e.g. dir). [Bug 789040]
-
-2003-08-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- TIP #136 IMPLEMENTATION from Simon Geard <simon.geard@ntlworld.com>
- * generic/tclCmdIL.c (Tcl_LrepeatObjCmd): Adapted version of Simon's
- * doc/lrepeat.n: patch, updated to the HEAD
- * tests/lrepeat.test: and matching the core style.
- * generic/tclBasic.c (buildIntCmds): Splice into core.
- * generic/tclInt.h:
- * doc/list.n: Cross-reference.
-
-2003-08-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinInit.c: recognize amd64 and ia32_on_win64 cpus.
-
-2003-08-06 Don Porter <dgp@users.sourceforge.net>
-
- * library/msgcat/msgcat.tcl: Added escape so that non-Windows
- * library/msgcat/pkgIndex.tcl: platforms do not try to use the
- registry package. This can save a costly and pointless package search.
- Bumped to 1.3.1. Thanks to Dave Bodenstab. [Bug 781609]
-
-2003-08-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_INVOKE, INST_EVAL, INST_PUSH_RESULT):
- added a Tcl_ResetResult(interp) at each point where the interp's
- result is pushed onto the stack, to avoid keeping an extra reference
- that may cause costly Tcl_Obj duplication. Detected by Franco Violi,
- analyzed by Peter Spjuth and Donal Fellows. [Bug 781585]
-
-2003-07-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * doc/Translate.3: better documentation of Tcl_TranslateFileName and
- related functions. [Bug 775220]
-
-2003-07-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tcl.h: Revert change made on 2003-07-21 since it made the
- sizeof(Tcl_Obj) different for regular vs mem debug builds.
- * generic/tclInt.h: Define TclDecrRefCount in terms of
- Tcl_DbDecrRefCount which removes one layer of inderection.
- * generic/tclObj.c (TclDbInitNewObj, Tcl_DbIncrRefCount,
- (Tcl_DbDecrRefCount, Tcl_DbIsShared): Define ThreadSpecificData that
- contains a hashtable. The table is used to ensure that a Tcl_Obj is
- only acted upon in the thread that allocated it. This checking code is
- enabled only when mem debug and threads are enabled.
-
-2003-07-24 Don Porter <dgp@users.sourceforge.net>
-
- * tests/async.test: Added several tests that demonstrate [Bug
- * tests/basic.test: 489537], Tcl's longstanding failure to
- * tests/dict.test: properly quote any leading '#' character when
- * tests/dstring.test: generating the string rep of a list so that
- * tests/list.test: the comment-power of that character is hidden
- * tests/parse.test: from any [eval], in order to satisfy the
- * tests/util.test: documentation that [list] does [eval]-safe
- quoting.
-
-2003-07-24 Reinhard Max <max@suse.de>
-
- * library/package.tcl: Fixed a typo that broke pkg_mkIndex -verbose.
- * tests/pkgMkIndex.test: Added a test for [pkg_mkIndex -verbose].
-
- * ChangeLog.2002 (new file):
- * ChangeLog: broke changes from 2002 into ChangeLog.2002 to reduce
- size of the main ChangeLog.
-
-2003-07-23 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: changes to html-tcl & html-tk targets for
- compatibility with non-gnu makes.
-
- * unix/Makefile.in: added macosx/README to dist target.
-
-2003-07-23 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinReg.c (OpenSubKey): Fixed bug 775976 which causes the
- registry set command to fail when built with VC7.
- * library/reg/pkgIndex.tcl: Incremented the version to 1.1.2.
-
-2003-07-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- Check that the thread incrementing or decrementing the ref count of a
- Tcl_Obj is the thread that originally allocated the thread. This fail
- fast behavior will catch programming errors that allow a single
- Tcl_Obj to be accessed from multiple threads.
-
- * generic/tcl.h (Tcl_Obj): Add allocThread member to Tcl_Obj. This
- member records the thread id the Tcl_Obj was allocated. It is used to
- check that any future ref count incr or decr is done from the same
- thread that allocated the Tcl_Obj. This member is defined only when
- threads and mem debug are enabled.
- * generic/tclInt.h (TclNewObj, TclDbNewObj, TclDecrRefCount):
- Define TclNewObj and TclDbNewObj using TclDbInitNewObj when mem debug
- is enabled. This fixes a problem where TclNewObj calls did not work
- the same as TclDbNewObj when mem debug was enabled.
- * generic/tclObj.c (TclDbInitNewObj, Tcl_DbIncrRefCount,
- (Tcl_DbDecrRefCount): Add new helper to init Tcl_Obj members when mem
- debug is enabled. Init the allocThread member in TclDbInitNewObj and
- check it in Tcl_DbIncrRefCount and Tcl_DbDecrRefCount to make sure a
- Tcl_Obj allocated in one thread is not being acted upon in another
- thread.
-
-2003-07-21 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * test/cmdAH.test: ensure certain tests run in local filesystem. [Bug
- 748960]
-
-2003-07-18 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: added option to allow installing manpages in
- addition to default html help.
-
-2003-07-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/Utf.3: Tightened up documentation of Tcl_UtfNext and Tcl_UtfPrev
- to better match the behaviour. [Bug 769895]
-
-2003-07-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/pkgIndex.tcl: upped to http v2.4.4
- * library/http/http.tcl: add support for user:pass info in URL.
- * tests/http.test: [Bug 759888] (shiobara)
-
-2003-07-18 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Restored the [Eval] proc to replace
- * library/tcltest/tcltest.tcl: the [::puts] command when either the
- -output or -error option for [test] is in use, in order to capture
- data written to the output or error channels for comparison against
- what is expected. This is easier to document and agrees better with
- most user expectations than the previous attempt to replace [puts]
- only in the caller's namespace. Documentation made more precise on
- the subject. [Bug 706359]
-
- * doc/AddErrInfo.3: Improved consistency of documentation by
- * doc/CrtTrace.3: using "null" everywhere to refer to the
- * doc/Encoding.3: character '\0', and using "NULL" everywhere
- * doc/Eval.3: to refer to the value of a pointer that points
- * doc/GetIndex.3: to nowhere. Also dropped references to ASCII
- * doc/Hash.3: that are no longer true, and standardized on
- * doc/LinkVar.3: the hyphenated spelling of "null-terminated".
- * doc/Macintosh.3:
- * doc/OpenFileChnl.3:
- * doc/SetVar.3:
- * doc/StringObj.3:
- * doc/Utf.3:
-
- * doc/CrtSlave.3 (Tcl_MakeSafe): Removed warning about possible
- deprecation (no TIP on that).
-
-2003-07-17 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixFCmd.c: fix for compilation errors on platforms where
- configure detects non-functional chflags(). [Bug 748946]
-
- * macosx/Makefile: Rewrote buildsystem for Mac OS X framework build
- to be purely make driven; in order to become independent of Apple's
- closed-source IDE and build tool. The changes are intended to be
- transparent to the Makefile user, all existing make targets and cmd
- line variable overrides should continue to work. Changed build to only
- include tcl specific html help in Tcl.framework, the tk specific html
- help is now included in Tk.framework. Added var to allow overriding of
- tclsh used during html help building (Landon Fuller).
-
- * macosx/Tcl.pbproj/project.pbxproj:
- * macosx/Tcl.pbproj/jingham.pbxuser: Changed to purely call through to
- the make driven buildsystem; Tcl.framework is no longer assembled by
- ProjectBuilder.
- Set default SYMROOT in target options to simplify setting up PB
- (manually setting common build folder for tcl & tk no longer needed).
-
- * tools/tcltk-man2html.tcl: Added options to allow building only the
- tcl or tk html help files; the default behaviour with none of the new
- options is to build both, as before.
-
- * unix/Makefile.in: Added targets for building only the tcl or tk help
-
- * macosx/README (new): Tcl specific excerpts of tk/macosx/README.
-
- * generic/tcl.h: Updated reminder comment about editing
- macosx/Tcl.pbproj/project.pbxproj when version number changes.
-
-2003-07-16 Mumit Khan <khan@nanotech.wisc.edu>
-
- * generic/tclPathObj.c (SetFsPathFromAny): Add Cygwin specific code to
- convert POSIX filename to native format.
- * generic/tclFileName.c (Tcl_TranslateFileName): And remove from here.
- (TclDoGlob): Adjust for cygwin and append / for dirs instead of \
- * win/tclWinFile.c (TclpObjChdir): Use chdir on Cygwin.
- [Patch 679315]
-
-2003-07-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/safe.tcl (FileInAccessPath): normalize paths before
- comparison. [Bug 759607] (myers)
-
- * unix/tclUnixNotfy.c (NotifierThreadProc): correct size of found and
- word vars from int to long. [Bug 767578] (hgo)
-
- * generic/tcl.h: Add recognition of -DTCL_UTF_MAX=6 on the make
- * generic/regcustom.h: line to support UCS-4 mode. No config arg at
- this time, as it is not the recommended build mode.
-
- * generic/tclPreserve.c: In Result and Preserve'd routines, do not
- * generic/tclUtil.c: assume that ckfree == free, as that is not
- * generic/tclResult.c: always true. [Bug 756791] (fuller)
-
-2003-07-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/CrtSlave.3 (Tcl_MakeSafe): Updated documentation to strongly
- discourage use. IMHO code outside the core that uses this function is
- a bug... [Bug 655300]
-
-2003-07-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c (Tcl_GlobObjCmd): [Bug 771840]
- * generic/tclPathObj.c (Tcl_FSConvertToPathType):[Bug 771947]
- * unix/tclUnixFCmd.c (GetModeFromPermString): [Bug 771949]
- Silence compiler warnings about unreached lines.
-
- * library/tcltest/tcltest.tcl (ProcessFlags): Corrected broken call
- * library/tcltest/pkgIndex.tcl: to [lrange]. Bumped to
- version 2.2.4. [Bug 772333]
-
-2003-07-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/dltest/pkga.c (Pkga_EqObjCmd): Fix typo that was causing a
- crash in load.test.
-
-2003-07-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/array.n: Make sure docs are synched with the 8.4 release.
-
-2003-07-15 Don Porter <dgp@users.sourceforge.net>
-
- * doc/http.n: Updated SYNOPSIS to match actual syntax of commands.
- [Bug 756112]
-
- * unix/dltest/pkga.c: Updated to not use Tcl_UtfNcmp and counted
- strings instead of strcmp (not defined in any #include'd header) and
- presumed NULL-terminated strings.
-
- * generic/tclCompCmds.c (TclCompileIfCmd): Prior fix of Bug 711371 on
- 2003-04-07 introduced a buffer overflow. Corrected. [Bug 771613]
-
-2003-07-15 Kevin B. Kenny <kennykb@acm.org>
-
- * win/rules.vc: Added a missing $(OPTDEFINES) which broke the build if
- STATS=memdbg was specified.
-
-2003-07-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdIL.c (SortCompare): Cleared up confusing error
- message. [Bug 771539]
-
-2003-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/binary.test (binary-46.*): Tests to help enforce the current
- behaviour.
- * doc/binary.n: Documented that [binary format a] and [binary scan a]
- do encoding conversion by dropping high bytes, unlike the rest of the
- core. [Bug 735364]
-
-2003-07-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl: Corrected [pkg_mkIndex] bug reported on
- comp.lang.tcl. The indexer was searching for newly indexed packages
- instead of newly provided packages.
-
-2003-07-08 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/winFCmd.test: fix for five tests under win98 [Bug 767679]
-
-2003-07-07 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/array.n: add examples from Welton
-
-2003-06-23 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n: clarification of 'file tail' behaviour [Bug 737977]
-
-2003-07-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/expr.n: Tighten up the wording of some operations. [Bug 758488]
-
- * tests/cmdAH.test: Made tests of [file mtime] work better on FAT
- filesystems. [Patch 760768] Also a little general cleanup.
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Made [string map] accept
- dictionaries for maps. This is much trickier than it looks, since map
- entry ordering is significant. [Bug 759936]
-
- * generic/tclVar.c (Tcl_ArrayObjCmd, TclArraySet): Made [array get]
- and [array set] work with dictionaries, producing them and consuming
- them. Note that for compatibility reasons, you will never get a dict
- from feeding a string literal to [array set] since that alters the
- trace behaviour of "multi-key" sets. [Bug 759935]
-
-2003-06-23 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclTrace.c: fix to Window debug build compilation error.
-
-2003-06-27 Don Porter <dgp@users.sourceforge.net>
-
- * tests/init.test: Added [cleanupTests] to report results of tests
- * tests/pkg.test: that run in slave interps. [Bugs 761334,761344]
-
- * tests/http.test: Used more reliable path to find httpd script.
-
-2003-06-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/init.test: Added tests init-4.6.* to illustrate [Bug 760872]
-
-2003-06-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclTrace.c: New file, factoring out of virtually all the
- various trace-related things from tclBasic.c and tclCmdMZ.c with the
- goal of making this a separate maintenance area.
-
-2003-06-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add -ieee when compiling with cc and
- add -mieee when compiling with gcc under OSF1-V5 "Tru64" systems. [Bug
- 748957]
-
-2003-06-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/encoding.n: Corrected the docs to say that [source] uses the
- system encoding, which it always did anyway (since 8.1) [Bug 742100]
-
-2003-06-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclHash.c (Tcl_HashStats): Prevented occurrence of
- division-by-zero problems. [Bug 759749]
-
-2003-06-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/tclUnixPort.h: #undef inet_ntoa before #define to avoid
- compiler warning under freebsd. [Bug 745844]
-
-2003-06-23 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * doc/dde.n: Committed TIP #135 which changes the
- * win/tclWinDde.c: -exact option to -force. Also cleaned a
- * tests/winDde.test: bug in the tests.
- * library/dde/pkgIndex.tcl: Incremented version to 1.2.5
-
- * doc/dde.n: Committed TIP #120 which provides the
- * win/tclWinDde.c: dde package for safe interpreters.
- * tests/winDde.test: Incremented package version to 1.2.4
- * library/dde/pkgIndex.tcl:
-
-2003-06-23 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFCmd.c: fix to bad error message when trying to do 'file
- copy foo ""'. [Bug 756951]
- * tests/fCmd.test: added two new tests for the bug.
-
- * win/tclWinFile.c:
- * win/tclWin32Dll.c: recommitted some filesystem globbing speed-ups,
- but disabled some on the older Win 95/98/ME where they don't seem to
- work.
-
- * doc/FileSystem.3: documentation fix [Bug 720634]
-
-2003-06-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_Export): removed erroneous comments. [Bug
- 756744]
-
-2003-06-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/makefile.vc: fixes to check-in below so compilation now works
- again on Windows.
-
- * generic/tclCmdMZ.c:
- * tests/regexp.test: fixing of bugs related to regexp and regsub
- matching of empty strings. Addition of a number of new tests. [Bug
- 755335]
-
-2003-06-16 Andreas Kupries <andreask@activestate.com>
-
- * win/Makefile.in: Haven't heard back from David for a week. Now
- * win/configure: committing the remaining changes.
- * win/configure.in: Note: In active contact with Helmut Giese about
- * win/makefile.vc: the borland relatedchanges. This part will see
- * win/rules.vc: future updates.
- * win/tcl.m4:
- * win/makefile.bc:
-
-2003-06-10 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclConfig.c (ASSOC_KEY): Changed the key to
- "tclPackageAboutDict" (tcl prefix) to make collisions with the keys of
- other packages more unlikely.
-
-2003-06-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclExecute.c: let TclExecuteObjvInternal call
- TclInterpReady instead of relying on its callers to do so; fix for the
- part of [Bug 495830] that is new in 8.4.
- * tests/interp.test: Added tests 18.9 (knownbug) and 18.10
-
-2003-06-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tcl.decls: Ported the changes from the
- * generic/tcl.h: 'tip-59-implementation' branch into the CVS
- * generic/tclBasic.c: head. Regenerated stub table. Regenerated the
- * generic/tclInt.h: configure's scripts, with help from Joe English.
- * generic/tclDecls.h:
- * generic/tclStubInit.c:
- * generic/tclConfig.c:
- * generic/tclPkgConfig.c:
- * unix/Makefile.in:
- * unix/configure.in: The changes in the windows section are not yet
- * unix/tcl.m4: committed, they await feedback from David
- * unix/mkLinks: Gravereaux.
- * doc/RegConfig.3:
- * mac/tclMacPkgConfig.c:
- * tests/config.test:
-
-2003-06-09 Don Porter <dgp@users.sourceforge.net>
-
- * string.test (string-4.15): Added test for [string first] bug
- reported in Tcl 8.3, where test for all-single-byte-encoded strings
- was not reliable.
-
-2003-06-04 Joe Mistachkin <joe@mistachkin.com>
-
- * tools/man2help.tcl: Added duplicate help section checking and
- * tools/index.tcl: corrected a comment typo for the getTopics proc
- in index.tcl. [Bug 748700]
-
-2003-06-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFCmd.c:
- * tests/fCmd.test: fix to [Bug #747575] in which a bad error message
- is given when trying to rename a busy directory to one with the same
- prefix, but not the same name. Added three new tests.
-
-2003-05-23 D. Richard Hipp <drh@hwaci.com>
-
- * win/tclWinTime.c: Add tests to detect and avoid a division by zero
- in the windows precision timer calibration logic.
-
-2003-05-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclObj.c (tclCmdNameType): Converted internal rep
- management of the cmdName Tcl_ObjType the opposite way, to always use
- the twoPtrValue instead of always using the otherValuePtr. Previous
- fix on 2003-05-12 broke several extensions that wanted to poke around
- with the twoPtrValue.ptr2 value of a cmdName Tcl_Obj, like TclBlend
- and e4graph. [Bug 726018]
- Thanks to George Petasis for the bug report and Jacob Levy for testing
- assistance.
-
-2003-05-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/mkLinks: Set the var S to "" at the top of the file to avoid
- error when user has set S to something. [Tk Bug 739833]
-
-2003-05-22 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: added missing references to new
- source files tclPathObj.c and tclMacOSXFCmd.c.
-
- * macosx/tclMacOSXBundle.c: fixed a problem that caused only the first
- call to Tcl_MacOSXOpenVersionedBundleResources() for a given bundle
- identifier to succeed. This caused the tcl runtime library not to be
- found in all interps created after the inital one.
-
-2003-05-19 Kevin B. Kenny <kennykb@hippolyta>
-
- * unix/tclUnixTime.c: Corrected a bug in conversion of non-ASCII
- chars in the format string.
-
-2003-05-19 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: changed tclConfig.sh location in
- versioned framework subdirectories to be identical to location in
- framework toplevel; fixed stub library symbolic links to be tcl
- version specific.
-
- * unix/tclUnixTime.c: fixed typo.
-
-2003-05-18 Kevin Kenny <kennykb@acm.org>
-
- * compat/strftime.c: Modified TclpStrftime to return its result in
- * generic/tclClock.c: UTF-8 encoding, and removed the conversion from
- * mac/tclMacTime.c: system encoding to UTF-8 from [clock format].
- * unix/tclUnixTime.c: Needed to avoid double conversion of the
- * win/tclWinTime.c: timezone name on Windows systems. [Bug 624408]
-
-2003-05-16 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/dde/pkgIndex.tcl: Applied TIP #130 which provides for
- * tests/winDde.test: unique dde server names. Added some more
- * win/tclWinDde.c: tests. Fixes [Bug 219293]
-
- * doc/dde.n: Updated documentation re TIP #130.
- * tests/winDde.test: Applied patch for [Bug 738929] by KKB and changed
- to new-style tests.
-
-2003-05-16 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/Makefile.in: Removed one excess source file tclDToA.c
-
-2003-05-16 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.pbproj/project.pbxproj: updated copyright year.
-
-2003-05-15 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclGetDate.y: added further hackery to the yacc
- * generic/tclDate.c: post-processing to arrange for the code to set
- * unix/Makefile.in: up exit handlers to free the stacks. [Bug
- 736425]
-
-2003-05-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFile.c (TclpMatchInDirectory): revert glob code to r1.44
- as 2003-04-11 optimizations broke Windows98 glob'ing.
-
- * doc/socket.n: nroff font handling correction
-
- * library/encoding/gb2312-raw.enc (new): This is the original
- gb2312.enc renamed to allow for it to still be used. This is needed by
- Tk (unix) because X fonts with gb2312* charsets really do want the
- original gb2312 encoding. [Bug 557030]
-
-2003-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): Stop unwarranted demotion of
- wide values to longs by formatting of int values. [Bug 699060]
-
-2003-05-14 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/encoding/gb2312.enc: copy euc-cn.enc over original
- gb2312.enc. gb2312.enc appeared to not work as expected, and most uses
- of gb2312 really mean euc-cn (which may be the cause of the problem).
- [Bug 557030]
-
-2003-05-14 Daniel Steffen <das@users.sourceforge.net>
-
- Implementation of TIP 118:
-
- * generic/tclFCmd.c (TclFileAttrsCmd): return the list of attributes
- that can be retrieved without error for a given file, instead of
- aborting the whole command when any error occurs.
-
- * unix/tclUnixFCmd.c: added support for new file attributes and for
- copying Mac OS X file attributes & resource fork during [file copy].
-
- * generic/tclInt.decls: added declarations of new external commands
- needed by new file attributes support in tclUnixFCmd.c.
-
- * macosx/tclMacOSXFCmd.c (new): Mac OS X specific implementation of
- new file attributes and of attribute & resource fork copying.
-
- * mac/tclMacFCmd.c: added implementation of -rsrclength attribute &
- fixes to other attributes for consistency with OSX implementation.
-
- * mac/tclMacResource.c: fixes to OSType handling.
-
- * doc/file.n: documentation of [file attributes] changes.
-
- * unix/configure.in: check for APIs needed by new file attributes.
-
- * unix/Makefile.in:
- * unix/tcl.m4: added new platform specifc tclMacOSXFCmd.c source.
-
- * unix/configure:
- * generic/tclStubInit.c:
- * generic/tclIntPlatDecls.h: regen.
-
- * tools/genStubs.tcl: fixes to completely broken code trying to
- prevent overlap of "aqua", "macosx", "x11" and "unix" stub entries.
-
- * tests/unixFCmd.test: added tests of -readonly attribute.
-
- * tests/macOSXFCmd.test (new): tests of macosx file attributes and of
- preservation of attributes & resource fork during [file copy].
-
- * tests/macFCmd.test: restore -readonly attribute of test dir, as
- otherwise its removal can fail on unices supporting -readonly.
-
-2003-05-13 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclEnv.c: Another putenv() copy behavior problem repaired
- when compiling on windows and using microsoft's runtime. [Bug 736421]
-
-2003-05-13 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIOUtil.c: ensure cd is thread-safe.
- [Bug 710642] (vasiljevic)
-
-2003-05-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclEvent.c (Tcl_Finalize): Removed unused variable to reduce
- compiler warnings. [Bug 664745]
-
-2003-05-13 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tcl.decls: Changed Tcl_JoinThread parameter name from
- * generic/tclDecls.h: "id" to "threadId". [Bug 732477]
- * unix/tclUnixThrd.c:
- * win/tclWinThrd.c:
- * mac/tclMacThrd.c:
-
-2003-05-13 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.decls:
- * macosx/tclMacOSXBundle.c: added extended version of the
- Tcl_MacOSXOpenBundleResources() API taking an extra version number
- argument: Tcl_MacOSXOpenVersionedBundleResources(). This is needed to
- be able to access bundle resources in versioned frameworks such as Tcl
- and Tk, otherwise if multiple versions were installed, only the latest
- version's resources could be accessed. [Bug 736774]
-
- * unix/tclUnixInit.c (Tcl_MacOSXGetLibraryPath): use new versioned
- bundle resource API to get tcl runtime library for TCL_VERSION. [Bug
- 736774]
-
- * generic/tclPlatDecls.h:
- * generic/tclStubInit.c: regen.
-
- * unix/tclUnixPort.h: worked around the issue of realpath() not
- being thread-safe on Mac OS X by defining NO_REALPATH for threaded
- builds on Mac OS X. [Bug 711232]
-
-2003-05-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/cmdAH.test: General clean-up of tests so that all
- tcltest-specific commands are protected by constraints and all
- platforms see the same number of tests. [Bug 736431]
-
-2003-05-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c: (AliasObjCmd): Added refCounting of the words
- * tests/interp.test (interp-33.1): of the target of an interp
- alias during its execution. Also added test. [Bug 730244]
-
- * generic/tclBasic.c (TclInvokeObjectCommand): objv[argc] is no
- longer set to NULL (Tcl_CreateObjCommand docs already say that it
- should not be accessed).
-
- * tests/cmdMZ.test: Forgot to import [temporaryDirectory].
-
- * generic/tclObj.c (tclCmdNameType): Corrected variable use of the
- otherValuePtr or the twoPtrValue.ptr1 fields to store a
- (ResolvedCmdName *) as the internal rep. [Bug 726018]
-
- * doc/Eval.3: Corrected prototype for Tcl_GlobalEvalObj [Bug 727622].
-
-2003-05-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclObjLookupVar): [Bug 735335] temporary fix,
- disabling usage of tclNsVarNameType.
- * tests/var.test (var-15.1): test for [Bug 735335]
-
-2003-05-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinSerial.c (SerialCloseProc): correct mem leak on closing a
- Windows serial port [Bug 718002] (schroedter)
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): prevent string repeat crash
- when overflow sizes were given (throws error). [Bug 714106]
-
-2003-05-09 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclThreadAlloc.c (TclFreeAllocCache): Fixed memory leak
- caused by treating cachePtr as a TLS index. [Bug 731754]
-
- * win/tclAppInit.c (Tcl_AppInit): Fixed memory leaks caused by not
- freeing the memory allocated by setargv and the async handler created
- by Tcl_AppInit. An exit handler has been created that takes care of
- both leaks. In addition, Tcl_AppInit now uses ckalloc instead of
- Tcl_Alloc to allow for easier leak tracking and to be more consistent
- with the rest of the Tcl core. [Bugs 733156, 733221]
-
- * tools/encoding/txt2enc.c (main): Fixed memory leak caused by failing
- to free the memory used by the toUnicode array of strings [Bug 733221]
-
-2003-05-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript):
- * tests/compile.test (compile-3.5): corrected wrong test and
- behaviour in the earlier fix for [Bug 705406]; Don Porter reported
- this as [Bug 735055], and provided the solution.
-
-2003-05-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_ReturnObjCmd): The array of strings passed
- to Tcl_GetIndexFromObj must be NULL terminated. [Bug 735186]
- Thanks to Joe Mistachkin for spotting this.
-
-2003-05-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/trace.n: Fixed very strange language in the documentation for
- 'trace add execution'. [Bug 729821]
-
- * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Made error message for 'trace
- info' more consistent with documentation. [Bug 706961]
-
- * generic/tclDictObj.c (DictInfoCmd): Fixed memory leak caused by
- confusion about string ownership. [Bug 731706]
-
-2003-05-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Implementation of TIP 90, which
- * generic/tclCmdAH.c: extends the [catch] and [return]
- * generic/tclCompCmds.c: commands to enable creation of a
- * generic/tclExecute.c: proc that is a replacement for
- * generic/tclInt.h: [return]. [Patch 531640]
- * generic/tclProc.c:
- * generic/tclResult.c:
- * tests/cmdAH.test:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/proc-old.test:
-
- * library/tcltest/tcltest.tcl: The -returnCodes option to [test]
- failed to recognize the symbolic name "ok" for return code 0.
-
-2003-05-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclBasic.c (Tcl_HideCommand): Fixed error message for
- grammar and spelling.
-
-2003-04-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclDictObj.c (DictIncrCmd): Updated to reflect the behaviour
- with wide increments of the normal [incr] command.
- * generic/tclInt.decls: Added TclIncrWideVar2 to internal stub table
- and cleaned up.
- * tests/incr.test (incr-3.*):
- * generic/tclVar.c (TclIncrWideVar2, TclPtrIncrWideVar):
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclCmdIL.c (Tcl_IncrObjCmd): Make [incr] work when trying to
- increment by wide values. [Bug 728838]
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Default mode of
- operation of [switch] is exact matching. [Bug 727563]
-
-2003-04-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Tcl_EvalObjv() failed to honor the
- TCL_EVAL_GLOBAL flag when resolving command names. Tcl_EvalEx passed a
- string rep including leading whitespace and comments to
- TclEvalObjvInternal().
-
-2003-04-25 Andreas Kupries <andreask@activestate.com>
-
- * win/tclWinThrd.c: Applied SF patch #727271. This patch changes the
- code to catch any errors returned by the windows functions handling
- TLS ASAP instead of waiting to get some mysterious crash later on due
- to bogus pointers. Patch provided by Joe Mistachkin.
-
- This is a stop-gap measure to deal with the low number of ?TLS slots
- provided by some of the variants of Windows (60-80).
-
-2003-04-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: fix to bug reported privately by Jeff where,
- for example, 'glob -path {[tcl]} *' gets confused by the leading
- special character (which is escaped internally), and instead lists
- files in '/'. Bug only occurs on Windows where '\' is also a directory
- separator.
- * tests/fileName.test: added test for the above bug.
-
-2003-04-22 Andreas Kupries <andreask@activestate.com>
-
- * The changes below fix SF bugs [593810], and [718045].
-
- * generic/tclIO.c (Tcl_CutChannel, Tcl_SpliceChannel): Invoke
- TclpCutSockChannel and TclpSpliceSockChannel.
-
- * generic/tclInt.h: Declare TclpCutSockChannel and
- TclpSpliceSockChannel.
-
- * unix/tclUnixSock.c (TclpCutSockChannel, TclpSpliceSockChannel):
- Dummy functions, on unix the sockets are _not_ handled specially.
-
- * mac/tclMacSock.c (TclpCutSockChannel, TclpSpliceSockChannel):
- * win/tclWinSock.c (TclpCutSockChannel, TclpSpliceSockChannel): New
- functions to handle socket specific cut/splice operations: auto-init
- of socket system for thread on splice, management of the module
- internal per-thread list of sockets, management of association of
- sockets with HWNDs for event notification.
-
- * win/tclWinSock.c (NewSocketInfo): Extended initialization
- assignments to cover all items of the structure. During debugging of
- the new code mentioned above I found that two fileds could contain
- bogus data.
-
- * win/tclWinFile.c: Added #undef HAVE_NO_FINDEX_ENUMS before
- definition because when compiling in debug mode the compiler complains
- about a redefinition, and this warning is also treated as an error.
-
-2003-04-21 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: When the return code of a test does
- not meet expectations, report that as the reason for test failure, and
- do not attempt to check the test result for correctness. [Bug 725253]
-
-2003-04-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinInt.h (VER_PLATFORM_WIN32_CE): conditionally define.
- * win/tclWinInit.c: recognize Windows CE as a Win platform. This just
- recognizes CE - full support will come later.
-
- * win/configure: regen
- * win/configure.in (SHELL): force it to /bin/sh as autoconf 2.5x
- uses /bin/bash, which can fail to find exes in the path (ie: lib).
-
- * generic/tclExecute.c (ExprCallMathFunc): remove incorrect
- extraneous cast from Tcl_WideAsDouble.
-
-2003-04-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/open.n: Moved serial port options from [fconfigure] to
- * doc/fconfigure.n: [open] as it is up to the creator of a channel
- to describe the channel's special config
- options. [Bug 679010]
-
-2003-04-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Made changes so that the "wideInt" Tcl_ObjType
- * generic/tclObj.c: is defined on all platforms, even those where
- * generic/tclPort.h: TCL_WIDE_INT_IS_LONG is defined. Also made the
- Tcl_Value struct have a wideValue field on all platforms. This is a
- ***POTENTIAL INCOMPATIBILITY*** for TCL_WIDE_INT_IS_LONG platforms
- because that struct changes size. This is the same TIP 72
- incompatibility that was seen on other platforms at the 8.4.0 release,
- when this change should have happened as well. [Bug 713562]
-
- * generic/tclInt.h: New internal macros TclGetWide() and
- TclGetLongFromWide() to deal with both forms of the "wideInt"
- Tcl_ObjType, so that conditional TCL_WIDE_INT_IS_LONG code is confined
- to the header file.
-
- * generic/tclCmdAH.c: Replaced most coding that was conditional
- * generic/tclCmdIL.c: on TCL_WIDE_INT_IS_LONG with code that
- * generic/tclExecute.c: works across platforms, sometimes using
- * generic/tclTest.c: the new macros above to do it.
- * generic/tclUtil.c:
- * generic/tclVar.c:
-
-2003-04-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/socket.n: Added a paragraph to remind people to specify their
- encodings when using sockets. [Bug 630621]
-
-2003-04-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/CrtMathFnc.3: Functions also have to deal with wide ints, but
- this was not documented. [Bug 709720]
-
-2003-04-16 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: removed undesired 'static' for function which
- is now shared (previously it was duplicated).
-
-2003-04-15 Joe English <jenglish@users.sourceforge.net>
-
- * doc/namespace.n: added example section "SCOPED SCRIPTS", supplied by
- Kevin Kenny. [Bug 219183]
-
-2003-04-15 Kevin Kenny <kennykb@acm.org>
-
- * makefile.vc: Updated makefile.vc to conform with Mo DeJong's changes
- to Makefile.in and tclWinPipe.c on 2003-04-14. Now passes TCL_PIPE_DLL
- in place of TCL_DBGX.
- * win/tclWinTime.c: Corrected use of types to make compilation
- compatible with VC++5.
-
-2003-04-15 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: finished check-in from yesterday, removing
- duplicate function definition.
-
-2003-04-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclClock.c: Corrected compiler warnings.
- * generic/tclTest.c:
-
-2003-04-14 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/Makefile.in: Don't define TCL_DBGX symbol for every compile.
- Instead, define TCL_PIPE_DLL only when compiling tclWinPipe.c. This
- will break other build systems, so they will need to remove the
- TCL_DBGX define and replace it with a define for TCL_PIPE_DLL.
- * win/tclWinPipe.c (TclpCreateProcess): Remove PREFIX_IDENT and
- DEBUG_IDENT from top of file. Use TCL_PIPE_DLL passed in from build
- env instead of trying to construct the dll name from already defined
- symbols. This approach is more flexible and better in the long run.
-
-2003-04-14 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWinFile.c: added conditionals to restore compilation on
- VC++6, which was broken by recent changes.
-
-2003-04-14 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c:
- * generic/tclPathObj.c:
- * generic/tclFileSystem.h: overlooked one function which was
- duplicated, so this is now shared between modules.
- * win/tclWinFile.c: allow this file to compile with VC++ 5.2 again
- since Mingw build fixes broke that.
-
-2003-04-13 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Add check for FINDEX_INFO_LEVELS from winbase.h,
- known to be a problem in VC++ 5.2. Define HAVE_NO_FINDEX_ENUMS if the
- define does not exist.
- * win/tclWinFile.c: Put declarations for FINDEX_INFO_LEVELS and
- FINDEX_SEARCH_OPS inside a check for HAVE_NO_FINDEX_ENUMS so that
- these are not declared twice. This fixes the Mingw build.
- * win/tclWinTime.c: Rework the init of timeInfo so that the number or
- initializers matches the declaration. This was broken under Mingw. Add
- cast to avoid compile warning when calling the AccumulateSample
- function.
-
-2003-04-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/Makefile.in (GENERIC_OBJS): add missing tclPathObj.c
-
-2003-04-12 Kevin Kenny <kennykb@acm.org>
-
- * doc/clock.n:
- * generic/tclClock.c (Tcl_ClockObjCmd):
- * tests/clock.test: Implementation of TIP #124. Also renumbered test
- cases to avoid duplicates. [Bug 710310]
- * tests/winTime.test:
- * win/tclWinTest.c (TestwinclockCmd, TestwinsleepCmd):
- * win/tclWinTime.c (Tcl_WinTime, UpdateTimeEachSecond,
- (ResetCounterSamples, AccumulateSample, SAMPLES, TimeInfo): Made
- substantial changes to the phase-locked loop (replaced an IIR filter
- with an FIR one) in a quest for improved loop stability (Bug not
- logged at SF, but cited in private communication from Jeff Hobbs).
-
-2003-04-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd,STR_IS_INT): Corrected
- inconsistent results of [string is integer] observed on systems where
- sizeof(long) != sizeof(int). [Bug 718878]
- * tests/string.test: Added tests for Bug 718878.
- * doc/string.n: Clarified that [string is integer] accepts 32-bit
- integers.
-
-2003-04-11 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (UpdateInterest): When dropping interest in
- TCL_READABLE now dropping interest in TCL_EXCEPTION too. This fixes a
- bug where Expect detects eof on a file prematurely on solaris 2.6 and
- higher. A much more complete explanation is in the code itself (40
- lines of comments for a one-line change :)
-
-2003-04-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/cmdAH.test: fix test suite problem if /home is a symlink. [Bug
- 703264]
- * generic/tclIOUtil.c: fix bad error message with 'cd ""'. [Bug
- 704917]
- * win/tclWinFile.c, win/tclWin32Dll.c:
- * win/tclWinInt.h: allow Tcl to differentiate between reparse points
- which are symlinks and mounted volumes, and correctly handle the
- latter. This involves some elaborate code to find the actual drive
- letter (if possible) corresponding to a mounted volume. [Bug 697862]
- * tests/fileSystem.test: add constraints to stop tests running in
- ordinary tcl interpreter. [Bug 705675]
-
- * generic/tclIOUtil.c:
- * generic/tclPathObj.c: (new file)
- * generic/tclFileSystem.h: (new file)
- * win/makefile.vc:
- Split path object handling out of the virtual filesystem layer, into
- tclPathObj.c. This refactoring cleans up the internal filesystem code,
- and will make any future optimisations and forthcoming better
- thread-safety much easier.
-
- * generic/tclTest.c:
- * tests/reg.test: added some 'knownBug' tests for problems in Tcl's
- regexp code with the TCL_REG_CAN_MATCH flag (see Bug 703709). Code too
- impenetrable to fix right now, but a fix is needed for tip113 to work
- correctly.
-
- * tests/fCmd.test
- * win/tclWinFile.c: added some filesystem optimisation to the 'glob'
- implementation, and some new tests.
-
- * generic/tclCmdMZ.c: fix typo in comment
-
- * tests/winFile.test:
- * tests/ioUtil.test:
- * tests/unixFCmd.test: renumbered tests with duplicate numbers. [Bug
- 710361]
-
-2003-04-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/binary.n: Fixed typo in [binary format w] desc. [Bug 718543]
-
-2003-04-08 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_ErrorObjCmd): Strings are only empty if
- they have zero length, not if their first byte is zero, so fix test
- guarding Tcl_AddObjErrorInfo to take this into account. [Bug
- reported by Don Porter; no bug-id.]
-
-2003-04-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileIfCmd): Corrected string limits of
- arguments interpolated in error messages. [Bug 711371]
-
- * generic/tclCmdMZ.c (TraceExecutionProc): Added missing
- Tcl_DiscardResult() call to avoid memory leak.
-
-2003-04-07 Donal K. Fellows <zzcgudf@ernie.mvc.mcc.ac.uk>
-
- * generic/tclDictObj.c (Tcl_DictObjCmd): Stopped compilers from
- moaning about switch fall-through. [Bug 716327]
- (DictFilterCmd): Yet more warning killing, this time reported by
- Miguel Sofer by private chat.
-
-2003-04-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/dict.test (dict-2.6):
- * generic/tclDictObj.c (Tcl_NewDictObj, Tcl_DbNewDictObj): Oops!
- Failed to fully initialise the Dict structure.
- (DictIncrCmd): Moved valueAlreadyInDictionary label to stop compiler
- complaints. [Bug 715751]
-
- * generic/tclDictObj.c (DictIncrCmd): Followed style in the rest of
- the core by commenting out wide-specific operations on platforms where
- wides are longs, and used longs more thoroughly than ints through
- [dict incr] anyway to forestall further bugs.
- * generic/tclObj.c: Made sure there's always a tclWideIntType
- implementation available, not that it is always useful. [Bug 713562]
-
-2003-04-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclDictObj.c: Removed commented out notes on declarations to
- be moved to elsewhere in the Tcl core.
-
- * generic/tclInt.h: Final stages of plumbing in.
- * generic/tclBasic.c:
- * generic/tclObj.c (TclInitObjSubsystem):
-
- * unix/Makefile.in, win/Makefile.in, win/makefile.[bv]c: Build support.
- * generic/tcl.decls: Added dict public API to stubs table.
- * generic/tcl.h (Tcl_DictSearch): Added declaration of structure to
- allow user code to iterate over dictionaries.
-
- * doc/DictObj.3: New files containing dictionary implementation
- * doc/dict.n: documentation and tests as as mandated by TIP
- * generic/tclDictObj.c: #111.
- * tests/dict.test:
-
-2003-04-03 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure:
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Don't set TCL_LIBS if it is already
- set to support use of TCL_LIBS var from tclConfig.sh in the Tk
- configure script.
-
-2003-04-03 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/Makefile.in: Don't subst MATH_LIBS, LIBS, and DL_LIBS
- separately. Instead, just subst TCL_LIBS since it includes the
- others.
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS, SC_TCL_LINK_LIBS): Set and subst
- TCL_LIBS in SC_CONFIG_CFLAGS instead of SC_TCL_LINK_LIBS. Don't subst
- MATH_LIBS since it is now covered by TCL_LIBS.
- * unix/tclConfig.sh.in: Use TCL_LIBS instead of DL_LIBS, LIBS, and
- MATH_LIBS.
- * unix/dltest/Makefile.in: Ditto.
-
-2003-04-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): Now that [return]
- compiles to INST_RETURN, it is safe to compile even outside a proc.
-
-2003-04-02 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Set stub lib flag based on new LIBFLAGSUFFIX
- variable.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set new LIBFLAGSUFFIX that works like
- LIBSUFFIX, it is used when creating library names. The previous
- implementation would generate -ltclstub85 instead of -ltclstub85s when
- configured with --disable-shared.
-
-2003-04-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c (TclSubstTokens): Moved declaration of
- utfCharBytes to beginning of procedure so that it does not go out of
- scope (get free()d) while append is still pointing to it. [Bugs
- 703167, 713754]
-
-2003-04-01 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Check for inet_ntoa in -lbind inside
- the BeOS block since doing it later broke the build under SuSE 7.3.
- [Bug 713128]
-
-2003-04-01 Don Porter <dgp@users.sourceforge.net>
-
- * tests/README: Direct [source] of *.test files is no longer
- recommended. The tests/*.test files should only be evaluated under the
- control of the [runAllTests] command in tests/all.tcl.
-
- * generic/tclExecute.c (INST_RETURN): Bytecompiled [return] failed to
- reset iPtr->returnCode, causing tests parse-18.17 and parse-18.21 to
- fail strangely.
- * tests/parse.test (parse-18.21): Corrected now functioning test.
- Added further coverage tests.
-
-2003-03-31 Don Porter <dgp@users.sourceforge.net>
-
- * tests/parse.test (parse-18.*): Coverage tests for the new
- implementation of Tcl_SubstObj(). Note that tests parse-18.17 and
- parse-18.21 demonstrate some bugs left to fix in the current code.
-
-2003-03-27 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Use -Wl,--export-dynamic instead of
- -rdynamic for LDFLAGS. The -rdynamic is not documented so it seems
- better to pass the --export-dynamic flag to the linker. [Patch 573395]
-
-2003-03-27 Miguel Sofer <msofer@users.sf.net>
-
- * tests/encoding.test:
- * tests/proc-old.test:
- * tests/set-old.test: Altered test numers to eliminate duplicates,
- [Bugs 710313, 710320, 710352]
-
-2003-03-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/parseOld.test: Altered test numers to eliminate duplicates.
- * tests/parse.test: [Bugs 710365, 710369]
- * tests/expr-old.test:
- * tests/expr.test:
-
- * tests/utf.test: Altered test numers to eliminate duplicates.
- * tests/trace.test: [Bugs 710322, 710327, 710349, 710363]
- * tests/lsearch.test:
- * tests/list.test:
- * tests/info.test:
- * tests/incr-old.test:
- * tests/if-old.test:
- * tests/format.test:
- * tests/foreach.test:
-
-2003-03-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS, SC_TCL_LINK_LIBS): Add BeOS system to
- SC_CONFIG_CFLAGS. Check for inet_ntoa in -lbind, needed for BeOS.
-
-2003-03-26 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n:
- * library/tcltest/tcltest.tcl: Added reporting during [configure
- -debug 1] operations to warn about multiple uses of the same test
- name. [FRQ 576693]
-
- * tests/msgcat.test (msgcat-2.2.1): changed test name to avoid
- duplication. [Bug 710356]
-
- * unix/dltest/pkg?.c: Changed all Tcl_InitStubs calls to pass
- argument exact = 0, so that rebuilds are not required when Tcl
- bumps to a new version. [Bug 701926]
-
-2003-03-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c:
- * tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the
- created local variable. [Bug 631741] (Chris Darroch) and [Bug 696893]
- (David Hilker)
-
-2003-03-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/dde/pkgIndex.tcl: bumped version to 1.2.2 in tclWinDde.c,
- now adding here too.
-
-2003-03-22 Kevin Kenny <kennykb@acm.org>
-
- * library/dde/pkgIndex.tcl:
- * library/reg/pkgIndex.tcl: Fixed a bug where [package require dde]
- or [package require registry] attempted to load the release version
- of the DLL into a debug build. [Bug 708218] Thanks to Joe Mistachkin
- for the patch.
- * win/makefile.vc: Added quoting around the script name in the 'test'
- target; Joe Mistachkin insists that he has a configuration that fails
- to launch tcltest without it, and it appears harmless otherwise.
-
-2003-03-22 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinDde.c: Make dde services conform the the documentation
- such that giving only a topic name really returns all services with
- that topic. [Bug 219155]
- Prevent hangup caused by dde server applications failing to process
- messages. [Bug 707822]
- * tests/winDde.test: Corrected labels and added a test for search by
- topic name.
-
-2003-03-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h (tclOriginalNotifier):
- * generic/tclStubInit.c (tclOriginalNotifier):
- * mac/tclMacNotify.c (Tcl_SetTimer,Tcl_WaitForEvent):
- * unix/tclUnixNotfy.c (Tcl_SetTimer,Tcl_WaitForEvent,
- (Tcl_CreateFileHandler,Tcl_DeleteFileHandler):
- * win/tclWinNotify.c (Tcl_SetTimer,Tcl_WaitForEvent): Some linkers
- apparently use a different representation for a pointer to a function
- within the same compilation unit and a pointer to a function in a
- different compilation unit. This causes checks like those in the
- original notifier procedures to fall into infinite loops. The fix is
- to store pointers to the original notifier procedures in a struct
- defined in the same compilation unit as the stubs tables, and compare
- against those values. [Bug 707174]
-
- * generic/tclInt.h: Removed definition of ParseValue struct that is
- no longer used.
-
-2003-03-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:
- * tests/compile.test: bad command count on TCL_OUT_LINE_COMPILE.
- [Bug 705406] (Don Porter)
-
-2003-03-19 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Replaced [regexp] and [regsub] with
- * library/history.tcl: [string map] where possible. Thanks
- * library/ldAout.tcl: to David Welton. [Bugs 667456,667558]
- * library/safe.tcl: Bumped to http 2.4.3, opt 0.4.5, and
- * library/http/http.tcl: tcltest 2.2.3.
- * library/http/pkgIndex.tcl:
- * library/opt/optparse.tcl:
- * library/opt/pkgIndex.tcl:
- * library/tcltest/tcltest.tcl:
- * library/tcltest/pkgIndex.tcl:
- * tools/genStubs.tcl:
- * tools/tcltk-man2html.tcl:
- * unix/mkLinks.tcl:
-
- * doc/Eval.3 (Tcl_EvalObjEx): Corrected CONST and
- * doc/ParseCmd.3 (Tcl_EvalTokensStandard): return type errors in
- documentation. [Bug 683994]
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): Alternative fix for
- * generic/tclCompile.c (INST_RETURN): [Bug 633204] that uses a new
- * generic/tclCompile.h (INST_RETURN): bytecode INST_RETURN to
- * generic/tclExecute.c (INST_RETURN): properly bytecode the [return]
- command to something that returns TCL_RETURN.
-
-2003-03-18 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Don't run the AC_CYGWIN macro since it uses
- AC_CANONICAL_HOST under autoconf 2.5X. Just check to see if __CYGWIN__
- is defined by the compiler and set the ac_cv_cygwin variable based on
- that. [Bug 705912]
-
-2003-03-18 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * tests/registry.test: Changed the conditionals to avoid an abort if
- [testlocale] is missing, as when running the test in tclsh rather than
- tcltest. [Bug 705677]
-
-2003-03-18 Daniel Steffen <das@users.sourceforge.net>
-
- * tools/tcltk-man2html.tcl: added support for building 'make html'
- from inside distribution directories named with 8.x.x version numbers.
- tcltk-man2html now uses the latest tcl8.x.x resp. tk8.x.x directories
- found inside its --srcdir argument.
-
-2003-03-17 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/format.test: Renumber tests, a bunch of tests all had the same
- id.
-
-2003-03-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/lsearch.n: Altered documentation of -ascii options so
- * doc/lsort.n: they don't specify that they operate on ASCII
- strings, which they never did anyway. [Bug
- 703807]
-
-2003-03-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): Only add the modifier that
- indicates we've got a wide int when we're formatting in an integer
- style. Stops some libc's from going mad. [Bug 702622] Also tidied
- whitespace.
-
-2003-03-13 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tcl.m4 (SC_WITH_TCL): Port version number fix that was made in
- tk instead of tcl sources.
-
-2003-03-13 Mo DeJong <mdejong@users.sourceforge.net>
-
- Require autoconf 2.57 or newer, see TIP 34 for a detailed explanation
- of why this is good. This will no doubt break the build on some
- platforms, let the flaming begin.
-
- * tools/configure: Regen with autoconf 2.57.
- * tools/configure.in: Require autoconf 2.57.
- * unix/configure: Regen with autoconf 2.57.
- * unix/configure.in: Require autoconf 2.57.
- Apply AC_LIBOBJ changes from patch 529884.
- * unix/tcl.m4: Ditto.
- * win/configure: Regen with autoconf 2.57.
- * win/configure.in: Require autoconf 2.57.
- Don't subst LIBOBJS since this happens by default, this avoids an
- autoconf error.
-
-2003-03-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_EvalTokensStandard):
- * generic/tclCmdMZ.c (Tcl_SubstObj):
- * generic/tclCompCmds.c (TclCompileSwitchCmd):
- * generic/tclCompExpr.c (CompileSubExpr):
- * generic/tclCompile.c (TclSetByteCodeFromAny,TclCompileScript,
- (TclCompileTokens,TclCompileCmdWord):
- * generic/tclCompile.h (TclCompileScript):
- * generic/tclExecute.c (TclCompEvalObj):
- * generic/tclInt.h (Interp,TCL_BRACKET_TERM,TclSubstTokens):
- * generic/tclParse.c (ParseTokens,Tcl_SubstObj,TclSubstTokens):
- * tests/subst.test (2.4, 8.7, 8.8, 11.4, 11.5):
- Substantial refactoring of Tcl_SubstObj to make use of the same
- parsing and substitution procedures as normal script evaluation.
- Tcl_SubstObj() moved to tclParse.c. New routine TclSubstTokens()
- created in tclParse.c which implements all substantial functioning of
- Tcl_EvalTokensStandard(). TclCompileScript() loses its "nested"
- argument, the Tcl_Interp struct loses its termOffset field and the
- TCL_BRACKET_TERM flag in the evalFlags field, all of which were only
- used (indirectly) by Tcl_SubstObj(). Tests subst-8.7,8.8,11.4,11.5
- modified to accomodate the only behavior change: reporting of parse
- errors now takes precedence over [return] and [continue] exceptions.
- All other behavior should remain compatible. [RFE 536831,684982] [Bug
- 685106]
-
- * generic/tcl.h: Removed TCL_PREFIX_IDENT and TCL_DEBUG_IDENT
- * win/tclWinPipe.c: from tcl.h -- they are not part of Tcl's
- public interface. Put them in win/tclWinPipe.c where they are used.
-
- * generic/tclInterp.c (Tcl_InterpObjCmd): Corrected and added
- * tests/interp.test (interp-2.13): test for option
- parsing beyond objc for [interp create --]. Thanks to Marco Maggi.
- [Bug 702383]
-
-2003-03-11 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/makefile.vc: Added two missing uses of $(DBGX) so that
- tclpip8x.dll loads without panicking on Win9x.
-
-2003-03-09 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclTest.c (TestChannelCmd): Removed an unused local variable
- that caused compilation problems on some platforms.
-
-2003-03-08 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Added missing "-body" to example. Thanks to Helmut
- Giese. [Bug 700011]
-
-2003-03-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/io.test:
- * tests/ioCmd.test: Define a fcopy constraint and add it to the
- constraint list of any test that depends on the fcopy command. This is
- only useful to Jacl which does not support fcopy.
-
-2003-03-07 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/encoding.test: Name temp files *.tcltestout instead of *.out
- so that when they are removed later, we don't accidently toast any
- files named *.out that the user has created in the build directory.
-
-2003-03-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_FileObjCmd): Fix the setting of a file's
- mtime and atime on 64-bit platforms. [Bug 698146]
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/io.test: Doh! Undo accidental commenting out of a couple of
- tests.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/io.test: Define a fileevent constraint and add it to the
- constraint list of any test that depends on the fileevent command.
- This is only useful to Jacl which does not support fileevent.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/io.test: Define an openpipe constraint and add it to the
- constraint list of any test that creates a pipe using the open
- command. This is only useful to Jacl which does not support pipes.
-
-2003-03-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/TclUtf.c (Tcl_UniCharNcasecmp): Corrected failure to
- * tests/utf.test (utf-25.*): properly compare Unicode strings of
- different case in a case insensitive manner. [Bug 699042]
-
-2003-03-06 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd):
- Replaced a non-portable 'bzero' with a portable 'memset'. [Bug 698442]
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_Seek, Tcl_OutputBuffered): If there is data
- buffered in the statePtr->curOutPtr member then set the BUFFER_READY
- flag in Tcl_Seek. This is needed so that the next call to FlushChannel
- will write any buffered bytes before doing the seek. The existing code
- would set the BUFFER_READY flag inside the Tcl_OutputBuffered
- function. This was a programming error made when Tcl_OutputBuffered
- was originally created in CVS revision 1.35. The setting of the
- BUFFER_READY flag should not have been included in the
- Tcl_OutputBuffered function.
- * generic/tclTest.c (TestChannelCmd): Use the Tcl_InputBuffered and
- Tcl_OutputBuffered util methods to query the amount of buffered input
- and output.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_Flush): Compare the nextAdded member of the
- ChannelBuffer to the nextRemoved member to determine if any output has
- been buffered. The previous check against the value 0 seems to have
- just been a coding error. See other methods like Tcl_OutputBuffered
- for examples where nextAdded is compared to nextRemoved to find the
- number of bytes buffered.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_GetsObj): Check that the eol pointer has not
- gone past the end of the string when in auto translation mode and the
- INPUT_SAW_CR flag is set. The previous code worked because the end of
- string value \0 was being compared to \n, this patch just skips that
- pointless check.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (WriteBytes, WriteChars, Tcl_GetsObj, ReadBytes):
- Rework calls to TranslateOutputEOL to make it clear that a boolean
- value is being returned. Add some comments in an effort to make the
- code more clear. This patch makes no functional changes.
-
-2003-03-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_SetChannelOption): Invoke the
- Tcl_SetChannelBufferSize method as a result of changing the
- -buffersize option to fconfigure. The previous implementation used
- some inlined code that reset the buffer size to the default size
- instead of ignoring the request as implemented in
- Tcl_SetChannelBufferSize.
- * tests/io.test: Update test case so that it actually checks the
- implementation of Tcl_SetChannelBufferSize.
-
-2003-03-05 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc: updated default tcl version to 8.5.
-
-2003-03-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): First attempt at a
- bytecode-compiled switch command. It only handles the most common case
- of switching, but that should be enough for this to speed up a lot of
- people's code. It is expected that the speed gains come from two
- things: better handling of the switch itself, and integrated
- compilation of the arms instead of embedding separate bytecode
- sequences (i.e. better local variable handling.)
- * tests/switch.test (switch-10.*): Tests of both uncompiled and
- compiled switch behaviour. [Patch #644819]
-
- * generic/tclCompile.h (TclFixupForwardJumpToHere): Additional macro
- to make the most common kind of jump fixup a bit easier.
-
-2003-03-04 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bumped version number of
- * generic/tcl.h: Tcl to 8.5a0.
- * library/init.tcl:
- * mac/README:
- * macosx/Tcl.pbproj/project.pbxproj:
- * tests/basic.test:
- * tools/configure.in:
- * tools/tcl.hpj.in:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README:
- * win/README.binary:
- * win/configure.in:
- * win/makefile.bc:
- * win/makefile.vc:
- * win/tcl.m4:
-
- * tools/configure: autoconf
- * unix/configure:
- * win/configure:
-
-2003-03-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.4.2 TAGGED FOR RELEASE ***
-
-2003-03-03 Daniel Steffen <das@users.sourceforge.net>
-
- Mac OS Classic specific fixes:
- * generic/tclIOUtil.c (TclNewFSPathObj): on TCL_PLATFORM_MAC, skip
- potential directory separator at the beginning of addStrRep.
- * mac/tclMacChan.c (OpenFileChannel, CommonWatch): followup fixes to
- cut and splice implementation for file channels.
- * mac/tclMacFile.c (TclpUtime): pass native path to utime().
- * mac/tclMacFile.c (TclpObjLink): correctly implemented creation of
- alias files via new static proc CreateAliasFile().
- * mac/tclMacPort.h: define S_ISLNK macro to fix stat'ing of links.
- * mac/tclMacUtil.c (FSpLocationFromPathAlias): fix to enable stat'ing
- of broken links.
-
-2003-03-03 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/Makefile.vc: corrected bug introduced by 'g' for debug builds.
-
-2003-03-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/dde/pkgIndex.tcl: dde bumped to version 1.2.1 for
- * win/tclWinDde.c: bundled release with Tcl 8.4.2
-
- * library/reg/pkgIndex.tcl: registry bumped to version 1.1.1 for
- * win/tclWinReg.c: bundled release with Tcl 8.4.2
-
- * library/opt/pkgIndex.tcl: updated package index to version 0.4.4
-
-2003-02-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure:
- * win/configure.in: check for 'g' for debug build type, not 'd'.
- * win/rules.vc (DBGX): correct to use 'g' for nmake win makefile to
- match the cygwin makefile for debug builds. [Bug 635107]
-
-2003-02-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n: subcommand is 'file volumes' not 'file volume'
-
-2003-02-27 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIOUtil.c (MakeFsPathFromRelative): removed dead code
- check of typePtr (darley).
-
- * tests/winTime.test: added note about PCI hardware dependency issues
- with high performance clock.
-
-2003-02-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/lsearch.test (lsearch-10.7):
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Stopped -start option from
- causing an option when used with an empty list. [Bug 694232]
-
-2003-02-26 Chengye Mao <chengye.geo@yahoo.com>
-
- * win/tclWinInit.c: fixed a bug in TclpSetVariables by initializing
- dwUserNameLen with the sizeof(szUserName) before calling GetUserName.
- Don't know if this bug has been recorded: it caused crash in starting
- Tcl or wish in Windows.
-
-2003-02-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (TraceCommandProc): Fix mem leak when deleting a
- command that had trace on it. [Bug 693564] (sofer)
-
-2003-02-25 Don Porter <dgp@users.sourceforge.net>
-
- * doc/pkgMkIndex.n: Modified [pkg_mkIndex] to use -nocase matching
- * library/package.tcl: of -load patterns, to better accomodate common
- user errors due to confusion between [package names] names and [info
- loaded] names.
-
-2003-02-25 Andreas Kupries <andreask@pliers.activestate.com>
-
- * tests/pid.test: See below [Bug 678412].
- * tests/io.test: Made more robust against spaces in paths [Bug 678400]
-
-2003-02-25 Miguel Sofer <msofer@users.sf.net>
-
- * tests/execute.test: cleaning up testobj's at the end, to avoid
- leak warning by valgrind.
-
-2003-02-22 Zoran Vasiljevic <zoran@archiwrae.com>
-
- * generic/tclEvent.c (Tcl_FinalizeThread): Fix [Bug 571002]
-
-2003-02-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * tests/binary.test (binary-44.[34]):
- * generic/tclBinary.c (ScanNumber): Fixed problem with unwanted
- sign-bit propagation when scanning wide ints. [Bug 690774]
-
-2003-02-21 Daniel Steffen <das@users.sourceforge.net>
-
- * mac/tclMacChan.c (TclpCutFileChannel, TclpSpliceFileChannel):
- Implemented missing cut and splice procs for file channels.
-
-2003-02-21 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl (tclPkgUnknown): Minor performance tweaks to
- reduce the number of [file] invocations. Meant to improve startup
- times, at least a little bit. [Patch 687906]
-
-2003-02-20 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4:
- * unix/tclUnixPipe.c: (macosx) use vfork() instead of fork() to create
- new processes, as recommended by Apple (vfork can be up to 100 times
- faster thank fork on macosx).
- * unix/configure: regen.
-
-2003-02-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEncoding.c (LoadTableEncoding):
- * library/encoding/cp932.enc: Correct jis round-trip encoding
- * library/encoding/euc-jp.enc: by adding 'R' type to .enc files.
- * library/encoding/iso2022-jp.enc: [Patch 689341] (koboyasi, taguchi)
- * library/encoding/jis0208.enc:
- * library/encoding/shiftjis.enc:
- * tests/encoding.test:
-
- * unix/tclUnixChan.c (Tcl_MakeTcpClientChannel): add
- MakeTcpClientChannelMode that takes actual mode flags to avoid hang on
- OS X (may be OS X bug, but patch works x-plat). [Bug 689835] (steffen)
-
-2003-02-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/regsub.n: Typo fix [Bug 688943]
-
-2003-02-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixThrd.c (TclpReaddir):
- * unix/tclUnixPort.h: update to Bug 689100 patch to ensure that there
- is a defined value of MAXNAMLEN (aka NAME_MAX in POSIX) and that we
- have some buffer allocated.
-
-2003-02-19 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclStringObj.c: restored Tcl_SetObjLength() side-effect of
- always invalidating unicode rep (if the obj has a string rep). Added
- hasUnicode flag to String struct, allows decoupling of validity of
- unicode rep from buffer size allocated to it (improves memory
- allocation efficiency). [Bugs 686782, 671138, 635200]
-
- * macosx/Tcl.pbproj/project.pbxproj:
- * macosx/Makefile: reworked embedded build to no longer require
- relinking but to use install_name_tool instead to change the
- install_names for embedded frameworks. [Bug 644510]
-
- * macosx/Tcl.pbproj/project.pbxproj: preserve mod dates when running
- 'make install' to build framework (avoids bogus rebuilds of dependent
- frameworks because tcl headers appear changed).
-
- * tests/ioCmd.test (iocmd-1.8): fix failure when system encoding is
- utf-8: use iso8859-1 encoding explicitly.
-
-2003-02-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileExprWords): remove unused variable
- "range" [Bug 664743]
- * generic/tclExecute.c (ExprSrandFunc): remove unused variable
- "result" [Bug 664743]
- * generic/tclStringObj.c (UpdateStringOfString): remove unused
- variable "length" [Bug 664751]
- * tests/execute.test (execute-7.30): fix for [Bug 664775]
-
-2003-02-18 Andreas Kupries <andreask@activestate.com>
-
- * unix/tcl.m4: [Bug #651811] Added definition of _XOPEN_SOURCE and
- linkage of 'xnet' library to HP 11 branch. This kills a lot of
- socket-related failures in the testsuite when Tcl was compiled in 64
- bit mode (both PA-RISC 2.0W, and IA 64).
-
- * unix/configure: Regenerated.
-
-2003-02-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIO.c (HaveVersion): correctly decl static
-
- * unix/tclUnixThrd.c (TclpReaddir): reduce size of name string in tsd
- to NAME_MAX instead of PATH_MAX. [Bug 689100] (waters)
-
-2003-02-18 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_ENABLE_THREADS): Make sure -lpthread gets passed on
- the link line when checking for the pthread_attr_setstacksize symbol.
-
-2003-02-18 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclTest.c: cleanup of new 'simplefs' test code, and better
- documentation.
-
-2003-02-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclRenameCommand): fixing error in previous
- commit.
-
-2003-02-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (TclExecuteByteCode INST_STR_MATCH):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd STR_MATCH):
- * generic/tclUtf.c (TclUniCharMatch):
- * generic/tclInt.decls: add private TclUniCharMatch function that
- * generic/tclIntDecls.h: does string match on counted unicode
- * generic/tclStubInit.c: strings. Tcl_UniCharCaseMatch has the failing
- * tests/string.test: that it can't handle strings or patterns with
- * tests/stringComp.test: embedded NULLs. Added tests that actually try
- strings/pats with NULLs. TclUniCharMatch should be TIPed and made
- public in the next minor version rev.
-
-2003-02-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclRenameCommand): 'oldFullName' object was not
- being freed on all function exits, causing a memory leak. [Bug 684756]
-
-2003-02-17 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_GetsObj): Minor change so that eol is only
- assigned at the top of the TCL_TRANSLATE_AUTO case block. The other
- cases assign eol so this does not change any functionality.
-
-2003-02-17 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * tests/notify.test: Removed Windows line terminators. [Bug 687913].
-
-2003-02-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_EvalEx):
- * generic/tclCompExpr.c (CompileSubExpr):
- * generic/tclCompile.c (TclCompileScript):
- * generic/tclParse.c (Tcl_ParseCommand, ParseTokens):
- * generic/tclParseExpr.c (ParsePrimaryExpr):
- * tests/basic.test (47.1):
- * tests/main.test (3.4):
- * tests/misc.test (1.2):
- * tests/parse.test (6.18):
- * tests/parseExpr.test (15.35):
- * tests/subst.test (8.6): Don Porter's fix for bad parsing of nested
- scripts. [Bug 681841]
-
-2003-02-15 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * tests/notify.test (new-file):
- * generic/tclTest.c (TclTest_Init, EventtestObjCmd, EventtestProc,
- (EventTestDeleteProc):
- * generic/tclNotify.c (Tcl_DeleteEvents): Fixed Tcl_DeleteEvents not
- to get a pointer smash when deleting the last event in the queue.
- Added test code in 'tcltest' and a new file of test cases
- 'notify.test' to exercise this functionality; several of the new test
- cases fail for the original code and pass for the corrected code. [Bug
- 673714]
-
- * unix/tclUnixTest.c (TestfilehandlerCmd): Corrected a couple of typos
- in error messages. [Bug 596027]
-
-2003-02-14 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README: Bumped to version 8.4.2.
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure:
- * unix/configure.in:
- * unix/tcl.m4:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure:
- * win/configure.in:
- * macosx/Tcl.pbproj/project.pbxproj:
-
- * generic/tclStringObj.c (Tcl_GetCharLength): perf tweak
-
- * unix/tcl.m4: correct HP-UX ia64 --enable-64bit build flags
-
-2003-02-14 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/tclWinTime.c: Added code to test and compensate for forward
- leaps of the performance counter. See the MSDN Knowledge Base article
- Q274323 for the hardware problem that makes this necessary on certain
- machines.
- * tests/winTime.test: Revised winTime-2.1 - it had a tolerance of
- thousands of seconds, rather than milliseconds. (What's six orders of
- magnitude among friends?) Both the above changes are triggered by a
- problem reported at:
- http://aspn.activestate.com/ASPN/Mail/Message/ActiveTcl/1536811
- although the developers find it difficult to believe that it accounts
- for the observed behavior and suspect a fault in the RTC chip.
-
-2003-02-13 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/tclWinInit.c: Added conversion from the system encoding to
- tcl_platform(user), so that it works with non-ASCII7 user names. [Bug
- 685926]
-
- * doc/tclsh.1: Added language to describe the handling of the
- end-of-file character \u001a embedded in a script file. [Bug 685485]
-
-2003-02-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fileName.test:
- * unix/tclUnixFile.c: fix for [Bug 685445] when using 'glob -l' on
- broken symbolic links. Added two new tests for this bug.
-
-2003-02-11 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * tests/http.test: Corrected a problem where http-4.14 would fail when
- run in an environment with a proxy server. Replaced references to
- scriptics.com by tcl.tk.
-
-2003-02-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/lsearch.test:
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): protect against the case
- that lsearch -regepx list and pattern objects are equal.
-
- * tests/stringObj.test:
- * generic/tclStringObj.c (Tcl_GetCharLength): correct ascii char opt
- of 2002-11-11 to not stop early on \x00. [Bug 684699]
-
- * tests.parse.test: remove excess EOF whitespace
-
- * generic/tclParse.c (CommandComplete): more paranoid check to break
- on (p >= end) instead of just (p == end).
-
-2003-02-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c (CommandComplete):
- * tests/parse.test: fix for [Bug 684744], by Don Porter.
-
-2003-02-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIOUtil.c (Tcl_FSJoinPath, Tcl_FSGetNormalizedPath):
- (UpdateStringOfFsPath): revert the cwdLen == 0 check and instead
- follow a different code path in Tcl_FSJoinPath.
- (Tcl_FSConvertToPathType, Tcl_FSGetNormalizedPath):
- (Tcl_FSGetFileSystemForPath): Update string rep of path objects before
- freeing the internal object. (darley)
-
- * tests/fileSystem.test: added test 8.3
- * generic/tclIOUtil.c (Tcl_FSGetNormalizedPath):
- (UpdateStringOfFsPath): handle the cwdLen == 0 case
-
- * unix/tclUnixFile.c (TclpMatchInDirectory): simplify the hidden file
- match check.
-
-2003-02-10 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure:
- * win/configure.in: Generate error when attempting to build under
- Cygwin. The Cygwin port of Tcl/Tk does not build and people are filing
- bug reports under the mistaken impression that someone is actually
- maintaining the Cygwin port. A post to comp.lang.tcl asking someone to
- volunteer as an area maintainer has generated no results. Closing bugs
- 680840, 630199, and 634772 and marking as "Won't fix".
-
-2003-02-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/append.n: Return value was not documented. [Bug 683188]
-
-2003-02-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * generic/tclIOUtil.c:
- * generic/tclInt.h:
- * tests/fileSystem.test:
- * unix/tclUnixFCmd.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: further filesystem optimization, applying [Patch
- 682500]. In particular, these code examples are faster now:
- foreach f $flist { if {[file exists $f]} {file stat $f arr;...}}
- foreach f [glob -dir $dir *] { # action and/or recursion on $f }
- cd $dir
- foreach f [glob *] { # action and/or recursion on $f }
- cd ..
-
- * generic/tclTest.c: Fix for [Bug 683181] where test suite left files
- in 'tmp'.
-
-2003-02-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/safe.tcl: code cleanup of eval and string comp use.
-
-2003-02-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFCmd.c: cleanup long lines
- * win/tclWinFile.c: sped up pure 'glob' by a factor of 2.5
- ('foreach f [glob *] { file exists $f }' is still slow)
- * tests/fileSystem.text:
- * tests/fileName.test: added new tests to ensure correct behaviour in
- optimized filesystem code.
-
-2003-02-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclTest.c:
- * tests/fileSystem.text: fixed test 7.2 to avoid a possible crash, and
- not change the pwd.
-
- * tests/http.text: added comment to test 4.15, that it may fail if you
- use a proxy server.
-
-2003-02-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileIncrCmd):
- * tests/incr.test: Don't include the text "(increment expression)" in
- the errorInfo generated by the compiled version of the incr command
- since it does not match the message generated by the non-compiled
- version of incr. It is also not possible to match this error output
- under Jacl, which does not support a compiler.
-
-2003-02-06 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): When an error is
- encountered reading the increment value during a compiled call to
- incr, add a "(reading increment)" error string to the errorInfo
- variable. This makes the errorInfo variable set by the compiled incr
- command match the value set by the non-compiled version.
- * tests/incr-old.test: Change errorInfo result for the compiled incr
- command case to match the modified implementation.
- * tests/incr.test: Add tests to make sure the compiled and
- non-compiled errorInfo messages are the same.
-
-2003-02-06 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Filename arguments to [outputChannel]
- and [errorChannel] (also -outfile and -errfile) were [open]ed but
- never [closed]. Also, [cleanupTests] could remove output or error
- files. [Bug 676978].
- * library/tcltest/pkgIndex.tcl: Bumped to version 2.2.2.
-
-2003-02-05 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/interp.test:
- * tests/set-old.test: Run test cases that depend on hash order through
- lsort so that the tests also pass under Jacl. Does not change test
- results under Tcl.
-
-2003-02-04 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c:
- * generic/tclEvent.c:
- * generic/tclInt.h:
- * mac/tclMacFCmd.c:
- * unix/tclUnixFCmd.c:
- * win/tclWin32Dll.c:
- * win/tclWinFCmd.c:
- * win/tclWinInit.c:
- * win/tclWinInt.h:
- * tests/fileSystem.test: fix to finalization/unloading/encoding issues
- to make filesystem much less dependent on encodings for its cleanup,
- and therefore allow it to be finalized later in the exit process. This
- fixes fileSystem.test-7.1. Also fixed one more bug in setting of
- modification dates of files which have undergone cross-platform
- copies. [Patch 676271]
-
- * tests/basic.test:
- * tests/exec.test:
- * tests/fileName.test:
- * tests/io.test: fixed some test failures when tests are run from a
- directory containing spaces.
-
- * tests/fileSystem.test:
- * generic/tclTest.c: added regression test for the modification date
- setting of cross-platform file copies.
-
-2003-02-03 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclBasic.c: Changed [trace add command] so that 'rename'
- callbacks get fully qualified names of the command. [Bug 651271].
- ***POTENTIAL INCOMPATIBILITY***
- * tests/trace.test: Modified the test cases for [trace add command] to
- expect fully qualified names on the 'rename' callbacks. Added a case
- for renaming a proc within a namespace.
- * doc/trace.n: Added language about use of fully qualified names in
- trace callbacks.
-
-2003-02-01 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclCompCmds.c: Removed an unused variable that caused
- compiler warnings on SGI. [Bug 664379]
-
- * generic/tclLoad.c: Changed the code so that if Tcl_StaticPackage is
- called to report the same package as being loaded in two interps, it
- shows up in [info loaded {}] in both of them (previously, it didn't
- appear in the static package list in the second).
-
- * tests/load.test Added regression test for the above bug. [Bug
- 670042]
-
- * generic/tclClock.c: Fixed a bug that incorrectly allowed [clock
- clicks {}] and [clock clicks -] to be accepted as if they were [clock
- clicks -milliseconds].
-
- * tests/clock.test: Added regression tests for the above bug. [Bug
- 675356]
-
- * tests/unixNotfy.test: Added cleanup of working files. [Bug 675609]
-
- * doc/Tcl.n: Added headings to the eleven paragraphs, to improve
- formatting in the tools that attempt to extract tables of contents
- from the manual pages. [Bug 627455]
-
- * generic/tclClock.c: Expanded mutex protection around the setting of
- env(TZ) and the thread-unsafe call to tzset(). [Bug 656660]
-
-2003-01-31 Don Porter <dgp@users.sourceforge.net>
-
- * tests/tcltest.test: Cleaned up management of file/directory
- creation/deletion to improve "-debug 1" output. [Bug 675614]
- The utility [slave] command failed to properly [list]-quote a
- constructed [open] command, causing failure when the pathname
- contained whitespace. [Bug 678415]
-
- * tests/main.test: Stopped main.test from deleting existing file. Test
- suite should not delete files that already exist. [Bug 675660]
-
-2003-01-28 Don Porter <dgp@users.sourceforge.net>
-
- * tests/main.test: Constrain tests that do not work on Windows. [Bug
- 674387]
-
-2003-01-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to setting modification date in
- TclCrossFilesystemCopy. Also added 'panic' in
- Tcl_FSGetFileSystemForPath under illegal calling circumstances which
- lead to hard-to-track-down bugs.
-
- * generic/tclTest.c: added test suite code to allow exercising a
- vfs-crash-on-exit bug in Tcl's finalization caused by the encodings
- being cleaned up before unloading occurs.
- * tests/fileSystem.test: added new 'knownBug' test 7.1 to demonstrate
- the crash on exit.
-
-2003-01-28 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tcl.h: Add TCL_PREFIX_IDENT and TCL_DEBUG_IDENT, used only
- by TclpCreateProcess.
- * unix/Makefile.in: Define TCL_DBGX.
- * win/Makefile.in: Define TCL_DBGX.
- * win/tclWinPipe.c (TclpCreateProcess): Check that the Tcl pipe dll
- actually exists in the Tcl bin directory and panic if it is not found.
- Incorporate TCL_DBGX into the Tcl pipe dll name. This fixes a really
- mysterious error that would show up when exec'ing a 16 bit application
- under Win95 or Win98 when Tcl was compiled with symbols. The error
- seemed to indicate that the executable could not be found, but it was
- actually the Tcl pipe dll that could not be found.
-
-2003-01-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update msys+mingw URL to release 6. This version bundles
- gcc 3.
-
-2003-01-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Add test that checks to see if the compiler can
- cast to a union type.
- * win/tclWinTime.c: Squelch compiler warning about union initializer
- by casting to union type when compiling with gcc.
-
-2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_CutChannel, Tcl_SpliceChannel): Invoke
- TclpCutFileChannel and TclpSpliceFileChannel.
- * generic/tclInt.h: Declare TclpCutFileChannel and
- TclpSpliceFileChannel.
- * unix/tclUnixChan.c (FileCloseProc, TclpOpenFileChannel,
- (Tcl_MakeFileChannel, TclpCutFileChannel, TclpSpliceFileChannel):
- Implement thread load data cut and splice for file channels. This
- avoids an invalid memory ref when compiled with -DDEPRECATED.
- * win/tclWinChan.c (FileCloseProc, TclpCutFileChannel,
- (TclpSpliceFileChannel): Implement thread load data cut and splice for
- file channels. This avoids an invalid memory ref that was showing up
- in the thread extension.
-
-2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWin32Dll.c (TclpCheckStackSpace, squelch_warnings):
- * win/tclWinChan.c (Tcl_MakeFileChannel, squelch_warnings):
- * win/tclWinFCmd.c (DoRenameFile, DoCopyFile, squelch_warnings):
- Re-implement inline ASM SEH handlers for gcc. The esp and ebp
- registers are now saved on the stack instead of in global variables so
- that the code is thread safe. Add additional checks when TCL_MEM_DEBUG
- is defined to be sure the values were recovered from the stack
- properly. Remove squelch_warnings functions and add a dummy call in
- the handler methods to squelch compiler warnings.
-
-2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure:
- * win/configure.in: Define HAVE_ALLOCA_GCC_INLINE when we detect that
- no alloca function is found in malloc.h and we are compiling with GCC.
- Remove HAVE_NO_ALLOC_DECL define.
- * win/tclWin32Dll.c (TclpCheckStackSpace): Don't define alloca as a
- cdecl function. Doing this caused a tricky runtime bug because the
- _alloca function expects the size argument to be passed in a register
- and not on the stack. To fix this problem, we use inline ASM when
- compiling with gcc to invoke _alloca with the size argument loaded
- into a register.
-
-2003-01-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinDde.c (Dde_Init): clarified use of tsdPtr.
- (DdeServerProc): better refcount handling of returnPackagePtr.
-
- * generic/tclEvent.c (Tcl_Finalize): revert finalize change on
- 2002-12-04 to correct the issue with extensions that have TSD needing
- to finalize that before they are unloaded. This issue needs further
- clarification.
-
- * tests/unixFCmd.test: only do groups check on unix
-
-2003-01-24 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclStringObj.c: proper fixes for Tcl_SetObjLength and
- Tcl_AttemptSetObjectLength dealing with string objects with both
- pure-unicode and normal internal representations. Previous fix didn't
- handle all cases correctly.
- * generic/tclIO.c: Add 'Tcl_GetString()' to ensure the object has a
- valid 'objPtr->bytes' field before manipulating it directly.
-
- This fixes [Bug 635200] and [Bug 671138], but may reduce performance
- of Unicode string handling in some cases. A further patch will be
- applied to address this, once the code is known to be correct.
-
-2003-01-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Add test to see if alloca is undefined in
- malloc.h.
- * win/tclWin32Dll.c (TclpCheckStackSpace): Rework the SEH exception
- handler logic to avoid using the stack since alloca will modify the
- stack. This was causing a nasty bug that would set the exception
- handler to 0 because it tried to pop the previous exception handler
- off the top of the stack.
-
-2003-01-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-
- * doc/lset.n: Fixed fault in return values from lset in documentation
- examples [SF Bug #658463] and tidied up a bit at the same time.
-
-2003-01-21 Joe English <jenglish@users.sourceforge.net>
-
- * doc/namespace.n (namespace inscope): Clarified documentation
- [Patch 670110]
-
-2003-01-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set SHLIB_SUFFIX so that
- TCL_SHLIB_SUFFIX will be set to a useful value in the generated
- tclConfig.sh. Set SHLIB_LD_LIBS to "" or '${LIBS}' based on the
- --enable-shared flag. This matches the UNIX implementation.
-
-2003-01-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCkalloc.c: change %ud to %u as appropriate.
-
-2003-01-17 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinDde.c (DdeServerProc): Deallocate the Tcl_Obj returned by
- ExecuteRemoteObject if it was not saved in a connection object.
-
-2003-01-17 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tcl.h: Revert earlier change that defined TCL_WIDE_INT_TYPE
- as long long and TCL_LL_MODIFIER as L when compiling with mingw. This
- change ended up causing some test case failures when compiling with
- mingw.
- * generic/tclObj.c (UpdateStringOfWideInt): Describe the warning
- generated by mingw and why it needs to be ignored so that someone is
- not tempted to "fix" this problem again in the future.
-
-2003-01-16 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclStringObj.c: Tcl_SetObjLength fix for when the object has
- a unicode string rep. [Bug 635200]
- * tests/stringObj.test: removed 'knownBug' constraint from test 14.1
- now that this bug is fixed.
-
- * generic/tclInt.h:
- * generic/tclBasic.c:
- * generic/tclCmdMZ.z:
- * tests/trace.test: execution and command tracing bug fixes and
- cleanup. In particular fixed [Bug 655645], [Bug 615043], [Bug 571385]
- - fixed some subtle cleanup problems with tracing. This required
- replacing Tcl_Preserve/Tcl_Release with a more robust refCount
- approach. Solves at least one known crash caused by memory
- corruption.
- - fixed some confusion in the code between new style traces (Tcl
- 8.4) and the very limited 'Tcl_CreateTrace' which existed before.
- - made behaviour consistent with documentation (several tests even
- contradicted the documentation before).
- - fixed some minor error message details
- - added a number of new tests
-
-2003-01-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinSerial.c (SerialOutputProc): add casts for bytesWritten to
- allow strict compilation (no warnings).
-
- * tests/winDde.test:
- * win/tclWinDde.c (Tcl_DdeObjCmd): Prevent crash when empty service
- name is passed to 'dde eval' and goto errorNoResult in request and
- poke error cases to free up any allocated data.
-
-2003-01-16 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWin32Dll.c (squelch_warnings): Squelch compiler warnings from
- SEH ASM code.
- * win/tclWinChan.c (squelch_warnings): Squelch compiler warnings from
- SEH ASM code.
- * win/tclWinDde.c: Add casts to avoid compiler warnings. Pass pointer
- to DWORD instead of int to avoid compiler warnings.
- * win/tclWinFCmd.c (squelch_warnings): Add casts and fixup decls to
- avoid compiler warnings. Squelch compiler warnings from SEH ASM code.
- * win/tclWinFile.c: Add casts and fixup decls to avoid compiler
- warnings. Remove unused variable.
- * win/tclWinNotify.c: Declare as DWORD instead of int to avoid
- compiler warning.
- * win/tclWinReg.c: Add casts to avoid compiler warning. Fix assignment
- in if expression bug.
- * win/tclWinSerial.c: Add casts to avoid compiler warnings. Remove
- unused variable.
- * win/tclWinSock.c: Add casts and fixup decls to avoid compiler
- warnings.
-
-2003-01-14 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclClock.c (FormatClock): corrected typo that incorrectly
- conditionally defined savedTZEnv and savedTimeZone.
-
-2003-01-13 Mo DeJong <mdejong@users.sourceforge.net>
-
- Fix mingw build problems and compiler warnings.
-
- * generic/tcl.h: Add if defined(__MINGW32__) check to code that sets
- the TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER.
- * generic/tclClock.c (FormatClock): Don't define savedTimeZone and
- savedTZEnv if we are not going to use them.
- * generic/tclEnv.c: Add cast to avoid warning.
- * win/tclWinChan.c: Use DWORD instead of int to avoid compiler warning
- * win/tclWinThrd.c: Only define allocLock, allocLockPtr, and dataKey
- when TCL_THREADS is defined. This avoid a compiler warning about
- unused variables.
-
-2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update msys + mingw URL, the new release includes the
- released 1.0.8 version of msys which includes a number of bug fixes.
-
-2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Pull in addition of shell32.lib to
- LIBS_GUI that was added to the Tk tcl.m4 but never made it back into
- the Tcl version.
-
-2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tcl.h: Skip Tcl's define of CHAR, SHORT, and LONG when
- HAVE_WINNT_IGNORE_VOID is defined. This avoids a bunch of compiler
- warnings when building with Cygwin or Mingw.
- * win/configure: Regen.
- * win/configure.in: Define HAVE_WINNT_IGNORE_VOID when we detect a
- winnt.h that still defines CHAR, SHORT, and LONG when VOID has already
- been defined.
- * win/tcl.m4 (SC_LOAD_TCLCONFIG): Subst the TCL_DEFS loaded from
- tclConfig.sh so that Tcl defines can make it into the Tk Makefile.
-
-2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Check for typedefs like LPFN_ACCEPT in winsock2.h
- and define HAVE_NO_LPFN_DECLS if not found.
- * win/tclWinSock.c: Define LPFN_* typedefs if HAVE_NO_LPFN_DECLS is
- defined. This fixes the build under Mingw and Cygwin, it was broken by
- the changes made on 2002-11-26.
-
-2003-01-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c:
- * win/tclWinInt.h:
- * win/tclWinInit.c: fix to new WinTcl crash on exit with vfs,
- introduced on 2002-12-06. Encodings must be cleaned up after the
- filesystem.
-
- * win/makefile.vc: fix to minor VC++ 5.2 syntax problem
-
-2003-01-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): Corrected off-by-one
- problem with recent commit. [Bug 633204]
-
-2003-01-09 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: remove unused variable 'macSpecialCase'
- [Bug 664749]
-
- * generic/tclIOUtil.c:
- * generic/tclInt.h:
- * unix/tclUnixFile.c:
- * mac/tclMacFile.c:
- * win/tclWinFile.c:
- * win/tclWinInt.h:
- * win/tclWin32Dll.c:
- * tests/cmdAH.test: fix to non-ascii chars in paths when setting mtime
- and atime through 'file (a|m)time $path $time'. [Bug 634151]
-
-2003-01-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExprFloatError): Use the IS_NAN macro for
- greater clarity of code.
-
-2003-01-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileReturnCmd):
- * tests/compile.test: Corrects failure of bytecompiled [catch
- {return}] to have result TCL_RETURN (not TCL_OK) [Bug 633204]. This
- patch is a workaround for 8.4.X. A new opcode INST_RETURN is a better
- long term solution for 8.5 and later.
-
-2003-01-04 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc:
- * win/rules.vc: Fixed INSTALLDIR macro problem that blanked itself by
- accident causing the install target to put the tree at the root of the
- drive built on. Whoops..
-
- Renamed the 'linkexten' option to be 'staticpkg'. Added 'thrdalloc' to
- allow the switching _on_ of the thread allocator. Under testing, I
- found it not to be benificial under windows for the purpose of the
- application I was using it for. It was more important for this app
- that resources for tcl threads be returned to the system rather than
- saved/moved to the global recycler. Be extra clean or extra fast for
- the default threaded build? Let's move to clean and allow it to be
- switched on for users who find it benificial for their use of threads.
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2004 b/ChangeLog.2004
deleted file mode 100644
index e237382..0000000
--- a/ChangeLog.2004
+++ /dev/null
@@ -1,4619 +0,0 @@
-2004-12-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tcl.m4, win/configure: update MSVC CFLAGS_OPT to -O2, remove -Gs
- (included in -O2) and -GD (outdated). Use "link -lib" instead of "lib"
- binary and remove -YX for MSVC7 portability. Add -fomit-frame-pointer
- for gcc OPT compiles. [Bug 1092952, 1091967] Align LIBS_GUI with Tk
- head needs.
-
-2004-12-29 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclDate.c: Regen
- * generic/tclGetDate.y (TclDatelex): Fixed a problem where a
- four-digit group with >=2 leading zeroes appeared to be a two-digit
- group, leading to misinterpreting the time 0012 as 1200. [Bug 1090413]
- * library/clock.tcl: Added code to interpret correctly months outside
- the range 01-12 as reduced modulo 12 with a corresponding adjustment
- to the year. [Bug 1092789]
- * tests/clock.test: Added regression test cases for the above two bugs
- * unix/Makefile.in: Added --no-lines to the 'bison' command line to
- * win/Makefile.in: help constrain the number of diffs in a cvs checkin
-
-2004-12-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclLiteral.c:
- * generic/tclProc.c:
- Avoid sharing cmdName literals accross namespaces, and generalise
- usage of the TclRegisterNewLiteral macro. [Patch 1090905]
-
-2004-12-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: moved TclInitCompiledLocals to tclProc.c
- * generic/tclProc.c: new static InitCompiledLocals to allow for a
- single pass over the proc's arguments at proc load time (instead of
- two as previously). TclObjInterpProc() now allocates the
- compiledLocals on the tcl execution stack, using the new
- TclStackAlloc/Free functions.
-
-2004-12-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (Tcl_LimitSetTime, TimeLimitCallback):
- (TclLimitRemoveAllHandlers, TclInitLimitSupport): Set a timer event to
- trigger when the time limit runs out. All the time limit actually does
- is check to see if the time limit has been exceeded, but this is
- enough to fix [Bug 1085023].
- * generic/tclInt.h (struct Interp): Added a field to hold the token
- for the timer event handler associated with the current time limit.
- * generic/tclEvent.c (Tcl_UpdateObjCmd, Tcl_VwaitObjCmd): Add error
- message when limit exceeded.
- * tests/interp.test (interp-34.[89]): Check that time limits handle
- the two cases reported in [Bug 1085023]
-
- * generic/tclTimer.c (TclCreateAbsoluteTimerHandler): New internal
- function that allows setting a timer handler that will be triggered at
- (or after) a specific time instead of at some number of milliseconds
- in the future. This is a candidate for future exposure via a TIP.
-
-2004-12-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclNamesp.c:
- * generic/tclProc.c:
- * generic/tclStubInit.c:
- * generic/tclTest.c: Added two new functions to allocate memory from
- the execution stack (TclStackAlloc, TclStackFree). Added functions
- TclPushStackFrame and TclPopStackFrame that do the work of
- Tcl_PushCallFrame and Tcl_PopCallFrame, but using frames allocated in
- the execution stack - i.e., heap instead of C-stack. The core uses
- these two new functions exclusively; the old ones remain for backwards
- compat, as at least two popular extensions (itcl, xotcl) are known to
- use them.
-
-2004-12-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c:
- * generic/tclInt.h:
- * generic/tclProc.c:
- * generic/tclVar.c: changing the isProcCallFrame field of the
- CallFrame struct from a 0/1 field to flags. Should be perfectly
- backwards compatible.
-
-2004-12-14 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure.in: Added special processing to remove "$U" from
- libraries in the LIBOBJS value. This is an auto-make-ism we need to
- avoid. [Bug 1081541]
-
- * unix/configure: autoconf-2.57
-
-2004-12-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Restored extern "C" guards so that C++ code sees
- function pointer typedef linkage consistent with earlier Tcl releases.
- [Bug 1082349]
-
- * generic/tclEncoding.c: Plugged some memory leaks. Thanks to Rolf Ade
- * generic/tclUtil.c: for reports and testing [Bug 1083082]
-
-2004-12-13 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Clarify that the [clock scan] command does not accept
- the full range of ISO8601 point-in-time formats. [Bug 1075433]
-
-2004-12-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclArrayObjCmd - ARRAY_NAMES): leaking an object
- [Bug 1084111] - thanks to Rolf Ade.
-
-2004-12-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclObj.c (TclSetCmdNameObj): special handling for fully
- qualified command names (as in fix [Patch 456668]).
-
-2004-12-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclNamesp.c: converting the static function
- GetNamespaceFromObj() to MODULE_SCOPE TclGetNamespaceFromObj().
-
-2004-12-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/tcl.wse.in, unix/tcl.spec, win/README.binary, README:
- * win/configure.in, unix/configure.in, generic/tcl.h:
- Bumped version number to 8.5a3 to distinguish HEAD of CVS development
- from the recent 8.5a2 release.
-
-2004-12-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclInitCompiledLocals):
- * generic/tclCompile.h:
- * generic/tclInt.h:
- * generic/tclProc.c (TclObjInterpProc, TclCreateProc): optimised
- loops that initialise a proc's arguments and compiled local
- variables, removing tests from inner loops.
-
-2004-12-10 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h: Move ensemble API decls here from tclNamesp.c
-
-2004-12-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (TclMakeEnsembleCmd, TclSetEnsemble*)
- (TclSetEnsemble*, TclFindEnsemble): Build an internal API for creating
- and manipulating ensembles; they can be deleted using the normal
- command-deletion API.
-
- * doc/Async.3: Reword for better grammar, better nroff and get the
- flag name right. (Reported by David Welton.)
-
-2004-12-07 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (2.1-4): Added constraints so that when a value
- of TCL_LIBRARY is required for process initialization, we skip the
- tests that mess with that value.
-
-2004-12-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- *** 8.5a2 TAGGED FOR RELEASE ***
-
- * unix/Makefile.in: add library/{tzdata,msgs} to dist target (kbk)
-
- * doc/foreach.n: Adjust tabs to be friendlier to some HTML
- converters. [Bug 1078760]
-
-2004-12-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixNotfy.c (NotifierThreadProc): init numFdBits
- [Bug 1079286]
-
- * doc/error.n, doc/SaveResult.3, doc/Thread.3: minor nroff typos
-
-2004-12-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/safe.test: Trim auto_path to improve performance [1080039]
-
- * tests/msgcat.test: makeFile/removeFile cleanup [1079117]
-
-2004-12-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEncoding.c: Different fix for [Bug 1077005].
- * generic/tclEvent.c: Broke apart TclpSetInitialEncodings() on
- * generic/tclInt.h: Windows into TclpSetInterfaces(), that is
- * unix/tclUnixInit.c: fundamentally essential, and the initialization
- * win/tclWinInit.c: of the system encoding, which is not. Made
- the TclpSetInterfaces call part of TclInitSubsystems so it cannot be
- overlooked.
-
-2004-12-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * changes: updated for 8.5a2 release
-
-2004-12-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c (TclSetProcessGlobalValue): Handle the case where
- a ProcessGlobalValue might be assigned to itself.
-
- * generic/tclEncoding.c (MakeFileMap): Correct refcounting errors
- managing values returned by TclPathPart (with refCount of 1!) that led
- to a memory leak. [Bug 1077474].
-
-2004-12-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix and new tests for [Bug 1074671] to ensure
- * tests/fileSystem.test: tilde paths are not returned specially by
- 'glob'.
-
-2004-12-02 Kevin B. Kenny <kennykb@acm.org>
-
- * win/Makefile.in: Added a 'sed' in the setting of ROOT_DIR_NATIVE to
- compensate for a bug in cygpath (at least version 1.36) that leaves a
- trailing backslash on the end of the converted path.
-
-2004-12-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (Alias,Target,Master): Rewrote these so that the
- aliases that refer to an interpreter are stored in a list and not a
- hashtable (which was only ever a convenience, and forced the use of a
- global mutex to generate keys!) [FRQ 1077210]
- * generic/tclNamesp.c (numNsCreated): Moved into thread-local storage
- to remove a global mutex. [FRQ 1077210]
-
-2004-12-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c (TclGetProcessGlobalValue): Narrowed the scope of
- mutex locks.
-
- * generic/tclUtil.c: Updated Tcl_GetNameOfExecutable() to
- * generic/tclEncoding.c: make use of a ProcessGlobalValue for
- * generic/tclEvent.c: storing the executable name. Added
- internal routines Tcl(Get|Set)ObjNameOfExecutable() to access that
- storage in Tcl_Obj, rather than string format.
-
- * unix/tclUnixFile.c: Rewrote TclpFindExecutable() to use
- * win/tclWinFile.c: TclSetObjNameOfExecutable to store the
- executable name it computes.
-
- * generic/tclInt.h: Added internal stub entries for
- * generic/tclInt.decls: TclpFindExecutable and
- Tcl(Get|Set)ObjNameOfExecutable.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclCmdIL.c: Retrieve executable name in Tcl_Obj form
- * win/tclWinPipe.c: instead of string form.
-
- * unix/tclUnixTest.c: Update [testfindexecutable] command to use new
- internal interfaces.
-
- * generic/tclEncoding.c: Moved TclpSetInitialEncodings() call
- from Tcl_FindExecutable() into TclInitEncodingSubsystem(). This is
- important on Windows where it establishes whether the "ascii" or
- "unicode" set of system routines will be used, and that needs to be
- done earlier to support filesystem operations. [Bug 1077005]
-
-2004-12-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/winDde.test: Rewritten to use tcltest2 features more
- thoroughly (reducing the [catch] count!) and fix the problem with
- winDde-6.1 being out of synch with the implementation.
-
-2004-11-30 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl ([unknown]): Restored the save/restore of the
- variables ::errorCode and ::errorInfo. This is needed when the
- [::bgerror] command is auto-loaded (as it is by Tk).
-
- Patch 976520 reworks several of the details involved with
- startup/initialization of the Tcl library, focused on the activities
- of Tcl_FindExecutable().
-
- * generic/tclIO.c: Removed bogus claim in comment that encoding
- "iso8859-1" is "built-in" to Tcl.
-
- * generic/tclInt.h: Created a new struct ProcessGlobalValue,
- * generic/tclUtil.c: routines Tcl(Get|Set)ProcessGlobalValue, and
- function type TclInitProcessGlobalValueProc. Together, these take care
- of the housekeeping for "values" (things that can be held in a
- Tcl_Obj) that are global across a whole process. That is, they are
- shared among multiple threads, and epoch and mutex protection must
- govern the validity of cached copies maintained in each thread.
-
- * generic/tclNotify.c: Modified TclInitNotifier() to tolerate being
- called multiple times in the same thread.
- * generic/tclEvent.c: Dropped the unused argv0 argument to
- TclInitSubsystems(). Removed machinery to unsure only one
- TclInitNotifier() call per thread, now that that is safe. Converted
- Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue, and moved them to
- tclEncoding.c.
- * generic/tclBasic.c: Updated caller.
-
- * generic/tclInt.h: TclpFindExecutable now returns void.
- * unix/tclUnixFile.c:
- * win/tclWinFile.c:
- * win/tclWinPipe.c:
-
- * generic/tclEncoding.c: Built new encoding search initialization on a
- foundation of ProcessGlobalValues, exposing new routines
- Tcl(Get|Set)EncodingSearchPath. A cache of a map from encoding name to
- directory pathname keeps track of where encodings are available for
- loading. Tcl_FindExecutable greatly simplified into just three
- function calls. The "library path" is now misnamed, as its only
- remaining purpose is as a foundation for the default encoding search
- path.
-
- * generic/tclInterp.c: Inlined the initScript that is evaluated by
- Tcl_Init(). Added verification after initScript evaluation that Tcl
- can find its installed *.enc files, and that it has initialized
- [encoding system] in agreement with what the environment expects.
- [tclInit] no longer driven by the value of $::tcl_libPath; it largely
- constructs its own search path now, rather than attempt to share one
- with the encoding system.
-
- * unix/tclUnixInit.c: TclpSetInitialEncodings factored so that a new
- * win/tclWinInit.c: routine TclpGetEncodingNameFromEnvironment can
- reveal that Tcl thinks the [encoding system] should be, even when an
- incomplete encoding search path, or a missing *.enc file won't allow
- that initialization to succeed. TclpInitLibraryPath reworked as an
- initializer of a ProcessGlobalValue.
-
- * unix/tclUnixTest.c: Update implementations of [testfindexecutable],
- [testgetdefenc], and [testsetdefenc].
-
- * tests/unixInit.test: Corrected tests to operate properly even when
- a value of TCL_LIBRARY is required to find encodings.
-
- * generic/tclInt.decls: New internal stubs: TclGetEncodingSearchPath,
- TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment. These
- are candidates for public exposure by future TIPs.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclTest.c: Updated [testencoding] to use
- * tests/encoding.test: Tcl(Get|Set)EncodingSearchPath. Updated tests.
-
-2004-11-30 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Corrected the regular expressions that match a
- time zone to allow for time zones specified as +HH or -HH.
- * tests/clock.test: Added regression test case for the above issue.
- Thanks to Rolf Ade for reporting this issue [https://wiki.tcl-lang.org/page/Parsing+ISO8601+dates+and+times]
- * win/tclWinDde.c (Tcl_DdeObjCmd): Corrected a typo that caused a
- compilation failure on VC++.
-
-2004-11-29 Andreas Kupries <andreask@activestate.com>
-
- * win/Makefile.in (install-libraries): Brought entry '2004-10-26 Don
- Porter (Tcl Modules)' into the windows world, actually the
- win/configure buildsystem. The other windows buildsystems (.vc, .bc)
- still have to be updated as well.
-
-2004-11-26 Andreas Kupries <andreask@activestate.com>
-
- * win/tclWinDde.c (ExecuteRemoteObject): Removed bogus semicolon found
- at the end of the header for the function definition, terminating it
- early and preventing a compile. This is likely a fix for '2004-11-25
- Donal'. I have to conclude that it is also unknown if the other
- changes to this file actually pass the testsuite. Running testsuite
- ... They don't. winDde-6.1 fails. This is only a message discrepance,
- i.e. not too bad. Leaving resolution of that to Pat and Donal.
-
-2004-11-26 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl (tcl_findLibrary): Made sure the uniquifying
- operations on the search path does not also normalize. [Bug 1072136]
-
-2004-11-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/configure.in: Simplify the code to check for correctness of
- strstr, strtoul and strtod.
- * unix/tcl.m4 (SC_TCL_CHECK_BROKEN_FUNC): Split a complex stanza out
- of configure.in into its own function. Also force it to do the right
- thing with caching of results of AC_TRY_RUN to deal with issue raised
- in [Patch 1073524]
-
- * doc/foreach.n: Added simple example. [FRQ 1073334]
-
-2004-11-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclProc.c (TclObjInterpProc): Make it so that only
- * generic/tclIndexObj.c (Tcl_WrongNumArgs): [proc] instances do
- * tests/indexObj.test (indexObj-5.7): quoting of their first
- arguments, so keeping [Bug 942757] fixed and making [Bug 1066837] be
- fixed as well. Done with a load of #ifdef-ery because this hack is so
- ugly nobody should keep it around once Itcl's fixed.
-
-2004-11-25 Reinhard Max <max@suse.de>
-
- * tests/tcltest.test: The order in which [glob] returns the file names
- is undefined, so tests should not depend on it.
-
-2004-11-25 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * doc/Thread.3:
- * doc/Notifier.3: Added changes from the core-8-4-branch
-
-2004-11-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/dde.n: Synchronized the documentation of the commands with the
- header of the docs and what the package actually does. Thanks to
- Andreas Kupries for spotting this.
- * win/tclWinDde.c (Tcl_DdeObjCmd): Much cleanup of argument parsing
- code.
-
-2004-11-24 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclPort.h: Relative include of tclWinPort.h returned as it
- was requiring me set -I$(tcl_root)/win for my extensions that need to
- include tclInt.h and doesn't appear to serve any purpose for windows
- builds.
-
-2004-11-24 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tcl.m4 (SC_ENABLE_THREADS): Corrected bad check for 3-argument
- readdir_r [Bug 1001325].
- * unix/configure: Regenerated.
- * unix/tclUnixNotfy.c: Corrected all uses of 'select' to manage their
- masks using the FD_CLR, FD_ISSET, FD_SET, and FD_ZERO macros rather
- than bit-whacking that failed under Solaris-Sparc-64. [Bug 1071807]
- * win/tclWinInit.c (TclpInitLibraryPath): Removed unused vars 'pathc'
- and 'pathv' that caused compilation problems on VC++ with
- --enable-symbols.
-
-2004-11-24 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_ENABLE_THREADS): Corrected failure to determine the
- number of arguments for readdir_r on SunOS systems. [Bug 1071701]
-
- * unix/configure: autoconf-2.57
-
- * generic/tclCmdIL.c (InfoVarsCmd): Corrected segfault in new
- * tests/info.test (info-19.6): trivial matching branch [Bug 1072654]
-
-2004-11-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/man2html.tcl, tools/man2html1.tcl: Update to use Tcl 8.4.
- * tools/man2html2.tcl: Fix broken .SS handling.
-
-2004-11-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/Makefile.in: Add (commented-out) code to integrate tclConfig.h
- into the dependency tree and 'make distclean'. [Bug 1068171]
-
- * generic/tclResult.c (Tcl_AppendResultVA): Remove call to
- Tcl_GetStringResult to speed up repeated calls to Tcl_AppendResult
- with the side effect that code that wants to access interp->result
- should always call Tcl_GetStringResult first. See [Patch 1041072]
- discussion for more details.
-
-2004-11-22 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_TCL_64BIT_FLAGS): Define HAVE_TYPE_OFF64_T only when
- off64_t, open64(), and lseek64() are defined. IRIX 5.3 is known to not
- include an open64 function. [Bug 1030465]
-
-2004-11-22 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2 argument version of
- readdir_r that is known to exists under IRIX 5.3.
- * unix/tclUnixThrd.c (TclpReaddir): Use either 2 arg or 3 arg version
- of readdir_r. [Bug 1001325]
-
-2004-11-22 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixInit.c (TclpInitLibraryPath): Purged dead code that used
- * win/tclWinInit.c (TclpInitLibraryPath): to extend the "library
- path". Search path construction for init.tcl is now done within the
- [tclInit] proc.
- * generic/tclInterp.c: Restored several directories to the search
- * tests/unixInit.test: path used to locate init.tcl within [tclInit].
- This change does not restore any directories to the encoding search
- path, so should still avoid the price of an unreasonably large number
- of filesystem accesses during encoding initialization at startup
- [Bug 976438]
-
-2004-11-22 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix and new test for [Bug 1043129] in the
- * tests/fileSystem.test: treatment of backslashes in file join on
- Windows.
-
-2004-11-21 Don Porter <dgp@users.sourceforge.net>
-
- * doc/AddErrInfo.3: Typo corrections (Thanks Daniel South).
- * doc/interp.n:
-
-2004-11-19 Don Porter <dgp@users.sourceforge.net>
-
- * doc/AddErrInfo.3: Docs for Tcl_(Get|Set)ReturnOptions. [TIP 227]
-
- * doc/AddErrInfo.3:
- * doc/Async.3: Documentation updates to replace references
- * doc/BackgdErr.3: to global variable ::errorInfo and ::errorCode
- * doc/SaveResult.3: and to the ::bgerror command with references
- * doc/after.n: to their preferred replacements, the
- * doc/bgerror.n: -errorinfo and -errorcode return options,
- * doc/error.n: the Tcl_*InterpState routines, and the
- * doc/exec.n: [interp bgerror] command.
- * doc/exit.n:
- * doc/fileevent.n:
- * doc/interp.n:
- * doc/return.n:
- * doc/tclvars.n:
- * doc/update.n:
-
- * tests/unixInit.test: Removed "knownBug" constraints to prompt bug
- fixing before 8.5a2 release.
-
-2004-11-19 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile:
- * unix/configure.in:
- * unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection of tcl
- framework build when determining tclLibPath from overloaded
- TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088]
-
- * unix/configure: autoconf-2.57
- * unix/tclConfig.h.in: autoheader-2.57
-
-2004-11-18 Don Porter <dgp@users.sourceforge.net>
-
- * doc/SaveResult.3: Documentation for Tcl_*InterpState (TIP 226).
-
- * generic/tclEvent.c (HandleBgErrors): Simplified program flow.
-
- * tests/basic.test: Updated functional (not testing) uses of
- * tests/io.test: [bgerror] to make use of [interp bgerror].
- * tests/socket.test:
- * tests/timer.test:
-
- * tests/interp.test (interp-36.*): [interp bgerror] tests.
-
- * generic/tclInterp.c: Corrected [interp bgerror] error messages.
-
-2004-11-18 Reinhard Max <max@suse.de>
-
- * unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of
- * unix/configure.in: [Patch 996085], that introduces
- * unix/Makefile.in: --enable-man-suffix.
-
- * unix/installManPage: added
- * unix/mkLinks.tcl: removed
- * unix/mkLinks: removed
- * unix/configure: generated
-
- * unix/Makefile.in: Don't install tclConfig.h .
-
-2004-11-17 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure.in: The change below reveals that the public data
- type Tcl_StatBuf relies on config information. For now, disabled the
- use of the tclConfig.h file until its full impact on Tcl's interface
- can be assessed.
-
- * unix/configure: autoconf-2.57
-
- * generic/tcl.h: Moved the #include "tclConfig.h" out of
- * generic/tclInt.h: tcl.h. The config settings are not part of
- * generic/tclPort.: the public interface, and having it there
- breaks compiled against uninstalled Tcl and extensions using
- autoconf-2.5*.
-
-2004-11-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring
- -ttycontrol on a channel. [Bug 1067708]
-
-2004-11-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c (TclFSEpochOk): There were two code paths via
- which the thread copy of filesystemEpoch could be synched with the
- master copy, but only one kept the filesystem list cache up to date.
- Fix routes everything through a single code path. [Bug 1035775].
-
-2004-11-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Stop architecture flags to 'ld' from
- getting lost when [load] is disabled. [Bug 1016796]
-
-2004-11-16 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.h:
- * unix/configure.in: changed HAVE_CONFIG_H to HAVE_TCL_CONFIG_H.
-
- * unix/configure: autoconf-2.57
-
-2004-11-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Added comment warning that the old ERR_IN_PROGRESS
- and ERROR_CODE_SET flag values should not be re-used for the sake of
- those extensions that have accessed them.
-
- * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed
- * tests/trace.test (trace-33.1): to permit a variable trace
- created with [trace variable] to be destroyed with [trace remove].
- Thanks to Keith Vetter for the report.
-
-2004-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/tclvars.n: Added section to documentation on global variables
- that are specific to tclsh and wish. [Patch 1065732]
-
-2004-11-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEncoding.c (TableFromUtfProc): correct crash condition
- when TCL_UTF_MAX == 6. [Bug 1004065]
-
-2004-11-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/interp.n: Basic documentation of the TIP#221 API.
-
-2004-11-12 Don Porter <dgp@users.sourceforge.net>
-
- TIP #221 IMPLEMENTATION
- * generic/tclBasic.c: Define [::tcl::Bgerror] in new interps.
- * generic/tclEvent.c: Update Tcl_BackgroundError to make use of the
- registered [interp bgerror] command.
- * generic/tclInterp.c: New [interp bgerror] subcommand.
- * tests/interp.test: syntax tests updated.
-
- TIP #226 IMPLEMENTATION
- * generic/tcl.decls: Stubs for Tcl_(Save|Restore|Discard)InterpState
- * generic/tcl.h: New public opaque type, Tcl_InterpState.
- * generic/tclInt.h: Drop old private declarations. Add
- Tcl(Get|Set)BgErrorHandler
- * generic/tclResult.c: Tcl_*InterpState implementations.
- * generic/tclDictObj.c: Update callers.
- * generic/tclIOGT.c:
- * generic/tclTrace.c:
-
- TIP #227 IMPLEMENTATION
- * generic/tcl.decls: Stubs for Tcl_(Get|Set)ReturnOptions.
- * generic/tclInt.h: Drop old private declarations.
- * generic/tclResult.c: Tcl_*ReturnOptions implementations.
- * generic/tclCmdAH.c: Update callers.
- * generic/tclMain.c:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * unix/tclAppInit.c: Removed tclConfig.h #include, now that tcl.h
- takes care of it for us.
-
- * generic/tclInt.h: Moved verification of ptrdiff_t typedef from
- * generic/tclExecute.c: multiple .c files into one common header where
- * generic/tclVar.c: it is verifiably after tclConfig.h inclusion.
-
-2004-11-12 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.h:
- * generic/tclInt.h:
- * unix/Makefile.in: include tclConfig.h from tcl.h and install it as a
- public header. Normalized compiler include path order to
- -I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR}.
-
- * unix/dltest/Makefile.in: add ${BUILD_DIR}/.. to include path to pick
- up tclConfig.h.
-
- * unix/tclUnixInit.c: moved check for HAVE_CFBUNDLE define after
- #include "tclInt.h" to ensure tclConfig.h has been included.
-
-2004-11-12 Reinhard Max <max@suse.de>
-
- * unix/config.h.in:
- * unix/tclConfig.h.in: renamed
-
- * unix/Makefile.in: Completed support for config header,
- * unix/configure.in: fixed building outside of the unix dir,
- * unix/tclAppinit.c: and reflected the name change of config.h.
- * generic/tclInt.h:
-
- * unix/configure: generated
-
-2004-11-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/config.h.in: Allow configure to put all the C #defs into
- * unix/configure.in: a file (called config.h) so that Unix builds
- * unix/tcl.m4: now take far fewer lines of scrollback to
- * unix/Makefile.in: proceed (making it less likely that any errors
- * generic/tclInt.h: or warnings will get missed).
- * unix/tclAppInit.c: Part of the TIP#34 upgrades.
-
- * unix/tcl.m4, unix/tclUnixPort.h: Check for pthread_attr_get_np in
- <pthread.h> before forcing the use of <pthread_np.h> to make things
- work on NetBSD 2.0. [Bug 1064882]
-
- * doc/binary.n, doc/upvar.n: More minor fixes.
-
-2004-11-12 Daniel Steffen <das@users.sourceforge.net>
-
- * doc/CrtChannel.3:
- * doc/Interp.3:
- * doc/Limit.3:
- * doc/binary.n:
- * doc/dict.n:
- * doc/tm.n:
- * doc/upvar.n: fixed *roff errors uncovered by running 'make html'.
-
- * tools/tcltk-man2html.tcl: added faked support for bullet point
- lists, i.e. *nroff ".IP \(bu" syntax.
-
-2004-11-11 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/fCmd.test:
- * unix/tclUnixFCmd.c (TraverseUnixTree): added option to rewind() the
- readdir() loop whenever the source hierarchy has been modified by
- traverseProc (e.g. by deleting files); this is required to ensure
- complete traversal of the source hierarchy on certain filesystems like
- HFS+. Added test for failing recursive delete on Mac OS X that was due
- to this. [Bug 1034337]
-
- * generic/tclListObj.c (Tcl_ListObjReplace): use memmove() instead of
- manual copy loop to shift list elements. Decreases time spent in
- Tcl_ListObjReplace() from 5.2% to 1.7% of overall runtime of tclbench
- on a ppc 7455 (i.e. 200% speed increase). [Patch 1064243]
-
- * generic/tclHash.c: hoisted some constant pointer dereferences out of
- loops to eliminate redundant loads that the gcc optimizer didn't deal
- with. Decreases time spend in Tcl_FindHashEntry() by 10% over a full
- run of the tcl testuite on a ppc 7455. [Patch 1064243]
-
- * tests/fileName.test:
- * tests/fileSystem.test:
- * tests/io.test:
- * tests/msgcat.test:
- * tests/tcltest.test:
- * tests/unixInit.test: fixed bugs causing failures when running tests
- with -tmpdir arg not set to working dir.
-
- * macosx/Makefile: corrected path to html help inside framework.
- Prevent parallel make from building several targets at the same time.
-
- * macosx/tclMacOSXFCmd.c (struct fileinfobuf): force struct to be
- packed to prevent failures when builing with -malign=natural.
-
-2004-11-10 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixChan.c: [Bug 727786]. Exterminated the code marked
- DEPRECATED. This code has not been used in over a year now, and we
- have no complaints.
-
-2004-11-08 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c: The pipe channel driver now respects the -blocking
- option when closing is the same way the UNIX side works. This is to
- avoid a hung shell when exiting due to open pipes that refuse to close
- in a graceful manner.
- * doc/open.n: Added a note about -blocking 0 and lack of exit status
- as it had never been documented. [Bug 947693]
-
- ***POTENTIAL INCOMPATIBILITY***
-
- Scripts that use async pipes on windows, must (like the UNIX side) set
- -blocking to 1 before calling [close] to receive the exit status.
-
-2004-11-07 David Gravereaux <davygrvy@pobox.com>
-
- * tests/winFile.test: added contraint to winFile-4.0 to prevent it
- being run on NT4 [Bug 981829]
-
-2004-11-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/reg.test: Major reorganization so that this file is much
- easier for a normal Tcl maintainer to comprehend. The test flags are
- still very cryptic, but they appear to have to be that way. The number
- of skipped tests has increased, but now the skipped tests have much
- more meaningful content.
-
- * tests/tm.test (genpaths): Add a [file normalize] so we pick up
- Windows drive letters, etc. [Bug 1053568]
-
-2004-11-04 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates toward an 8.5a2 release.
-
-2004-11-03 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (FreeScan): Fixed a bug where scanning "Monday"
- with a base time other than midnight incorrectly carried the base time
- forward.
-
- * test/clock.test (clock-33.{5,5a}): Made the test failure more
- informative.
-
- * tests/clock.test (clock-34.{28,44,45,46}): Removed 'knownBug'
- constraints from tests that no longer fail.
-
- Thanks to Don Porter for reporting these.
-
-2004-11-03 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tcl.h: Moved the preprocessor logic
- * generic/tclDecls.h: from tclInt.h of setting the
- * generic/tclInt.h: TCL_STORAGE_CLASS macro to the
- * generic/tclIntDecls.h: tcl*Decls.h files now that no
- * generic/tclIntPlatDecls.h: use of EXTERN is left in tclInt.h.
- * generic/tclPlatDecls.h: Proto for Tcl_Main moved in tcl.h
- * win/tclWinPort.h: to prior the inclusion of the Stubs
- headers as they are now resetting TCL_STORAGE_CLASS. Removed
- extraineous reset from tclWinPort.h. [Patch 1055668]
-
- * generic/tclCompile.h: Removed extrainious reset of TCL_STORAGE_CLASS
- missed in my last edit.
-
-2004-11-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl ([unknown]): Corrections to the 2004-10-25 mods to
- Aunt ??? in [unknown]. Flaws revealed by Itcl test suite, which still
- apparently relies on this brokenness. Also added comment suggesting
- the error message that any code using this hack *ought* to receive in
- reply.
-
- * generic/tclTrace.c (TclCallVarTraces): Improved ability to debug
- * tests/incr-old.test (incr-old-2.6): errors during variable
- * tests/incr.test (incr-{1,2}.28): traces by preserving the
- * tests/set.test (set-{2,4}.4): -errorinfo data.
- * tests/trace.test (trace-33.1): [Bug 527164]
-
-2004-11-02 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclInt.h: added a check for #ifdef __cplusplus around the
- #define of MODULE_SCOPE. About the only time it would be problem is
- when someone is statically linking to Tcl and accessing internals from
- a C++ file and has name mangling issues from the lack of "C" after
- 'extern' [Patch 1055668].
- * generic/tclCompile.h: Exchanged use of the EXTERN macro to the new
- MODULE_SCOPE macro. Lowered exported internals count by 35. [Patch
- 1055668]
- * win/tclWinInt.h:
- * win/tclWinPort.h: exported internals dropped by a count of 14.
- * generic/tclFileSystem.h: Added use of MODULE_SCOPE on protos.
- * generic/tclRegexp.h: manipulating TCL_STORAGE_CLASS unnecessary.
-
-2004-11-02 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected some misleading
- * tests/tcltest.test (tcltest-26.1,2): displays of ::errorInfo and
- ::errorCode information when the -setup, -body, and/or -cleanup scripts
- return an unexpected return code. Thanks to Robert Seeger for the fix.
- [RFE 1017151].
-
-2004-11-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Improved version of the
- NaN fix from Miguel Sofer. [Bug 761471]
-
-2004-11-02 Kevin Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Cuiaba: Change to DST rules for
- * library/tzdata/America/Havana: autumn of 2004.
- [ftp://elsie.nci.nih.gov/pub/tzdata2004g.tar.gz]
-
- * tools/tclZIC.tcl: Updated to be compatible with recent changes in
- library/clock.tcl.
-
-2004-11-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFile.c: Simplify TclpUtime to use Tcl_FSGetNativePath, and
- add comments.
-
-2004-11-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInt.h: Change uses of EXTERN to MODULE_SCOPE (defined in
- this file too to be 'extern' if not overridden) as nothing declared in
- tclInt.h is supposed to be visible outside the Tcl core. If there *is*
- anything that extensions are actually using, we can open this up later
- on. [Patch 1055668]
-
- * doc/CrtChannel.3 (Tcl_GetChannelMode): Add synopsis. [Bug 1058446]
-
-2004-11-01 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinFile.c (FromCTime, TclpUtime): Replaced a call to the
- Posix 'utime' function with calls to Windows-API equivalents, to avoid
- a bug where the VC++ versions misconvert times across a Daylight
- Saving Time boundary. [Bug 926106]
- * win/tclWinInt.h (TclWinProcs):
- * win/tclWin32Dll.c (asciiProcs, unicodeProcs): Removed now-unused
- reference to 'utime'.
- * tests/cmdAH.test (cmdAH-24.12): Added test case for the above bug.
-
-2004-11-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Make INST_EQ and friends
- handle NaN correctly in all cases. [Bug 761471]
-
- * generic/tclNamesp.c (NamespaceInscopeCmd): Make the error message
- generation the same as in NamespaceEvalCmd().
- (Tcl_Import): Rationalized to use Tcl_EvalObjv().
-
-2004-10-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/io.test (io-40.3): Convert umask2 test constraint into a form
- that most people will be able to satisfy.
-
- * tests/cmdAH.test (cmdAH-8.45): Removed broken test constraint. It
- didn't do what it was intended to do, and it implied the other correct
- constraint. [Bug 1053908]
-
- * generic/tclCmdIL.c (InfoGlobalsCmd):
- * tests/info.test (info-8.4): Strip leading global-namespace
- specifiers from the pattern argument. [Bug 1057461]
-
-2004-10-30 Kevin Kenny <kennykb@acm.org>
-
- * generic/clock.c: Replaced WIN32 macro with __WIN32__. [Bug 1054357].
- Thanks to David Gravereaux for the patch.
- * win/tclWinFile.c: Removed a long-standing bug that causes incorrect
- conversion between file time and UTC time if the file time is recorded
- in a different Daylight Saving Time status than the current one. [Bug
- 926106]
-
-2004-10-29 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Correct reaction to errors in the
- obsolete processCmdLineArgsHook. [Bug 1055673]
- * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.7
- * unix/Makefile.in:
- * tests/all.tcl: Update to use [tcltest::configure].
-
-2004-10-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * library/tm.tcl (::tcl::tm::*): Use the core proc engine to generate
- the wrong-num-args error messages for the path ensemble.
-
- Ensembles can now (sometimes) rewrite the error messages of their
- subcommands so they appear more like the arguments that the user
- passed to the ensemble. Below is a description of changes involved in
- doing this.
-
- * tests/namespace.test (namespace-50.*): Tests of ensemble subcommand
- error message rewriting.
- * generic/tclProc.c (TclObjInterpProc): Make procedures implement
- their wrong-num-args message using Tcl_WrongNumArgs instead of
- something baked-at-home.
- * generic/tclNamesp.c (TclIsEnsemble, NsEnsembleImplementationCmd):
- Added test of ensemble-hood (available to rest of core) and made
- ensembles set up the rewriting for Tcl_WrongNumArgs to take advantage
- of.
- * generic/tclInt.h (Interp.ensembleRewrite): Extra fields.
- * generic/tclIndexObj.c (Tcl_WrongNumArgs): Add knowledge of what is
- going on in ensembles' command rewriting so this command can generate
- the right error message itself.
- * generic/tclBasic.c (Tcl_CreateInterp, TclEvalObjvInternal): Added
- code to initialize (as empty) the rewriting fields and reset them when
- we leak outside an ensemble implementation.
-
-2004-10-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_START_CMD):
- * tests/execute.test (execute-8.3): fix for execution stack corruption
- [Bug 1055676]. Credit dgp for detective work and fix.
-
-2004-10-27 Don Porter <dgp@users.sourceforge.net>
-
- * tests/socket.test (socket-13.1): Balanced [makeFile] and
- [removeFile] commands.
-
- * tests/clock.test: Correct duplicate test names.
- * tests/namespace.test:
- * tests/string.test:
- * tests/io.test (io-50.4): Use namespace variables.
-
-2004-10-27 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclInt.decls: The following 9 functions were moved from
- * generic/tclInt.h: tclInt.h to the private/int Stubs table for
- * generic/tclIntDecls.h: use by the test suite. As tclTest.obj is
- * generic/tclStubInit.c: linked to the shell, these functions need
- "blessed" status so as to always be exported from the library. Being
- placed in the Stubs table guarantees this [Bug 1054748]:
- TclpObjRemoveDirectory, TclpObjCopyDirectory,
- TclpObjCreateDirectory, TclpObjDeleteFile,
- TclpObjCopyFile, TclpObjRenameFile,
- TclpObjStat, TclpObjAccess,
- TclpOpenFileChannel
-
- * tests/registry.test: Fixed test files to load the correct
- * tests/winDde.test: registry and dde packages by using the info
- * win/Makefile.in: from makefiles to tell tcltest where to load
- * win/makefile.vc: them from. This avoids grabbing the wrong
- package from $auto_path which might be the install point rather than
- the dev location. Kudos to Jennifer Hom for adding -load and
- -loadfile to the tcltest package. [Bug 926088]
-
- * win/tclWinThrd.c (TclFinalizeLock): release the critical section
- before deleting it. [Bug 731778]
-
- * generic/tcl.h: Removed the file level 'extern "C" {' and the
- coresponding closing block as it serves no purpose given that all the
- function prototypes have the proper extern usage already.
-
- * unix/tclAppInit.c: When built as tcltest, TclThread_Init was
- * win/tclAppInit.c: getting called twice. First by Tcltest_Init,
- then again in Tcl_AppInit. The call from Tcl_AppInit is now removed.
-
-2004-10-27 Andreas Kupries <andreask@activestate.com>
-
- * tests/tm.test: Expanded on the testsuite entered by Donal.
- * library/tm.tcl: Even found bugs, these have been corrected.
-
-2004-10-26 Kevin Kenny <kennykb@acm.org>
-
- * tests/format.test (format-19.1): Additional regression test for [Bug
- 868489].
-
-2004-10-27 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/*.n: Many small general documentation fixes.
-
-2004-10-26 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclPipe.c (TclCleanupChildren): bad cast of resolvedPid
- caused PIDs on win95 to go negative. winpipe-4.2 brought this to the
- surface. Fixed with sprintf in place of TclFormatInt. Thanks to hgiese
- [Patch 767676]
-
-2004-10-26 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl (::tcl::tm::Defaults): Added a second [file dirname]
- around the location of the executable. This fixes [Bug 1038705].
- Instable of a bogus "foo/bin/lib" we now have the correct "foo/lib" as
- a base path for modules.
-
-2004-10-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c (Tcl_SubstObj): Fix for failed subst-12.3 test
- * tests/subst.test (subst-12.3-5): More tests for Bug 1036649.
-
- * unix/Makefile.in (install-libraries): Updated the installation of
- the http, msgcat, and tcltest packages to install as Tcl Modules on
- Unix systems. Other platform Makefiles still need updating. [Patch
- 1054370]
-
- * tests/basic.test: Added missing constraints.
- * tests/compile.test:
- * tests/fileSystem.test:
-
- * tests/init.test (init-2.8): Updated to not rely on http package.
-
-2004-10-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclVar.c: removed more direct references to the VAR flags,
- replaced with access macros.
-
-2004-10-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/expr.n: Clarified that non-num/non-bool literals require
- quoting. [Bug 1027849]. Also listed booleans as acceptable values.
-
-2004-10-26 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (FreeScan): Fixed a bug that caused relative days
- of the week in free-form [clock scan] to be evaluated in the wrong
- time zone.
- * tests/clock.test (clock-31.[456]): Made sure that there isn't an
- env(TZ) or env(TCL_TZ) lying around that will override the time zone
- that we're trying to establish with the simulated registry.
- Both problems reported as [Bug 1054101].
-
-2004-10-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/string.n (map): Rewrote to clarify that we don't just map single
- characters. [Bug 1048005]
- * doc/info.n (procs): Clarified that the pattern argument may have
- namespace separators in it. [Bug 1047928]
-
- * tests/cmdAH.test (cmdAH-8.45): Simplify in the hope that the reasons
- for [Bug 1053908] will become clearer.
-
-2004-10-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode):
- Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer
- needed for protection because routines like Tcl_SetErrorCode() and
- Tcl_AddErrorInfo() can no longer re-enter bytecode execution.
-
- * generic/tclResult.c (TclProcessReturn): Bug fix. Be sure that a
- missing -errorinfo option when code == TCL_ERROR causes the errorInfo
- field to get reset.
-
- * tests/thread.test (thread-4.4): Test depended on a ::errorInfo value
- initialized to "". Added code to test to setup that requirement.
-
- * library/auto.tcl: Purged Tcl's script library of all
- * library/clock.tcl: remaining references to global vars
- * library/init.tcl: ::errorInfo and ::errorCode.
-
- * generic/tclMain.c (Tcl_Main): Updated to make use of
- TclGetReturnOptions instead of ::errorInfo variable.
-
- * generic/tclInterp.c (tclInit): Bug fix. Access dict variables with
- [dict get], not array syntax.
-
-2004-10-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/tm.test: Rewrote the tests to actually perform syntax checks
- on the public API. Added a new test (currently failing) to indicate
- that the test suite is not complete yet.
- * library/tm.tcl (path): Rewrote to turn this command into an ensemble
- to make it faster and simpler.
-
-2004-10-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclTrace.c: defined new macros to get/set the flags of
- variables. The only files that still access the flag values directly
- are tclCompCmds.c, tclCompile.c, tclProc.c and tclVar.c
-
-2004-10-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo): Shift
- the initialization of errorCode to NONE to more central location.
-
- * generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
- Rewrite to build on the new TclGet/SetReturnOptions routines.
-
- * generic/tclResult.c (TclGetReturnOptions): Add call to
- Tcl_AddObjErrorInfo to be sure error fields are initialized.
-
- * generic/tclResult.c (TclTransferResult): Rewrite to build on the new
- TclGet/SetReturnOptions routines.
-
-2004-10-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/tm.n: Tightened up the documentation.
- * tests/tm.test: Created (with partially dummy content) so TIP#189 can
- be marked Final.
-
- * generic/tclNamesp.c (NsEnsembleImplementationCmd): Make ensembles
- cut their implementations out of error traces. This is the right thing
- to do more often than not.
-
-2004-10-22 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Fixed a typo where the fallback time zone became
- ::localtime instead of :localtime. Fixed a bug where time zone names
- containing hyphens could not be loaded.
- * tests/clock.test: Added regression test cases that covers both bugs.
- Thanks to Todd M. Helfter <tmh@jumpgate.itsp.purdue.edu> for finding
- these bugs.
-
-2004-10-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TclCompEvalObj, Tcl_ExprObj):
- * generic/tclProc.c (TclProcCompileProc): Always call object
- freeIntRepProc's in the same way.
-
-2004-10-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: fixed bug in commit of 2004-07-23, which was
- causing a leak of Proc structures and failure of compile-12.1. Two
- lines were 'zombies' from the previous way localVarNames worked.
- Credit dgp for finding this.
-
-2004-10-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h (Interp):
- * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
- * generic/tclResult.c (GetKeys,ReleaseKeys,etc.): Moved the key values
- of the return options dictionary out of private fields of the Interp
- struct and into thread-static values managed in tclResult.c.
-
- * generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd): Updated to
- call the new TclGet/SetReturnOptions routines to do much of their
- work.
-
- * generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions):
- * generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions): New
- utility routines to get/set the return options of an interp. Intent is
- that these routines will be converted to public routines after TIP
- approval.
-
- * generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions):
- * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions): Move
- internal utility routines from tclCmdMZ.c to tclResult.c.
-
- * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp):
- * generic/tclResult.c (TclTransferResult): Rework so that
- iPtr->returnOpts can be NULL when there are no special options.
-
- * generic/tclResult.c (TclRestoreInterpState): Plug potential memory
- leak.
-
-2004-10-21 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclBasic.c: Various changes to [clock format] that,
- * generic/tclClock.c: together, make it roughly twice as fast
- * generic/tclInt.h: while all tests in the test suite
- * library/clock.tcl: continue to pass.
-
-2004-10-20 Andreas Kupries <andreask@activestate.com>
-
- * win/Makefile.in (install-msgs): Fixed a problem with the
- * win/Makefile.in (install-tzdata): installation of timezone data and
- message catalogs. They used the installed tcl library directory, not
- the source library. Before it was installed. Switched to source lib
- dir. Thanks to Kevin for the help in figuring this out.
-
-2004-10-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclThreadTest.c (ThreadEventProc): Corrected subtle bug
- where the returned (char *) from Tcl_GetStringResult(interp) continued
- to be used without copying or refcounting, while activity on the
- interp continued. That's not safe, and recent changes demonstrated the
- lack of safety with failing tests thread-4.3 and thread-4.5.
-
-2004-10-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclDictObj.c (DictWithCmd): Make sure all paths (that are
- not themselves error paths) do not lose the result code.
-
-2004-10-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h (Tcl*InterpState): New internal routines
- * generic/tclResult.c (Tcl*InterpState): TclSaveInterpState,
- TclRestoreInterpState, and TclDiscardInterpState are superior
- replacements for Tcl_(Save|Restore|Discard)Result. Intent is that
- these routines will be converted to public routines after TIP
- approval. Interfaces for these routines were shamelessly stolen from
- Itcl.
-
- * generic/tclBasic.c (TclEvalObjvInternal):
- * generic/tclDictObj.c (DictUpdateCmd, DictWithCmd):
- * generic/tclIOGT.c (ExecuteCallback):
- * generic/tclTrace.c (Trace*Proc,TclCheck*Traces,TclCallVarTraces):
- Callers of Tcl_*Result updated to call the new routines. The calls
- were relocated in several cases to perform save/restore operations
- only when needed.
-
- * generic/tclEvent.c (HandleBgErrors):
- * generic/tclFCmd.c (CopyRenameOneFile): Calls to Tcl_*Result that
- were eliminated because they appeared to serve no useful purpose,
- typically saving/restoring an error message, only to throw it away.
-
-2004-10-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp):
- * generic/tclCmdAH.c (Tcl_CatchObjCmd):
- * generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn):
- * generic/tclCompCmds.c (TclCompileReturnCmd):
- * generic/tclExecute.c (TclCompEvalObj):
- * generic/tclInt.h (Interp):
- * generic/tclProc.c (TclUpdateReturnInfo): Place primary storage of
- the -level and -code information in private fields of the Interp
- struct, rather than in a DictObj. This should significantly improve
- performance of TclUpdateReturnInfo.
-
-2004-10-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclResult.c: removed unused variable [Bug 1048588]. Thanks
- to Daniel South.
-
-2004-10-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (TclProcessReturn): Now that primary
- * generic/tclProc.c (TclUpdateReturnInfo): storage for the
- errorInfo and errorCode values are internal fields, we can set them at
- the time of the [return] command, and not have to wait until the
- specified number of "-level"s have popped.
-
- * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp)
- (TclEvalObjvInternal, Tcl_LogCommandInfo, TclAddObjErrorInfo):
- * generic/tclCmdAH.c (Tcl_CatchObjCmd):
- * generic/tclEvent.c (BgError, ErrAssocData, Tcl_BackgroundError)
- (HandleBgErrors, BgErrorDeleteProc):
- * generic/tclExecute.c (TclCreateExecEnv, TclDeleteExecEnv):
- * generic/tclIOUtil.c (comments only):
- * generic/tclInt.h (ExecEnv,Interp, ERR_IN_PROGRESS):
- * generic/tclInterp.c ([tclInit]):
- * generic/tclMain.c (comments only):
- * generic/tclNamesp.c (Tcl_CreateNamespace, Tcl_DeleteNamespace)
- (TclTeardownNamespace):
- * generic/tclProc.c (TclUpdateReturnInfo):
- * generic/tclResult.c (Tcl_ResetResult, TclTransferResult):
- * generic/tclTrace.c (CallVarTraces):
- Reworked management of the "errorInfo" data of an interp. That
- information is now primarily stored in a new private (Tcl_Obj *) field
- of the Interp struct, rather than using a global variable ::errorInfo
- as the primary storage. The ERR_IN_PROGRESS flag bit value is no
- longer required to manage the value in its new location, and is
- removed. Variable traces are established to support compatibility for
- any code expecting the ::errorInfo variable to hold the information.
-
- ***POTENTIAL INCOMPATIBILITY***
- Code that sets traces on the ::errorInfo variable may notice a
- difference in timing of the firing of those traces. Code that uses the
- value ERR_IN_PROGRESS.
-
-2004-10-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP#217 IMPLEMENTATION
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Add -indices option from James
- Salsman. [Patch 1017532]
-
- * generic/tclUtil.c (TclMatchIsTrivial): Detect degenerate cases of
- glob matching that let us avoid scanning through hash tables.
- * generic/tclCmdIL.c (InfoCommandsCmd, InfoGlobalsCmd, InfoProcsCmd):
- (InfoVarsCmd): Use this to speed up some [info] subcommands.
-
-2004-10-12 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Campo_Grande:
- * library/tzdata/America/Cuiaba:
- * library/tzdata/America/Sao_Paulo
- * library/tzdata/America/Argentina/Mendoza:
- * library/tzdata/America/Argentina/San_Juan:
- Synchronized to Olson's 'tzdata2004e'.
-
-2004-10-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP#201 AND TIP#212 IMPLEMENTATIONS
-
- * doc/dict.n, doc/expr.n: Documentation for new functionality.
- * tests/expr.test: Basic tests of 'in' and 'ni' behaviour.
- * tests/dict.test (dict-21.*,dict-22.*): Tests for [dict update] and
- [dict with].
- * generic/tclExecute.c (TclExecuteByteCode): Implementation of the
- INST_LIST_IN and INST_LIST_NOT_IN bytecodes.
- * generic/tclParseExpr.c (GetLexeme): Parse the 'in' and 'ni'
- operators for TIP#201.
- * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of
- implementation of TIP#212; docs and tests still to do...
-
-2004-10-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTest.c (TestsetobjerrorcodeCmd): Simplified.
-
-2004-10-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c:
- * generic/tclFileSystem.h:
- * generic/tclIOUtil.c:
- * generic/tclPathObj.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c:
- * tests/fileName.test:
- * tests/winFCmd.test: code reorganization for better generic/platform
- code splitting [Bug 925620] removing the need for several #ifdef's,
- and tests and fix for an unreported Windows glob problem ('glob -dir
- C: -tails *').
-
-2004-10-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * *.3: Convert CONST to const and VOID to void so we document how
- people should actually use the Tcl API and not the compatibility hacks
- that it has to have.
-
- * doc/man.macros, *.3: Update .AS macro so it can know how wide to
- make the third column of the argument list. Update documentation for C
- API (only users) to take advantage of this.
-
- * doc/FileSystem.3: Formatting fixes for greater documentation
- clarity.
-
-2004-10-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclFileName.c (DoGlob, TclGlob): Stop messy sharing of
- interpreter result and instead use a private object for collecting the
- result of the glob. This simplifies TclGlob quite a lot.
- * generic/tclIOUtil.c (Tcl_FSMatchInDirectory): Simplify by removing
- some nesting. Also standardize variable names.
- (FsAddMountsToGlobResult): Force updates to the list to be done
- in-place, putting a side-condition of non-shared-ness on the resultPtr
- argument to Tcl_FSMatchInDirectory, but everything would have broken
- before if that was shared *anyway*.
-
- * generic/tclEncoding.c (LoadTableEncoding): Removed reference to Tcl
- interpreter; it wasn't needed as direct object use is more efficient.
-
- * generic/tclPathObj.c: Made this file follow the style rules in the
- Engineering Manual more closely, and also take advantage of the
- internal object manipulation macros more.
-
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reorganized to have fewer
- magic flag variables and to separate the code that scans for a match
- from the code that processes a match body.
-
-2004-10-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c:
- * generic/tclBinary.c:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclCompExpr.c:
- * generic/tclDictObj.c:
- * generic/tclEncoding.c:
- * generic/tclExecute.c:
- * generic/tclFCmd.c:
- * generic/tclHistory.c:
- * generic/tclIndexObj.c:
- * generic/tclInterp.c:
- * generic/tclIO.c:
- * generic/tclIOCmd.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclPkg.c:
- * generic/tclResult.c:
- * generic/tclScan.c:
- * generic/tclTimer.c:
- * generic/tclTrace.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
- * unix/tclUnixFCmd.c:
- * unix/tclUnixPipe.c:
- * win/tclWinDde.c:
- * win/tclWinFCmd.c:
- * win/tclWinPipe.c:
- * win/tclWinReg.c:
- It is a poor practice to directly set or append to the value of the
- objResult of an interp, because that value might be shared, and in
- that circumstance a Tcl_Panic() will be the result. Searched for
- example of this practice and replaced with safer alternatives, often
- using the Tcl_AppendResult() routine that dkf just rehabilitated.
- * library/dde/pkgIndex.tcl: Bump to dde 1.3.1
- * library/reg/pkgIndex.tcl: Bump to registry 1.1.5
-
-2004-10-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/SetResult.3: Made Tcl_AppendResult non-deprecated; better that
- people use it than most of the common alternatives!
- * generic/tclResult.c (Tcl_AppendResultVA): Make this work better with
- Tcl_Objs. [Patch 1041072]
- (Tcl_SetResult, Tcl_AppendElement): Change string to stringPtr to
- avoid C++ keywords.
-
-2004-10-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclObjInvoke): More simplification of the
- TclObjInvoke routine toward unification with the rest of the
- evaluation stack.
-
- * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp)
- (TclEvalObjvInternal, Tcl_LogCommandInfo):
- * generic/tclCmdAH.c (Tcl_CatchObjCmd):
- * generic/tclEvent.c (BgError, Tcl_BackgroundError, HandleBgErrors):
- * generic/tclInt.h (Interp, ERROR_CODE_SET):
- * generic/tclNamesp.c (Tcl_CreateNamespace, Tcl_DeleteNamespace)
- (TclTeardownNamespace):
- * generic/tclResult.c (Tcl_ResetResult, Tcl_SetObjErrorCode)
- (TclTransferResult):
- * generic/tclTrace.c (CallVarTraces):
- Reworked management of the "errorCode" data of an interp. That
- information is now primarily stored in a new private (Tcl_Obj *) field
- of the Interp struct, rather than using a global variable ::errorCode
- as the primary storage. The ERROR_CODE_SET flag bit value is no longer
- required to manage the value in its new location, and is removed.
- Variable traces are established to support compatibility for any code
- expecting the ::errorCode variable to hold the information.
-
- ***POTENTIAL INCOMPATIBILITY***
- Code that sets traces on the ::errorCode variable may notice a
- difference in timing of the firing of those traces.
-
- * generic/tclNamesp.c (Tcl_PopCallFrame): Removed Bug 1038021
- workaround. That bug is now fixed.
-
-2004-10-04 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/clock.test (clock-34.*): Removed an antibug that forced
- comparison of [clock scan] results with the :localtime time zone. Now
- that [clock scan] uses the current time zone instead, the antibug
- caused several tests to fail. [Bug 1038554]
-
-2004-10-04 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclParseExpr.c (GetLexeme): Ensure that the 'eq' and 'ne'
- operators are followed by non-alphabetic characters so lexemes can't
- run together. [Bug 884830]
-
- * doc/DictObj.3, doc/dict.n: Clarified that a dictionary is not
- order-preserving. [Bug 1032243] Also added another example to show off
- more ways of using a dictionary and a few other formatting
- improvements.
-
-2004-10-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclDictObj.c (TraceDictPath, Tcl_DictObjPutKeyList): Add
- support for automatic creation of dictionary paths since that is what
- everyone seems to actually expect of the API! [Bug 1037235]
- (Tcl_DictObjNext): Make calling this after Tcl_DictObjDone non-fatal
- as that simplifies a number of internal APIs. This doesn't break any
- existing working code as it is a case which previously caused a panic.
-
-2004-10-02 Don Porter <dgp@users.sourceforge.net>
-
- * tests/namespace.test (namespace-8.7): Another test for save/restore
- of ::errorInfo and ::errorCode during global namespace teardown.
-
-2004-10-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd):
- * generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level
- references in the level object for speed.
-
-2004-09-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_CreateInterp):
- * generic/tclInt.h (Interp): Removed the flag bit value
- EXPR_INITIALIZED. It was set during interp creation and never tested.
- Whatever purpose it had is in the past.
-
- * generic/tclBasic.c (Tcl_EvalObjEx): Removed the flag bit value
- * generic/tclInt.h (Interp): USE_EVAL_DIRECT. It was used
- * generic/tcLTest.c (TestevalexObjCmd): only in the testing command
- * tests/parser.test (parse-9.2): [testevalex] and nothing in
- the test suite made use of the capability it enabled.
-
- * generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization
- * generic/tclCmdAH.c (Tcl_ErrorObjCmd): of the management of
- * generic/tclCmdMZ.c (TclProcessReturn): the errorCode value.
- * tests/error.test (error-6.4-9):
-
- * generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified
- * tests/namespace.test (namespace-8.5,6): the save/restore of
- ::errorInfo and ::errorCode during global namespace teardown. Revised
- the comment to clarify why this is done, and added tests that will
- fail if this is not done.
-
- * generic/tclResult.c (TclTransferResult): Added safety checks so that
- unexpected undefined ::errorInfo or ::errorCode will not lead to a
- segfault.
-
- * generic/tclTrace.c (TclCallVarTraces): Save/restore the flag values
- * tests/var.test (var-16.1): that define part of the
- interpreter state during variable traces. [Bug 1038021].
-
-2004-09-30 Miguel Sofer <msofer@users.sf.net>
-
- * tests/subst.test (12.1-2): added tests for [Bug 1036649]
-
-2004-09-29 Don Porter <dgp@users.sourceforge.net>
-
- * tests/basic.test (49.*): New tests for TCL_EVAL_GLOBAL.
-
-2004-09-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclVar.c (TclObjLookupVar, TclObjLookupVar):
- (TclObjUnsetVar2, SetArraySearchObj):
- * generic/tclUtil.c (SetEndOffsetFromAny):
- * generic/tclStringObj.c (Tcl_SetStringObj):
- (Tcl_SetUnicodeObj, SetStringFromAny):
- * generic/tclResult.c (ResetObjResult):
- * generic/tclRegexp.c (Tcl_GetRegExpFromObj):
- * generic/tclPathObj.c (TclFSMakePathRelative, SetFsPathFromAny):
- (TclFSMakePathFromNormalized, Tcl_FSNewNativePath):
- * generic/tclObj.c (TclFreeObj, Tcl_SetBooleanObj, SetBooleanFromAny):
- (Tcl_SetDoubleObj, SetDoubleFromAny, Tcl_SetIntObj):
- (SetIntOrWideFromAny, Tcl_SetLongObj, SetWideIntFromAny):
- (Tcl_SetWideIntObj, TclSetCmdNameObj, SetCmdNameFromAny):
- * generic/tclNamesp.c (SetNsNameFromAny, MakeCachedEnsembleCommand):
- * generic/tclListObj.c (Tcl_SetListObj, SetListFromAny):
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
- * generic/tclDictObj.c (SetDictFromAny):
- * generic/tclCompile.c (TclInitByteCodeObj):
- * generic/tclBinary.c (Tcl_SetByteArrayObj, SetByteArrayFromAny):
- * generic/tclInt.h (TclFreeIntRep): Factorize out deletion of object
- internal representation to a shared macro, so simplifying much code.
-
-2004-09-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TclObjInvoke): fix for bogus gcc warning about
- uninitialised variable.
-
-2004-09-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Removed internal routines TclInvoke,
- * generic/tclInt.decls: TclGlobalInvoke, TclObjInvokeGlobal and the
- * tests/basic.test: portion of TclObjInvoke that handles calls
- without TCL_INVOKE_HIDDEN enabled. None of this code is called any
- longer within the core, and the superior public interface,
- Tcl_EvalObjv, is available for any external callers.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclEvent.c (HandleBgErrors): Updated [bgerror] invocations
- to make use of Tcl_Obj based routines, dropping the calls to
- TclGlobalInvoke()
-
-2004-09-27 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c:
- * generic/tclFileSystem.h:
- * generic/tclIOUtil.c:
- * generic/tclPathObj.c:
- * tests/cmdAH.test:
- * tests/fileSystem.test:
- * tests/winFCmd.test: fix to bad error message with 'cd' on windows,
- when permissions are inadequate [Bug 1035462] and to treatment of a
- volume-relative pwd on Windows [Bug 1018980].
-
- * doc/FileSystem.3: added missing Tcl_GlobTypeData documentation [Bug
- 935853]
-
-2004-09-27 Kevin Kenny <kennykb@acm.org>
-
- * compat/strftime.c (Removed):
- * generic/tclClock.c (removed TclClockOldscanObjCmd):
- * generic/tclDate.c (Regenerated):
- * generic/tclGetDate.y:
- * generic/tclInt.decls (removed TclGetDate and TclpStrftime):
- * generic/tclInt.h (removed TclGetDateInfo):
- * generic/tclIntDecls.h (Regenerated):
- * generic/tclStubInit.c (Regenerated):
- * library/clock.tcl:
- * unix/tclUnixTime.c (removed TclpStrftime):
- * win/Makefile.in:
- * win/makefile.bc:
- * win/makefile.bc:
- * win/tcl.dsp:
- Continued refactoring of [clock] for TIP 173 changes. Broke the
- free-form parser apart so that the Bison parser is responsible for
- only parsing, while clock.tcl handles relative times like "next
- Thursday", "next January". This change is needed to make timezones
- other than :localtime and :Etc/UTC work with free-form scanning. This
- change closes out the issue identified as being "for another day" in
- my log message of 2004-09-08. The refactored code also eliminates the
- last known references to TclpStrftime and TclGetDate, so those
- routines (including compat/strftime.c) have been removed. The
- refactoring also has the benefit that all storage in the Bison parser
- is now on the C stack, eliminating any need for mutex protection
- around [clock scan]. Also, changed the Makefiles so that 'make
- gendate' is available on Windows as well as Unix.
-
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): Removed some grubby
- * generic/tclObj.c (SetBooleanFromAny): work-around code that was
- needed only because of Bug 868489.
-
- * generic/tclBasic.c (TclObjInvoke): Removed three unused variables to
- silence a compiler warning in VC++.
-
-2004-09-27 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3: fix to small typo.
-
-2004-09-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclInt.h:
- * generic/tclProc.c:
- * tests/compExpr-old.test:
- * tests/compExpr.test:
- * tests/expr.test:
- * tests/for.test:
- * tests/if.test:
- * tests/incr.test:
- * tests/while.test:
- Report compilation errors at runtime, [Patch 1033689] by dgp.
-
-2004-09-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/dltest/Makefile.in (clean): Fixup make clean rule so that it
- does not delete all files when SHLIB_SUFFIX is set to the empty string
- in a static build. [Bug 1016726]
-
-2004-09-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Corrections to the 2004-09-21 commit
- * generic/tclExecute.c: regarding ERR_ALREADY_LOGGED. That commit
- * generic/tclNamesp.c: caused Tk test send-10.7 to fail. Added
- * tests/namespace.test (25.7,8): tests in the Tcl test suite
- * tests/pkg.test (2.25,26): to catch this error without the aid
- of Tk in the future.
-
- * generic/tclCmdAH.c (Tcl_ExprObjCmd): Simplified the TclObjCmdProc
- of [expr] with a call to Tcl_ConcatObj.
-
-2004-09-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (TclProcessReturn): Support the -errorline
- * generic/tclCompile.c (TclCompileScript): option to [return].
- * tests/compile.test (16.23.*): Use that capability to defer reporting
- * tests/misc.test (1.2): of parse errors until runtime. Updated
- tests to reflect change. [Bug 1032805]
-
-2004-09-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_START_CMD):
- * tests/proc.test (7.2-3): fix for [Bug 729692] was incorrect whenever
- a loop exception was returned.
-
-2004-09-22 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Montevideo: Updated to reflect
- ftp://elsie.nci.nih.gov/pub/tzdata2004d.tar.gz. (Changes to
- Asia/Jerusalem were in the comments only.) [Routine maintenance - no
- bug] Spanish-language description of the change at
- http://www.presidencia.gub.uy/decretos/2004091502.htm
-
-2004-09-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c: Tolerate [append] syntax errors
- * tests/appendComp.test (8.1): at compile time, and allow runtime to
- raise the error (or succeed if a redefined [append] allows).
-
- * generic/tclBasic.c: Reworked management of the interp flag
- * generic/tclCompile.c: ERR_ALREADY_LOGGED, to reduce its exposure.
- * generic/tclExecute.c: Still left several referebces that are just
- * generic/tclNamesp.c: too nice on performace to do away with. These
- changes also resolve an inconsistency in the ::errorInfo values
- produced by [namespace eval x error foo bar] and [namespace eval x
- {error foo bar}].
-
- * generic/tclExecute.c (TclCompEvalObj): Simplified the
- TclCompEvalObj routine. Much housekeeping now reliably happens
- elsewhere. [Patch 1031949]
-
-2004-09-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/interp.n: Tighten up wording on how [interp eval] and [interp
- invokehidden] operate w.r.t. stack frames. [Bug 926590]
-
-2004-09-20 Don Porter <dgp@users.sourceforge.net>
-
- * tests/error.test (error-6.2,3): Added more tests to verify
- ::errorCode setting by/after a [catch].
-
-2004-09-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdAH.c: removed outdated comment [Bug 1029518].
-
-2004-09-18 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c: Dde package can load into a safe interp. Claim
- this fact for the Tcl_StaticPackage() call when the shell is built
- with the TCL_USE_STATIC_PACKAGES option.
-
-2004-09-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that
- large shifts end up shifting correctly. [Bug 868467]
-
- * doc/FileSystem.3, doc/OpenFileChnl.3: More documentation fixes from
- Mikhail Kolesnitchenko. [Patch 1022527]
- * doc/*: Standardize highlighting of symbols defined in tcl.h
-
-2004-09-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_AddObjErrorInfo, Tcl_LogCommandInfo):
- * generic/tclCmdAH.c ([catch], [error]):
- * generic/tclCmdMZ.c ([return]):
- * generic/tclProc.c (TclUpdateReturnInfo):
- * generic/tclResult.c (Tcl_SetErrorCodeVA, Tcl_SetObjErrorCode)
- (TclTransferResult): Refactored so that all errorCode setting flows
- through Tcl_SetObjErrorCode(). This greatly reduces the number of
- different places in the code that need to know details about an
- internal bitflag field of the Interp struct. Also places errorCode
- setting in one place for easier future mods.
-
-2004-09-17 Kevin B.Kenny <kennykb@acm.org>
-
- * generic/tclDate.c: Revised tclGetDate.y to use bison instead of
- * generic/tclGetDate.y: yacc to build the parser, eliminating all the
- * generic/tclInt.h: complicated hackery involving 'sed'
- * unix/Makefile.in: postprocessing. Rebuilt the parser.
-
-2004-09-14 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (ClockOldscanObjCmd): Silenced a compiler warning
- (long passed as a param where unsigend long was expected). 'Unsigned
- long' is wrong, but the fix is really to change the signature of
- TclGetDate to return a structure of its 'yy' variables and then do the
- remaining work inside clock.tcl. But, as I said on 2004-09-08, that's
- a job for another day. [Bug 1027993]
-
-2004-09-10 Miguel Sofer <msofer@users.sf.net>
-
- * doc/interp.n:
- * generic/tclInterp.c (TclPreventAliasLoop, AliasCreate):
- * tests/interp.test (17.4-6, 19.3-4): fixing problems with renaming of
- aliases [Bugs 707104 1026493]. Fix designed by dgp.
-
-2004-09-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (NsEnsembleImplementationCmd): Add token field
- to internal rep of EnsembleCmdRep structure so that we can check it to
- see if the subcommand object is really being used with the same
- ensemble. [Bug 1026903]
-
-2004-09-11 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (TclMktimeObjCmd): Corrected a bad check for
- error return from 'mktime'.
- * generic/tclObj.c (Tcl_GetIntFromObj): Corrected a problem where
- demoting a wide to an int failed on a big-endian machine. [Bug
- 1026125].
- * tests/clock.test (clock-43.1): Added regression test for error
- return from 'mktime'.
-
-2004-09-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_CONCAT1): fix for [Bug 1025834]; avoid
- unnecessary string copies.
-
-2004-09-10 David Gravereaux <davyrgvy@pobox.com>
-
- * tests/tcltest.test: tcltest-12.3-4 needed to have
- ::tcltest::loadScript set to empty in their -setup
-
-2004-09-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclObj.c (SetIntOrWideFromAny): Rewritten integral value
- parsing code so that values do not flip so easily between numeric
- representations. Thanks to KBK for this! [Bug 868489]
-
- * generic/tclIO.c (Tcl_Seek): Make sure wide seeks do not fail to set
- ::errorCode on error. [Bug 1025359]
-
-2004-09-10 Andreas Kupries <andreask@activestate.com>
-
- * generic/tcl.h: Micro formatting fixes.
- * generic/tclIOGT.c: Channel version fixed, must be 3, to have
- wideseekProc. Thanks to David Graveraux <davygrvy@pobox.com>.
-
-2004-09-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamespace.c (TclGetNamespaceForQualName): Resolved
- longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY
- flag revealed by testing the 2004-09-09 commits against Itcl.
- TCL_NAMESPACE_ONLY now acts as specified in the pre-function comment,
- forcing resolution in the passed in context namespace. It has been
- incorrectly forcing resolution in the interp's current namespace.
-
-2004-09-10 Kevin Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Fixed a bug where %z always put a plus sign on
- the time zone in :localtime.
- * tests/clock.test: Added test case for the above bug.
-
-2004-09-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_CONCAT1): added a peephole optimisation
- for concatting an empty string. This enables replacing the idiom 'K $x
- [set x {}]' by '$x[set x {}]' for fastest execution.
-
-2004-09-09 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinConsole.c: Calls to WriteFile and WriteConsoleA changed to
- WriteConsole for simplicity.
-
-2004-09-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty
-
- * tests/namespace.test: logic that relied exclusively on string
- matching and failed in the presence of [rename]s. [Bug 560297] Also
- corrected faulty prevention of [namespace import] cycles. [Bug 1017299]
-
-2004-09-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_CreateInterp): Removed obsolete field
- for storing the string-based command procedure of built-in commands.
- We no longer have any string-based built-in commands!
-
-2004-09-08 Kevin B. Kenny <kennykb@acm.org>
-
- * compat/strftime.c (_conv): Corrected a problem where hour 0 would
- format as a blank format group with %k.
- * doc/clock.n: Corrected a buglet in the header information. [Bug
- 1024058]
- * generic/tclClock.c (TclClockMktimeObjCmd): Fixed a bug where the
- month was scanned incorrectly in -timezone :localtime.
- * tests/clock.test (clock-34.*,clock-40.1, clock-41.1): Adjusted the
- clock-34.* test cases so that the consistency check is performed in
- :localtime rather than the current time zone. This change allows
- dealing with issues where the C library has a different idea of DST
- conversion than Tcl. (Real fix would be to break TclGetDate into
- separate parser and time converter, and do the time conversion in
- clock.tcl. That's for another day.) Added regression test case for the
- bug where month was scanned incorrectly in -timezone :localtime. [Bug
- 1023779] Added regression test case for %k at the zero hour.
-
-2004-09-07 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: some quoting needed to be removed as it was
- breaking with VC7. [Bug 1023150]
-
-2004-09-07 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Documented the default -format, and changed references
- to a (nonexistent) msgcat command to refer to the msgcat package. [Bug
- 1023870]
- * generic/tclTimer.c: Removed a premature optimisation that attempted
- to store the assoc data in the client data; the optimisation caused a
- bug that [after] would overwrite its imports. [Bug 1016167]
- * library/clock.tcl (InitTZData, ClearCaches): Changed so that the
- in-memory time zone :UTC (and its aliases) always gets reinitialised,
- in case tzdata is absent. [Bug 1019537, 1023779]
- * library/tzdata/*: Regenerated.
- * tests/clock.test (clock-31.*, clock-39.1): Corrected a problem where
- the 'system' locale tests fail on a non-English Windows machine. [Bug
- 1023761]. Added a test to make sure that alias time zones load
- correctly. [Bug 1023779].
- * tests/timer.test (timer-1.1, timer-2.1): Changed to (one hopes!) be
- more resilient on an overloaded system, if [after 200] sleeps for 300
- ms or longer.
- * tools/tclZIC.tcl (writeLinks): Corrected a problem where alias time
- zone names were written incorrectly, causing them to fail to load at
- run time. [Bug 1023779].
- * win/tclWinTime.c (Tcl_GetTime): Eliminated CPUID tests on Win64 -
- assuming that HAL vendors now do a better job of keeping the
- performance counters synchronized among CPU's. [Bug 1020445]
-
-2004-09-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/tclvars.n, doc/tcltest.n, doc/tclsh.1, doc/safe.n, doc/expr.n
- * doc/WrongNumArgs.3, doc/Utf.3, doc/TraceVar.3, doc/Thread.3
- * doc/TCL_MEM_DEBUG.3, doc/SubstObj.3, doc/StdChannels.3
- * doc/SetResult.3, doc/RegExp.3, doc/RegConfig.3, doc/RecEvalObj.3
- * doc/PrintDbl.3, doc/ParseCmd.3, doc/Panic.3, doc/ObjectType.3
- * doc/Object.3, doc/Namespace.3, doc/Interp.3, doc/IntObj.3
- * doc/Hash.3, doc/GetOpnFl.3, doc/GetIndex.3, doc/Eval.3
- * doc/Encoding.3, doc/DoubleObj.3, doc/DictObj.3, doc/CrtTimerHdlr.3
- * doc/CrtObjCmd.3, doc/CrtMathFnc.3, doc/CrtCommand.3, doc/CrtChannel.3
- * doc/ChnlStack.3, doc/ByteArrObj.3, doc/AssocData.3, doc/Alloc.3:
- More documentation fixes from Mikhail Kolesnitchenko. [Patch 1022527]
-
-2004-09-03 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixFCmd.c: Stop NULL interp arguments from triggering a
- crash when an error happens. [Bug 1020538]
-
-2004-09-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545]
-
-2004-09-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/makefile.vc: clock.tcl needs to be installed.
-
-2004-09-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinReg.c (BroadcastValue): WIN64 cast corrections
-
- * win/tclWinDde.c (DdeClientWindowProc):
- (DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections
-
- * win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium),
- until we have it, just return unknown. [Bug 1020445]
-
-2004-09-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/regsub.n, doc/RegConfig.3, doc/Environment.3:
- * doc/CrtChannel.3, doc/safe.n: Use correct abbreviations.
-
-2004-08-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/trace.n, doc/socket.n, doc/registry.n, doc/pid.n:
- * doc/namespace.n, doc/msgcat.n, doc/lsort.n, doc/lsearch.n:
- * doc/linsert.n, doc/info.n, doc/http.n, doc/history.n:
- * doc/format.n, doc/file.n, doc/exec.n, doc/dde.n, doc/clock.n:
- * doc/catch.n, doc/binary.n: More spelling and grammar fixes from
- Mikhail Kolesnitchenko. [Patch 1018486]
-
-2004-08-31 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * generic/tclIOUtil.c: Clarified documentation regarding ability of a
- filesystem to say that it doesn't support a given operation using the
- EXDEV Posix error code (copyFileProc, renameFileProc, etc), and
- updated one piece of code to ensure correct behaviour when an
- operation is not supported [Bug 1017072]
-
- * tests/fCmd.test: fix to test suite problem [Bug 1002884]
-
-2004-08-31 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in (install-libraries): portable sh fix.
-
-2004-08-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Stop [string map] from
- crashing when its map and input string are the same object.
-
-2004-08-27 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (FindEnsemble): Factor out the code to convert a
- command name into an ensemble configuration and add support for
- ignoring [namespace import] link chains. [Bug 1017022]
- (NamespaceWhichCmd): Rework to use newer option parsing API.
-
-2004-08-27 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: added customization of default module path roots
- via TCL_MODULE_PATH makefile variable.
- * macosx/Makefile: add platform standard locations to default module
- path roots. [Patch 942881]
-
- * tests/env.test: macosx fixes.
-
-2004-08-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/timer.test (timer-10.1): Test for Bug 1016167.
- * generic/tclTimer.c: Workaround for situation when a [namespace
- import] causes the objv[0] value to be something other than what
- Tcl_AfterObjCmd expects. [Bug 1016167].
-
-2004-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (NsEnsembleImplementationCmd): Use the ensemble
- command token to get the name of the ensemble for passing to the
- -unknown handler instead of relying on objv[0], which may contain
- useless info in the presence of [namespace import]. Problem found by
- Don Porter when investigating [Bug 1016167].
-
-2004-08-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclProc.c: The routine TclProcInterpProc was a
- * generic/tclTestProcBodyObj.c: specific instance of the general
- service already provided by TclObjInvokeProc. Removed
- TclProcInterpProc and TclGetInterpProc from the code...
-
- * generic/tclInt.decls: ...and from the internal stubs table.
- * generic/tclIntDecls.h
- * generic/tclStubInit.c
-
-2004-08-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/string.n: Added clarifying note.
-
-2004-08-23 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Updated [tcl_findLibrary] search path to
- include any [<pkg>::pkgconfig get scriptdir,runtime] directory, as
- well as the $::auto_path. [RFE 695441]
-
-2004-08-21 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/clock.test (clock-38.1): Changed TZ setting to specify CET in
- excruciating detail to deal with systems that lack the Posix defaults
- for DST changes (and to be formally correct with the change dates for
- CET).
-
-2004-08-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that the
- %ld conversion works correctly on 64-bit platforms. [Bug 1011860]
-
-2004-08-19 Kevin Kenny <kennykb@acm.org>
-
- * library/clock.tcl (format): Changed default timezone format from
- alphabetic to numeric to produce scannable times in more locales.
- * tests/clock.test (clock-37.1): Removed now-unused 'needPST'
- constraint and the comments that refer to it.
-
-2004-08-18 Andreas Kupries <andreask@activestate.com>
-
- * library/init.tcl: Integrated TIP #189. We source a separate file
- (see below), instead of inlining the contents of that file. This
- should beeasier to maintain, and easier to backport/install in 8.4
- installations.
-
- Note: Usage of Tcl Modules is restricted to non-safe interps. It
- cannot be loaded into a safe interp.
-
- * library/tm.tcl: New file, the v2 reference implementation for TIP
- #189, Tcl Modules.
-
- * doc/tm.n: New file, documentation for Tcl Modules, based on the TIP.
-
- * unix/mkLinks: Regenerated.
- * win/makefile.vc: Added tm.tcl to list of files to install.
-
-2004-08-18 Kevin Kenny <kennykb@acm.org>
-
- * tests/httpd (httpdRespond): Corrected an abuse of the [clock]
- command that caused test failures for some values of [clock clicks].
-
- * doc/clock.n
- * generic/tclBasic.c (Tcl_CreateInterp, Tcl_HideUnsafeCommands):
- * generic/tclClock.c (all):
- * generic/tclInt.h:
- * generic/tclInterp.c (CreateSlave):
- * library/clock.tcl: (new file)
- * library/init.tcl (clock):
- * library/msgs/*.msg:(new files)
- * library/tzdata/*:
- * library/tzdata/*/*:
- * library/tzdata/*/*/*: (new files)
- * tools/installData.tcl: (new file)
- * tools/loadICU.tcl: (new file)
- * tools/makeTestCases.tcl: (new file)
- * tools/tclZIC.tcl: (new file)
- * unix/Makefile.in:
- * unix/configure: (regenerated)
- * unix/tcl.m4:
- * tests/clock.test (all):
- * win/Makefile.in:
- * win/Makefile.vc:
- Implementation of TIPs #173 and #209.
-
- The [clock] command is now a Tcl ensemble, with most of its
- functionality written in Tcl and callouts to C code only to access
- low-level functions such as localtime, mktime and tzset.
-
- In addition to the functionality changes called out in the two TIPs,
- it is worth noting that the [clock] command in a safe slave
- interpreter is now an alias to the [clock] command in the master, and
- that [clock] is otherwise not expected to function entirely correctly
- in safe interps. C code that simply does Tcl_MakeSafe needs to be
- aware that [clock] may need special handling. (It appears unlikely
- that such code actually exists.)
-
- One incompatibility of note is that if the time zone cannot be
- determined from the TZ, TCL_TZ environment variables, or from the
- Windows control panel, so that the C library must be used for date and
- time conversions, then times outside the range of time_t will fail;
- they used to return bad data silently.
-
- Many thanks to all the many people who assisted with testing,
- debugging, criticism of the specification, and localisation. Deserving
- of particular mention are Joe English, Clif Flynt, Donal K. Fellows,
- Jeff Hobbs, Cameron Laird, Arjen Markus, Reinhard Max, Christopher
- Nelson, Steve Offutt, Donald G. Porter, Pascal Scheffers, Peter da
- Silva and Richard Suchenwirth-Bauersachs.
-
- *** POTENTIAL INCOMPATIBILITY ***
-
-2004-08-16 Miguel Sofer <msofer@users.sf.net>
-
- * doc/SetVar.3:
- * generic/tclTest.c (TestseterrorcodeCmd):
- * generic/tclVar.c (TclPtrSetVar):
- * tests/result.test (result-4.*, result-5.*): [Bug 1008314] detected
- and fixed by dgp.
-
-2004-08-13 Don Porter <dgp@users.sourceforge.net>
-
- * library/msgcat/msgcat.tcl: Added checks to prevent [mclocale]
- * tests/msgcat.test: from registering filesystem paths to possibly
- malicious code to be evaluated by a later [mcload].
-
-2004-08-10 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * unix/tclUnixThrd.c (TclpThreadCreate): changed handling of the
- returned thread ID since broken on 64-bit systems (Cray). Thanks to
- Rob Ratcliff for reporting the bug.
-
-2004-08-03 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (MakeCachedEnsembleCommand): Initialize the
- epoch field cached in the subcommand. [Bug 989298]
- (NsEnsembleImplementationCmd): Plug a leak (thanks to Miguel Sofer for
- spotting it with valgrind) and reduce the number of goto labels to
- make the code clearer.
-
-2004-08-02 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl (pkg_mkIndex): Updated [pkg_mkIndex] to make
- use of [glob -directory $dir -tails] and return options.
-
- TIP#207 IMPLEMENTATION
-
- * doc/interp.n: Added support for a -namespace option to the
- * generic/tclBasic.c: [interp invokehidden] command. Also added an
- * generic/tclInt.h: internal routine TclObjInvokeNamespace() and
- * generic/tclInterp.c: corrected the flag names TCL_FIND_ONLY_NS and
- * generic/tclNamesp.c: TCL_CREATE_NS_IF_UNKNOWN that are passed to the
- * generic/tclTrace.c: internal routine TclGetNamespaceForQualName().
- * tests/interp.test: [Patch 981841]
-
- * generic/tclLiteral.c (TclCleanupLiteralTable): Corrected
- * tests/compile.test (compile-12.4): flawed deletion of literal
- internal reps that could lead to accessing of freed memory. Thanks to
- Kevin Kenny for test case and fix [Bug 1001997].
-
-2004-07-30 Don Porter <dgp@users.sourceforge.net>
-
- * tests/safe.test (safe-2.1): Disabled senseless test. [Bug 999612]
-
- * library/auto.tcl (auto_reset): Removed "protected" list of commands
- from [auto_reset]. All entries in the auto_index can be re-loaded.
- * library/package.tcl: Updated comment to reflect 2004-07-28 commit.
-
- * generic/tclEvent.c (Tcl_Finalize): Re-organized Tcl_Finalize so
- that Tcl_ExitProc's that call Tcl_Finalize recursively do not cause
- deadlock. [Patch 999084 fixes Tk Bug 714956]
-
-2004-07-30 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/configure:
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS
- to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var.
- * unix/Makefile.in: added MAC_OSX_OBJS variable.
-
-2004-07-29 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl: [::pkg::create] is now an alias. Test safe-2.1
- will now fail until Bug 999612 is corrected.
-
-2004-07-28 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl: Moved private command
- * library/tclIndex: [pkg_compareExtension] into ::tcl::Pkg.
- * tests/pkg_mkIndex.test: Also moved implementation of
- [::pkg::create] to [::tcl::Pkg::Create].
-
-2004-07-25 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/io.test: Make io-61.1 create file as binary to pass on Win32
-
-2004-07-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: simplify tclLocalVarNameType, removing the
- reference to the corresponding proc. The reference is now seen as
- unnecessary, and it may cause leaking circular references under some
- circumstances (see for example [Bug 994838]).
-
-2004-07-22 Don Porter <dgp@users.sourceforge.net>
-
- * tests/eofchar.data (removed): Test io-61.1 now generates its own
- * tests/io.test: file of test data as needed.
-
-2004-07-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclEvent.c: Correct threaded obj allocator to
- * generic/tclInt.h: fully cleanup on exit and allow for
- * generic/tclThreadAlloc.c: reinitialization. [Bug 736426]
- * unix/tclUnixThrd.c: (mistachkin, kenny)
- * win/tclWinThrd.c:
-
-2004-07-21 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclBasic.c (DeleteInterpProc):
- * generic/tclLiteral.c (TclCleanupLiteralTable):
- * generic/tclInt.h: added a TclCleanupLiteralTable function, called
- from DeleteInterpProc, that frees internal representations of shared
- literals early when an interpreter is being deleted. This change
- corrects a number of memory mismanagement issues in the cases where
- the internal representation of one literal contains a reference to
- another, and avoids conditions such as resolved variable names
- referring to procedure and namespace contexts that no longer exist.
- [Bug 994838]
-
-2004-07-20 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in:
- * win/Makefile.in: added 'install-private-headers' makefile target to
- allow optionally installing private tcl headers. [FR 922727]
-
- * macosx/Makefile: use new 'install-private-headers' target to install
- private headers into framework. [FR 922727]
-
- * unix/tclUnixFile.c (NativeMatchType): added support for readonly
- matching of user immutable files (where available).
-
- * macosx/tclMacOSXBundle.c: dynamically acquire address for
- CFBundleOpenBundleResourceMap symbol, since it is only present in full
- CoreFoundation on Mac OS X and not in CFLite on pure Darwin.
-
-2004-07-19 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * win/tclwinThrd.c: redefined MASTER_LOCK to call TclpMasterLock.
- Fixes [Bug 987967]
-
-2004-07-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to rare 'cd' infinite loop in normalization
- with vfs [Bug 991420].
- * tests/fileSystem.test: added test for above bug.
-
- * doc/FileSystem.3: clarified documentation of Posix error codes in
- 'remove directory' FS proc - 'EEXIST' is used to signify a non-empty
- directory error (bug reported against tclvfs).
-
-2004-07-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in, unix/tcl.m4: move (C|LD)FLAGS after their
- * unix/configure.in, unix/configure: _DEFAULT to allow for env setting
- to override m4 switches. Move SC_MISSING_POSIX_HEADERS up and
- consolidate calls to limit redundancy in configure.
- (CFLAGS_WARNING): Remove -Wconversion
- (SC_ENABLE_THREADS): Set m4 to force threaded build when built against
- a threaded Tcl core.
-
-2004-07-16 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Corrected a typo in the
- generation of error messages and simplified by reusing data in a
- variable instead of retrieving the string again. Fixes [Bug 835289].
-
- * doc/OpenFileChnl.3: Added description of the behaviour of
- Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug
- 934511].
-
- * doc/CrtCommand.3: Added note that the arguments given to the command
- proc of a Tcl_CreateCommand are in utf-8 since Tcl 8.1. Closing [Patch
- 414778].
-
- * doc/ChnlStack.3: Removed the declaration that the interp argument to
- Tcl_(un)StackChannel can be NULL. This fixes [Bug 881220], reported by
- Marco Maggi <marcomaggi@users.sourceforge.net>.
-
- * tests/socket.test: Accepted two new testcases by Stuart Casoff
- <stwo@users.sourceforge.net> checking that -server and -async don't go
- together [Bug 796534].
-
- * unix/tclUnixNotfy.c (NotifierThreadProc): Accepted Joe Mistachkin's
- patch for [Bug 990500], properly closing the notifier thread when its
- exits.
-
-2004-07-15 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe Mistachkin's
- patch for [Bug 990453], closing leakage of mutexes. They were not
- destroyed properly upon finalization.
-
-2004-07-15 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.h (CHANNEL_INCLOSE): New flag. Set in
- * generic/tclIO.c (Tcl_UnregisterChannel): 'Tcl_Close' while the
- * generic/tclIO.c (Tcl_Close): close callbacks are
- run. Checked in 'Tcl_Close' and 'Tcl_Unregister' to prevent recursive
- call of 'close' in the close-callbacks. This is a possible error made
- by implementors of virtual filesystems based on 'tclvfs', thinking
- that they have to close the channel in the close handler for the
- filesystem.
-
-2004-07-14 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c:
- * generic/tclIO.h:
- * Not reverting, but #ifdef'ing the changes from May 19, 2004 out of
- the core. This removes the ***POTENTIAL INCOMPATIBILITY*** for channel
- drivers it introduced. This has become possible due to Expect gaining
- a BlockModeProc and now handling blockingg and non-blocking modes
- correctly. Thus [SF Tcl Bug 943274] is still fixed if a recent enough
- version of Expect is used.
-
- * doc/CrtChannel.3: Added warning about usage of a channel without a
- BlockModeProc.
-
-2004-07-15 Andreas Kupries <andreask@pliers.activestate.com>
-
- * generic/tclIOCmd.c (Tcl_PutsObjCmd): Added length check to the old
- depreceated newline syntax, to ensure that only "nonewline" is
- accepted. [Tcl SF Bug 985869], reported by Joe Mistachkin
- <mistachkin@users.sourceforge.net>.
-
-2004-07-15 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclEvent.c (Tcl_Finalize): stuffed memory leak incurred by
- re-initializing of TSD slots after the last call to
- TclFinalizeThreadData (done from within Tcl_FinalizeThread()). We
- basically just repeat the TclFinalizeThreadData() once more before
- tearing down TSD keys in TclFinalizeSynchronization(). There should be
- more elaborate mechanism in place for handling such issues, based on
- thread cleanup handlers registered on the OS level. Such change
- requires much more work and would also require TIP because some
- visible parts of Tcl API would have to be modified. In the meantime,
- this will do.
-
- * generic/tclNotify.c (TclFinalizeNotifier): Added conditional
- notifier finalization based on the fact that an TclInitNotifier has
- been called for the current thread. This fixes the [Bug 770053] again.
- Hopefully this time w/o unwanted side-effects.
-
-2004-07-15 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclLiteral.c (TclReleaseLiteral): Removed unused variable
- 'codePtr' to silence a message from VC++.
-
-2004-07-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript):
- * generic/tclLiteral.c (TclReleaseLiteral): fix for [Bug 467523],
- which resurfaced with the latest changes. The previous strategy was to
- have special code in TclReleaseLiteral to handle the self-references
- generated by empty scripts. The new approach avoids the self-reference
- altogether, by having empty scripts return an unshared literal.
-
-2004-07-15 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclEvent.c (NewThreadProc): Backout of changes to fix the
- [Bug 770053]. See SF bugreport for more info.
-
-2004-07-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_EvalEx): leak fix by dgp, release
- objv[objectsUsed] on error.
-
-2004-07-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c (Tcl_SubstObj): leak fix by dgp, release result
- on error.
-
-2004-07-11 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (BuildEnsembleConfig): Don't forget to clean out
- references when deleting the hash table.
- * generic/tclDictObj.c (Tcl_DictObjRemoveKeyList): Oops, forgot to
- delete value object when removing the hash entry. [Bug 989093 in part]
-
-2004-07-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC): fixed leak of expandNestList objs when
- there is an error while an expansion is in progress (code added at
- checkForCatch).
-
-2004-07-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to 'cd' bug when vfs is active [tclvfs Bug
- 986944] - this bug recently introduced by some threading fixes. Need
- to work out how to add tests for this.
-
-2004-07-10 Kevin Kenny <kennykb@acm.org>
-
- * tests/clock.test (clock-2.11): Changed the test so that it isn't an
- infinite loop when run under valgrind on a slow virtual machine.
- Thanks to Miguel Sofer for the bug report. Also put in code to restore
- env(LC_TIME) after tests complete, silencing a warning from 'make
- TESTFLAGS="-debug 1" test'.
-
-2004-07-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (DeleteInterpProc): reverted the modification of
- 3 days ago, as the leak of [Bug 983660] is now handled by the change
- in TclCleanupByteCode.
- * generic/tclCompile.c (TclCleanupByteCode): let each bytecode remove
- its references to literals at interp deletion, without updating the
- dying literal table.
- * generic/tclLiteral.c (TclDeleteLiteralTable): with the above change
- to TclCleanupByteCode, this function now removes a single reference to
- the literal object and cleans up its own structures.
-
-2004-07-08 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWinInit.c (AppendEnvironment): Silenced a compilation warning
- about a type mismatch.
-
-2004-07-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript): fix for [Bug 458361].
- Single-word scripts are compiled with an unshared cmdName to avoid
- shimmering between bytecode and cmdName reps.
-
-2004-07-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (TclMergeReturnOptions): Simplified logic and
- removed potential memory leak. [Bug 986257].
-
-2004-07-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/man2help2.tcl (setTabs, IPmacro): Added support for the more
- advanced *roff macros used in Tk's doc/bind.n
-
- * generic/tclObj.c (TclInitObjSubsystem): Declare all current object
- types.
-
-2004-07-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/cmdMZ.test (cmdMZ-return-2.17): Added a test that a word
- containing backslash-quoted value is treated correctly.
-
- * generic/tclCompile.c (TclWordKnownAtCompileTime): [Bug 986196]
- Corrected flaw above and the flaw that caused TCL_TOKEN_SIMPLE_WORDs
- to have their original word value copied ( "{a b}" ) rather than the
- actual value ( "a b" ). Thanks to Kevin Kenny for report and tests.
-
-2004-07-06 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/cmdMZ.test (cmdMZ-return-2.15,cmdMZ-return-2.16): Added a test
- that a return code containing spaces is correctly returned.
-
-2004-07-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/man2html2.tcl (IPmacro, setTabs): Added support for the more
- advanced *roff macros used in Tk's doc/bind.n
-
-2004-07-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (DeleteInterpProc): fix for [Bug 983660], found
- by pspjuth. Tear down the global namespace before freeing the interp
- handle, to allow the bytecodes to free their non-shared literals.
- * generic/tclLiteral.c (TclReleaseLiteral): moved special code for
- self-ref so that it is also used for non-shared literals. Possible bug
- found by inspection.
-
-2004-07-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (ExprRoundFunc):
- * tests/expr-old.test (39.1): added support for wide integers to
- round(); [Bug 908375], reported by Hemang Lavana.
-
-2004-07-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.h:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c: Moved declaration of TclCompEvalObj() from
- tclCompile.h to the internal stubs table, for compiler
- experimentation.
-
-2004-07-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/regcomp.c (stid): correct minor pointer size error
-
- * generic/tclPipe.c (TclCreatePipeline): applied TIP #202 patch that
- * doc/exec.n, tests/exec.test: adds 2>@1 as a special case
- redirection of stderr to the result output.
-
-2004-07-02 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/io.test: Changed several tests to run the event loop rather
- than just calling [update] periodically, avoiding intermittent
- failures (usually in io-29.32) that stemmed from unreaped processes on
- Windows.
- * tests/winPipe.test (winpipe-1.11): Fixed a bug that caused test to
- fail if the path name of the working directory contained whitespace
- [Bug 678430]
-
-2004-07-01 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fileSystem.test: Added test for [Bug 970529]
-
-2004-07-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * win/README.binary, win/README: Updated references to Tcl and Tk 8.4
- to point to 8.5 instead. Thanks to Theo Verelst for spotting this.
- * generic/tcl.h: Added note to help prevent those changes from getting
- missed in the future.
-
- * doc/Namespace.3, doc/load.n, doc/Limit.3: Typo fixes and remove
- duplicate documentation. [Bug 983146]
-
-2004-06-30 Don Porter <dgp@users.sourceforge.net>
-
- * tests/fileSystem.test: Minor correction to new fileSystem-9.X tests
- so that they clean up temporary directories correctly.
-
-2004-06-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/filename.n: clarified behaviour concerning trailing slashes in
- filenames [Bug 971976]
-
- * win/tclWinFile.c:
- * tests/fileSystem.test: fix and tests for [Bug 979879]
-
-2004-06-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP#188 IMPLEMENTATION
-
- * doc/string.n, tests/string.test: Add 'wideinteger' to things
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): that can be tested for with
- the [string is] subcommand. [Patch 940915, by Kevin Kenny]
-
-2004-06-29 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinInit.c: Corrected reference counting flaw in recent
- changes. Thanks to Pat Thoyts. [Bug 981893].
-
-2004-06-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWin32Dll.c: fix to compilation with VC++ 5.2
-
-2004-06-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * library/safe.tcl: Make sure that the temporary variable is local to
- the namespace and not inadvertently global. [Bug 981733]
-
-2004-06-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/unixNotfy.test: Modified constraints so that testing with a
- threaded tclsh (not tcltest) will not hang.
-
-2004-06-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclThreadStorage.c: Corrected type casting errors that led
- to calculation of a negative index value, thus accesses outside the
- threadStorageCache array, thus memory corruption. Crash observed on
- Mac OS X platform.
-
-2004-06-23 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclThread.c: Implements platform independent thread storage
- * generic/tclThreadStorage.c: mechanism and fixes associated bugs on
- platforms where there is limited thread local storage space
- (Win98/WinNT4). [Patch 976496]
-
- * generic/tclInt.decls:
- * generic/tclIntDecls.h: Added thread storage functions to the
- * generic/tclStubInit.c: internal stubs table.
-
- * unix/Makefile.in:
- * unix/configure:
- * unix/tcl.m4:
- * win/makefile.vc:
- * win/rules.vc:
- * win/Makefile.in: Modified the unix, VC++, and Cygwin build systems
- * win/configure: to include the new "tclThreadStorage.c" and the new
- * win/tcl.m4: USE_THREAD_STORAGE define.
-
-2004-06-23 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/io.test: Added -force to 18.1 and 18.2. This was failing on
- WinXP.
-
- * tests/winFCmd.test: Added a cleanup to winFCmd-16.11 to avoid a
- failure in 16.12.
-
- * tests/eofchar.data: Added -kb option to ensure a binary checkout to
- win32 systems. This fixes a failure in io-61.1
-
- * win/makefile.vc: fix for [Bug 977369] about launching tclsh to
- generate a tclConfig.sh with the nmake build system
-
-2004-06-23 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/winDde.test (createChildProcess): Added a 200-ms delay (with
- the event loop live) when shutting down the test DDE server process.
- With the delay in place, nuisance failures of tests winDde-4.2, -6.5,
- and -6.6 appear to be much less frequent. [Bug 957449]
-
-2004-06-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/*.test: Standardize use of platform constraints.
-
- * unix/tclUnixInit.c (GetStackSize, TclpCheckStackSpace):
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): Added code to check
- whether the C stack is about to be exceeded, from [Patch 746378] by
- Joe Mistachkin but with substantial revisions.
-
-2004-06-22 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclEvent.c (NewThreadProc): Fixed broken build on Windows
- caused by missing TCL_THREAD_CREATE_RETURN.
-
- * tests/stack.test (stack-3.1): Corrected nuisance error in threaded
- builds.
-
-2004-06-22 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclEvent.c:
- * generic/tclInt.h:
- * unix/tclUnixNotfy.c:
- * unix/tclUnixThrd.c:
- * win/tclWinThrd.c: [Bug 770053]. See bug report for more information
- about what it does.
-
- * tests/unixNotfy.test: rewritten to use tcltest::threadReap to
- gracefully wait for the test thread to exit. Otherwise we got a race
- condition with main thread exiting before the test thread. This
- exposed the long-standing Tcl lib issue with resource
- garbage-collection on application exit.
-
-2004-06-21 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWin32Dll.c (DllMain, _except_dllmain_detach_handler)
- (TclpCheckStackSpace, _except_checkstackspace_handler)
- (TclWinCPUID, _except_TclWinCPUID_detach_handler):
- * win/tclWinChan.c (Tcl_MakeFileChannel)
- (_except_makefilechannel_handler):
- * win/tclWinFCmd.c (DoRenameFile, _except_dorenamefile_handler)
- (DoCopyFile, _except_docopyfile_handler):
- Rework pushing of exception handler function pointer so that compiling
- with gcc -O3 works. Remove empty function call to avoid compiler
- warning. Mark the DllMain function as noinline to avoid compiler error
- from duplicated asm labels in generated code.
-
-2004-06-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclThreadAlloc.c (Ptr2Block): Rewrote so as to maximize the
- chance of detecting and reporting a memory inconsistency without
- relying on things being consistent. [Bug 975895]
-
-2004-06-18 Don Porter <dgp@users.sourceforge.net>
-
- * tests/load.test: Relaxed strictness of error message matching
- for test load-2.3 so that it will pass on Mac OSX.
-
- * generic/tclEncoding.c: Static TclFindEncodings -> FindEncodings.
- * generic/tclInt.h: Updated TclpFindExecutable() so that failed
- * generic/tclUtil.c: attempts to find the executable are saved
- * unix/tclUnixFile.c: just as successful finds are. [Patch 966053]
- * unix/tclUnixTest.c:
-
-2004-06-18 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/winFCmd.test (winFCmd-16.12): Changed test to compute the
- target directory, so as not to fail if the user's HOME isn't the root.
-
-2004-06-19 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: autoconf 2.5 fixes in Darwin section.
- * unix/configure: autoconf-2.57
-
-2004-06-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixInit.c (localeTable): Added some more locale to encoding
- mapping info from Jim Huang <jserv@kaffe.org>
-
- * generic/tclInt.h (PendingObjData,TclFreeObjMacro,etc):
- * generic/tclObj.c (TclFreeObj): Added scheme for making TclFreeObj()
- avoid blowing up the C stack when freeing up very large object trees.
- [Bug 886231]
-
- * win/tclWinInit.c (SetDefaultLibraryDir): Fix logic, simplify and add
- comments.
-
-2004-06-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclObj.c: Added missing space in panic message.
-
- * win/tclWinInit.c: Inform [tclInit] about the default library
- directory via the ::tclDefaultLibrary variable. This should correct a
- problem with my 2004-06-11 commit. Better solutions still in the
- works. Thanks to Joe Mistachkin for pointing out the breakage.
-
-2004-06-16 Don Porter <dgp@users.sourceforge.net>
-
- * doc/library.n: Moved variables ::auto_oldpath and
- * library/auto.tcl: ::unknown_pending into ::tcl namespace.
- * library/init.tcl: [Bugs 808319, 948794]
-
-2004-06-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/binary.n: Added some notes to the documentation of the 'a'
- format to address the point raised in [RFE 768852].
-
-2004-06-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclConfig.sh.in (TCL_EXTRA_CFLAGS): set to @CFLAGS@, which is
- the configure-time CFLAGS. Addendum to m4 change on 2004-05-26.
-
-2004-06-14 Kevin Kenny <kennykb@acm.org>
-
- * win/Makefile.in: Corrected compilation flags for tclPkgConfig.c so
- that it doesn't require Stubs.
- * generic/tclBasic.c (Tcl_CreateInterp): Removed comment stating that
- TclInitEmbeddedConfigurationInformation needs Stubs; with the change
- above, the comment is now erroneous.
-
-2004-06-11 Don Porter <dgp@users.sourceforge.net>
-
- * doc/Encoding.3: Removed bogus claims about tcl_libPath.
-
- * generic/tclInterp.c (Tcl_Init): Stopped setting the
- tcl_libPath variable. [tclInit] can get all its directories without it.
-
- * tests/unixInit.test: Modified test code that made use of
- tcl_libPath variable.
-
- * unix/tclUnixInit.c: Stopped setting the tclDefaultLibrary variable,
- execept on the Mac OS X platform with HAVE_CFBUNDLE. In that
- configuration we should seek some way to make use of the TIP 59
- facilities and get rid of that usage of tclDefaultLibrary as well.
-
- * generic/tclInterp.c: Updated [tclInit] to make $env(TCL_LIBRARY) an
- absolute path, and to include the scriptdir,runtime configuration value
- on the search path for init.tcl.
-
- * unix/tclUnixInit.c: The routines Tcl_Init() and TclSourceRCFile()
- * win/tclWinInit.c: had identical implementations for both win and
- * generic/tclInterp.c: unix. Moved to a single generic implementation.
- * generic/tclMain.c:
- * library/init.tcl:
- * generic/tclInitScript.h (removed):
- * unix/Makefile.in:
- * win/tcl.dsp:
-
- * unix/configure.in: Updated TCL_PACKAGE_PATH value to handle
- * win/configure.in: --libdir configuration.
-
- * unix/configure.in: autoconf-2.57
- * win/configure.in:
-
- * generic/tclBasic.c (Tcl_CreateInterp): Moved call to
- TclInitEmbeddedConfigurationInformation() earlier in
- Tcl_CreateInterp() so that other parts of interp creation and
- initialization may access and use the config values.
-
-2004-06-11 Kevin Kenny <kennykb@acm.org>
-
- * win/tclAppInit.c: Restored the 'setargv' procedure when compiling
- with mingw. Apparently, the command line parsing in mingw doesn't work
- as well as that in vc++, and the result was (1) that winPipe-8.19
- failed, and (2) that 'make test' would work at all only with
- TESTFLAGS='-singleproc 1'. [Bug 967195]
-
-2004-06-10 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclIOUtil.c: removed forceful setting of the private cached
- current working directory rep from within the Tcl_FSChdir(). We
- delegate this task to the Tcl_FSGetCwd() which does this task anyway.
- The relevant code is still present but disabled temporarily until the
- change proves correct. The Tcl test suite passes all test with the
- given change so I suppose it is good enough.
-
-2004-06-10 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixInit.c (TclpInitLibraryPath): Disabled addition of
- * win/tclWinInit.c (TclpInitLibraryPath): relative-to-executable
- directories to the library search path. A first step in reform of
- Tcl's startup process.
-
- ***POTENTIAL INCOMPATIBILITY***
- Attempts to directly run ./tclsh or ./tcltest out of a build directory
- will either fail, or will make use of an installed script library in
- preference to the one in the source tree. Use `make shell` or `make
- runtest` instead.
-
- * tests/unixInit.test: Modified tests to suit above changes.
-
- * generic/tclPathObj.c: Corrected [file tail] results when operating
- on a path produced by TclNewFSPathObj(). [Bug 970529]
-
-2004-06-09 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclIOUtil.c: partially corrected [Bug 932314]. Also
- corrected return values of Tcl_FSChdir() to reflect those of the
- underlying platform-specific call. Originally, return codes were mixed
- with those of Tcl.
-
-2004-06-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:
- * generic/tclExecute.c: handle warning [Bug 969066]
-
-2004-06-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclHash.c (RebuildTable): Move declaration of variable so it
- is only declared when it is used. [Bug 969068]
-
-2004-06-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n: Added correct option to example. [Bug 968219]
-
-2004-06-05 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tcl.h: Corrected Tcl_WideInt declarations so that the mingw
- build works again.
- * generic/tclDecls.h: Changes to the tests for clock
- * generic/tclInt.decls: frequency in Tcl_WinTime so
- * generic/tclIntDecls.h: that any clock frequency is
- * generic/tclIntPlatDecls.h: accepted provided that all
- * generic/tclPlatDecls.h: CPU's in the system share a
- * generic/tclStubInit.c: common chip, and hence,
- * tests/platform.test (platform-1.3): presumably, a common clock.
- * win/tclWin32Dll.c (TclWinCPUID): This change necessitated a
- * win/tclWinTest.c (TestwincpuidCmd) small burst of assembly code
- * win/tclWinTime.c (Tcl_GetTime): to read CPU ID information,
- which was added as TclWinCPUID in the internal Stubs. To test this
- code in the common case of a single-processor machine, a
- 'testwincpuid' command was added to tclWinTest.c, and a test case in
- platform.test. Thanks to Jeff Godfrey and Richard Suchenwirth for
- reporting this bug. [Bug 976722]
-
-2004-06-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Restored #include <stdio.h> to tcl.h,
- rejecting the "fix" for "Bug" 945570. Tcl_FSSeek() needs the values of
- SEEK_SET, etc. and too many extensions rely on tcl.h providing stdio.h
- for them.
-
-2004-06-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFile.c (TclpFindExecutable): when using GetModuleFileNameA
- (Win9x), convert from CP_ACP to WCHAR then convert back to utf-8.
- Adjunct to 2004-04-07 fix.
-
-2004-06-02 David Gravereaux <davygrvy@pobox.com>
-
- * tests/winPipe.test (winpipe-6.1): blocking set to 1 before closing
- to ensure we get an exitcode. The windows pipe channel driver doesn't
- differentiate between a blocking and non-blocking close just yet, but
- will soon. Part of [Bug 947693]
-
-2004-06-02 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n: fix to documentation of 'file volumes' (Bug 962435)
-
-2004-06-01 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: check for either MSDEVDIR or MSVCDIR being in the
- environment, for VC7. [Bug 942214]
-
- * generic/tclIO.c (Tcl_SetChannelOption): -buffersize wasn't
- understanding hexidecimal notation nor was reporting number conversion
- errors. The behavior to silently ignore settings outside the
- acceptable range of Tcl_SetChannelBufferSize (<10 or >1M) is
- unchanged. This silent ignoring behavior might be up for review soon.
-
-2004-05-30 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c:
- * win/tclWinPort.h: Reworked the win implementation of Tcl_WaitPid to
- support exitcodes in the 'signed short' range. Even though this range
- is non-portable, it is valid on windows. Detection of exception codes
- are now more accurate. Previously, an application that exited with
- ExitProcess((DWORD)-1); was improperly reported as exiting with
- SIGABRT.
-
-2004-05-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c: Added comments describing the purposes of each
- function in the limit implementation and rewrote the names of some
- non-public functions for greater clarity of purpose.
- * doc/interp.n: Added note about what happens when a limited
- interpreter creates a slave interpreter.
- * doc/Limit.3: Added manual page for the resource limit subsystem's C
- API. [Bug 953903]
-
-2004-05-29 Joe English <jenglish@users.sourceforge.net>
-
- * doc/global.n, doc/interp.n, doc/lrange.n: Fix minor markup errors.
-
-2004-05-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/*.n: Added examples to many (too many to list) more man pages.
-
-2004-05-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c:
- * generic/tclVar.c: using (ptrdiff_t) instead of (int) casting to
- correct compiler warnings [Bug 961657], reported by Bob Techentin.
-
-2004-05-27 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/clock.test: Added a single test for the presence of %G in
- [clock format], and conditioned out the clock-10.x series if they're
- all going to fail because of a broken strftime() call. [Bug 961714]
-
-2004-05-27 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclHash.c (CompareStringKeys): Added #ifdef to allow people
- to instruct this function to use strcmp(). [FRQ 951168]
-
- * generic/tclVar.c: Moved declarations into #if guards so they only
- happen when required.
- * unix/tclUnixPort.h: Guard declaration of strtod() so it is only
- enabled when we don't have a declaration in stdlib.h
- * unix/tclUnixThrd.c (Tcl_CreateThread): Added declarations
- * unix/tclUnixTest.c (AlarmHandler): and casts so that
- * unix/tclUnixChan.c (TtyModemStatusStr): all functions are
- * generic/tclScan.c (Tcl_ScanObjCmd): defined before use
- * generic/tclDictObj.c (InvalidateDictChain): and no cross-type
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): uses are performed.
-
- The overall effect is to make building with gcc with the additional
- flags -Wstrict-prototypes -Wmissing-prototypes produce no increase in
- the total number of warnings (except for main(), which is undeclared
- for traditional reasons.)
-
-2004-05-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in: Rework configure ordering to TCL_LINK_LIBS,
- * unix/tcl.m4: ENABLE_SHARED, CONFIG_CFLAGS, & ENABLE_SYMBOLS
- * unix/configure: before TCL_EARLY_FLAGS and TCL_64BIT_FLAGS
- * unix/configure.in: (about 400 lines earlier) in configure.in. This
- forces CFLAGS configuration to be done before many tests, which is
- needed for 64-bit builds and may affect other builds. Also make
- CONFIG_CFLAGS append to CFLAGS directly instead of using EXTRA_CFLAGS,
- and have LDFLAGS append to any existing value. [Bug 874058]
- * unix/dltest/Makefile.in: change EXTRA_CFLAGS to DEFS
-
-2004-05-26 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Correction to debug prints and testing
- * library/tcltest/pkgIndex.tcl: if TCLTEST_OPTIONS value. Corrected
- * tests/tcltest.test: double increment of numTestFiles in
- -singleproc 1 configurations. Updated tcltest-19.1 to tcltest 2.1
- behavior. Corrected tcltest-25.3 to not falsely report a failure in
- tcltest.test. Bumped to tcltest 2.2.6. [Bugs 960560, 960926]
-
-2004-05-25 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/http.n (http::config): add -urlencoding option (default utf-8)
- * library/http/http.tcl: that specifies encoding conversion of
- * library/http/pkgIndex.tcl: args for http::formatQuery. Previously
- * tests/http.test: undefined, RFC 2718 says it should be
- utf-8. 'http::config -urlencoding {}' returns previous behavior, which
- will throw errors processing non-latin-1 chars. Bumped http package to
- 2.5.0.
-
-2004-05-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (DeleteScriptLimitCallback): Move all deletion
- of script callback hash table entries to happen here so the entries
- are correctly removed at the right time. [Bug 960410]
-
-2004-05-25 Miguel Sofer <msofer@users.sf.net>
-
- * docs/global.n: added details for qualified variable names [Bug
- 959831]
-
-2004-05-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_FindNamespaceVar):
- * tests/namespace.test (namespace-17.10-12): reverted commit of
- 2004-05-23 and removed the tests, as it interferes with the varname
- resolver and there are apps that break (AlphaTk). A fix will have to
- wait for Tcl9.
-
- * generic/tclVar.c: Caching of namespace variables disabled: no simple
- way was found to avoid interfering with the resolver's idea of
- variable existence. A cached varName may keep a variable's name in the
- namespace's hash table, which is the resolver's criterion for
- existence.
-
- * tests/namespace.c (namespace-17.10): testing for interference
- between varname caching and name resolver.
-
-2004-05-25 Kevin Kenny <kennykb@acm.org>
-
- * tests/winFCmd.test: Correct test for the presence of a CD-ROM so
- that it doesn't misdetect some other sort of filesystem with a
- write-protected root as being a CD-ROM drive. [Bug 918267]
-
-2004-05-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/winPipe.test: Protect against path being set
- * tests/unixInit.test: Unset path when done.
- * tests/unload.test (unload-3.1): Verify [pkgb_sub] does not exist.
- Delete interps when done.
- * tests/stringComp.test: stop re-use of string.test test names
- * tests/regexpComp.test: stop re-use of regexp.test test names
- * tests/namespace.test (namespace-46.3): Verify [p] does not exist.
- * tests/http.test: Clear away the custom [bgerror] when done.
- * tests/io.test: Take care to use namespace variables.
- * tests/autoMkindex.test (autoMkindex-5.2): Use variable "result"
- that gets cleaned up.
- * tests/exec.test: Clean up the "path" array.
- * tests/interp.test (interp-9.3): Initialize res, so prior values
- cannot make the test fail.
- * tests/execute.test (execute-8.1): Updated to remove the trace set
- on ::errorInfo. When left in place, that trace can cause later tests
- to fail.
-
-2004-05-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclBasic.c: Removed references to Tcl_RenameCommand from
- * generic/tcl.h: comments. [Bug 848440, second part]
-
- * tests/fCmd.test: Rewrote tests that failed consistently on NFS so
- they either succeed (through slightly more liberal matching of the
- results) or are constrained to not run. [Bug 931312]
-
- * doc/bgerror.n: Use idiomatic open flags for working with log
- files. [Bug 959602]
-
-2004-05-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to
- properly have tclIntType used for smaller values. This corrects [TclX
- Bug 896727] and any other 3rd party extension that created math
- functions but was not yet WIDE_INT aware in them.
-
-2004-05-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (TclInitLimitSupport): Made limits work on
- platforms where sizeof(void*)!=sizeof(int). [Bug 959193]
-
-2004-05-24 Miguel Sofer <msofer@users.sf.net>
-
- * doc/set.n: accurate description of name resolution process,
- referring to namespace.n for details [Bug 959180]
-
-2004-05-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_FindNamespaceVar): [Bug 959052] fixed,
- insuring that no "zombie" variables are found.
- * generic/tclVar.c (TclLookupSimpleVar): comments re [Bug 736729]
- (predecessor of [Bug 959052]) removed.
- * tests/namespace.test: added tests 17.10-12
-
- The patch modifies non-documented behaviour, and passes every test in
- the testsuite. However, scripts relying on the old behaviour may
- break.
- Note that the only behaviour change concerns the creative writing of
- unset variables. More precisely, which variable will be created when
- neither a namespace variable nor a global variable by that name
- exists, as defined by [info vars]. The new behaviour is that the
- namespace resolution process deems a variable to exist exactly when
- [info vars] finds it - ie, either it has value, or else it was "fixed"
- by a call to [variable].
- Note: this patch was removed on 2002-05-25.
-
-2004-05-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclObjLookupVar, TclObjUnsetVar2): fix for new (in
- tcl8.4) exteriorisations of [Bug 736729] due to the use of
- tclNsVarNameType obj types. Reenabling the use of this objType ("VAR
- ref absolute" benchmark down to 66 ms, from 230). Added comments in
- TclLookupSimpleVar explaining my current understanding of [Bug
- 736729].
-
-2004-05-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: fix for [Bug 735335]. The use of tclNsVarNameType
- objs is still disabled, pending resolution of [Bug 736729].
-
-2004-05-21 Miguel Sofer <msofer@users.sf.net>
-
- * tests/namespace.test (namespace-41.3): removed the {knownBug}
- constraint: [Bug 231259] is closed since nov 2001, and the fix of [Bug
- 729692] (INST_START_CMD) makes the test succeed.
-
-2004-05-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclExecute.c (TclExecuteByteCode): Move a few declarations a
- short distance so pre-C99 compilers can cope. Also fix so
- TCL_COMPILE_DEBUG path compiles...
-
-2004-05-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): reorganised TEBC
- automatic variables, defining them in tight blocks instead of at the
- function level. This has three purposes:
- - it simplifies the analysis of individual instructions
- - it is preliminary work to the non-recursive engine
- - it allows a better register allocation by the optimiser; under
- gcc3.3, this results in up to 10% runtime in some tests
-
-2004-05-20 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (TclLimitRemoveAllHandlers):
- * generic/tclBasic.c (DeleteInterpProc):
- * tests/interp.test (interp-34.7): Ensure that all limit callbacks are
- deleted when their interpreters are deleted. [Bug 956083]
-
-2004-05-19 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinFile.c (TclpMatchInDirectory): fix for an issue where
- there was a sneak path from Tcl_DStringFree to SetErrorCode(0). The
- result was that the error code could be reset between a call to
- FindFirstFileEx and the check of its status return, leading to a
- bizarre error return of {POSIX unknown {No error}}. (Found in
- unplanned test - no incident logged at SourceForge.)
-
-2004-05-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/interp.test (interp-34.3): Rewrite this test to see if a time
- limit can catch a tight bytecode loop, a maximally aggressive
- denial-of-service attack.
- * generic/tclInterp.c (Tcl_LimitCheck): Fix the sense of checks to see
- whether a time limit has been extended.
-
- * tests/*.test: Many minor fixes, including ensuring that every test
- is run (so constraints control whether the test is doing anything) and
- making sure that constraints are always set using the API instead of
- poking around inside tcltest's internal datastructures. Also got rid
- of all trailing whitespace lines from the test suite!
-
-2004-05-19 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem
- * generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry
- 2001-09-26. The fix done at that time is incomplete. It is possible to
- get around it if the actual read operation is defered and not executed
- in the event handler itself. Instead of tracking if we are in an read
- caused by a synthesized fileevent we now track if the OS has delivered
- a true event = actual data and bypass the driver if a read finds that
- there is no actual data waiting. The flag is cleared by a short or
- full read.
-
- ***POTENTIAL INCOMPATIBILITY*** for channel drivers.
-
-2004-05-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'.
- * tests/cmdAH.test: added test for this bug.
-
- * doc/FileSystem.3: better documentation of refCount requirements of
- some FS functions (Bug 956126)
-
-2004-05-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclTest.c (TestgetintCmd): Made the tests in get.test check
- * tests/get.test: Tcl_GetInt() since the core now
- avoids that function.
-
-2004-05-18 Kevin B. Kenny <kennykb@acm.org>
-
- * compat/strftime.c (_fmt, ISO8601Week):
- * doc/clock.n:
- * tests/clock.test: Major rework to the handling of ISO8601 week
- numbers. Now passes all the %G and %V test cases on Windows, Linux and
- Solaris [Bugs 500285, 500389, and 852944]
-
-2004-05-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/append.n, doc/upvar.n: Added example.
-
-2004-05-18 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: now generates a tclConfig.sh from Pat Thoyts [Patch
- 909911]
-
-2004-05-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n: Improve clarity (based on [Patch 955361] by Peter
- Spjuth)
-
- * tools/man2help2.tcl (macro,SHmacro): Added support for subsection
- (.SS) header macros.
-
- * doc/interp.n: Added user documentation for the TIP#143 resource
- limits and some examples.
-
- * generic/tclInterp.c (Tcl_LimitCheck, Tcl_LimitTypeReset): Reset the
- limit-exceeded flag when removing a limit.
-
-2004-05-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): added comments to
- classify the variables according to their use in TEBC.
-
-2004-05-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/global.n, doc/uplevel.n: Added an example.
-
- * tests/info.test (info-3.1): Corrected test result back to what it
- used to be in Tcl 7.* now that command counts are being correctly kept
-
- * generic/tclExecute.c (TEBC:INST_START_CMD): Make sure that the
- command-count is always advanced. Allows TIP#143 limits to tell that
- work is being done.
-
- * doc/list.n: Updated example to fit with the unified format.
- * doc/seek.n: Added some examples.
-
-2004-05-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * win/tclWinFile.c:
- * tests/cmdAH.test: fix to (Bug 954263) where 'file executable' was
- case-sensitive.
-
-2004-05-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/OpenFileChnl.3: Documented type of 'offset' argument to Tcl_Seek
- was wrong. [Bug 953374]
-
-2004-05-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): remove one level of
- indirection for compiledLocals addressing.
-
-2004-05-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_CALL_FUNC1): bugfix; restored
- (DE)CACHE_STACK_INFO pair around the call - the user defined math
- function could cause a recursive call to TEBC.
-
-2004-05-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_DeleteInterp):
- * generic/tclExecute.c (INST_START_CMD): interp deletion now modifies
- the compileEpoch, eliminating the need for the check for interp
- deletion in INST_START_CMD.
-
-2004-05-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.h:
- * generic/tclCompile.c:
- * generic/tclExecute.c: changed implementation of {expand}, last
- chance while in alpha as ...
-
- ***POTENTIAL INCOMPATIBILITY***
- Scripts precompiled with ProComp under previous tcl8.5a versions may
- malfunction due to changed instruction numbers for
- INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM and INST_START_CMD.
-
-2004-05-14 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclInt.decls: Promoted TclpLocaltime and TclpGmtime
- * generic/tclIntDecls.h: from Unix-specific stubs to the generic
- * generic/tclIntPlatDecls.h: internal Stubs table. Reran 'genstubs'
- * generic/tclStubInit.c:
- * unix/tclUnixPort.h:
-
- * generic/tclClock.c: Changed a buggy 'GMT' timezone specification
- to the correct 'GMT0'. [Bug 922848]
-
- * unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to
- unix/tclUnixTime.c where they belong.
-
- * unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone,
- ThreadSafeGMTime [removed],
- ThreadSafeLocalTime [removed],
- SetTZIfNecessary, CleanupMemory):
- Restructured to make sure that the same mutex protects all calls to
- localtime, gmtime, and tzset. Added a check in front of those calls to
- make sure that the TZ env var hasn't changed since the last call to
- tzset, and repeat tzset if necessary. [Bug 942078] Removed a buggy
- test of the Daylight Saving Time information in 'gettimeofday' in
- favor of applying 'localtime' to a known value. [Bug 922848]
-
- * tests/clock.test (clock-3.14): Added test to make sure that changes
- to $env(TZ) take effect immediately.
-
- * win/tclWinTime.c (TclpLocaltime, TclpGmtime): Added porting layer
- for 'localtime' and 'gmtime' calls.
-
-2004-05-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c:
- * generic/tclCompile.h: the math functions receive a pointer to top of
- the stack (tosPtr) instead of the execution environment (eePtr). First
- step towards a change in the execution stack management - it is now
- only used within TEBC.
-
-2004-05-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP#143 IMPLEMENTATION
-
- * generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode):
- * generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking.
- * generic/tclInterp.c (Tcl_Limit*): Public limit API.
- * generic/tcl.decls:
- * tests/interp.test: Basic tests of command limits.
-
- * doc/binary.n: TIP#129 IMPLEMENTATION [Patch 858211]
- * generic/tclBinary.c: Note that the test suite probably has many more
- * tests/binary.test: failures now due to alterations in constraints.
-
-2004-05-12 Miguel Sofer <msofer@users.sf.net>
-
- Optimisations for INST_START_CMD [Bug 926164].
- * generic/tclCompile.c (TclCompileScript): avoid emitting
- INST_START_CMD as the first instruction in a bytecoded Tcl_Obj. It is
- not needed, as the checks are done before calling TEBC.
- * generic/tclExecute.c (TclExecuteByteCode): runtime peephole
- optimisation: check at INST_POP if the next instruction is
- INST_START_CMD, in which case we fall through.
-
-2004-05-11 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/split.n, doc/join.n: Updated examples and added more.
-
-2004-05-11 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/glob.n: documented behaviour of symbolic links with 'glob -types
- d' (Bug 951489)
-
-2004-05-11 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/scan.n: Updated the examples to be clearer about their relevance
- to the scan command.
-
-2004-05-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/scan.n: Added examples.
-
-2004-05-10 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c (BuildCommandLine): Moved non-obvious appending
- logic to outside the loop and added commentary for its purpose. Also
- use the existence of contents in the linePtr rather than the scratch
- DString post the append, as this more clear.
-
- (TclpCreateProcess): When under NT, with no console, and executing a
- DOS application, the path priming does not need an ending space as
- BuildCommandLine() will do this for us.
-
-2004-05-08 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c:
- * generic/tclIOUtil.c: remove some compiler warnings on MacOS X.
-
-2004-05-07 Chengye Mao <chengye.geo@yahoo.com>
-
- * win/tclWinPipe.c: refixed bug 789040 re-entered in rev 1.41. Let's
- be careful and don't re-enter previously fixed bugs.
-
-2004-05-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/format.n: Added examples.
-
-2004-05-07 Miguel Sofer <msofer@users.sf.net>
-
- * doc/unset.n: added upvar.n to the "see also" list
-
-2004-05-07 Reinhard Max <max@suse.de>
-
- * generic/tclEncoding.c:
- * tests/encoding.test: added support and tests for translating
- embedded null characters between real nullbytes and the internal
- representation on input/output [Bug 949905].
-
-2004-05-07 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c:
- * generic/tclIOUtil.c:
- * generic/tclFileSystem.h:
- * tests/fileSystem.test: fix for [Bug 943995], in which vfs-registered
- root volumes were not handled correctly as glob patterns in all
- circumstances.
-
-2004-05-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclObj.c (TclFreeObj): made TclFreeObj use the new macro
- TclFreeObjMacro(), so that the allocation and freeing of Tcl_Obj is
- defined in a single spot (the macros in tclInt.h), with the exception
- of the TCL_MEM_DEBUG case.
- The #ifdef logic for the corresponding macros has been reformulated to
- make it clearer.
-
-2004-05-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/break.n, doc/continue.n, doc/for.n, doc/while.n: More examples.
-
-2004-05-05 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (unixInit-2.10): Test correction for Mac OSX.
- Be sure to consistently compare normalized path names. Thanks to
- Steven Abner (tauvan). [Bug 948177]
-
-2004-05-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is no
- such API. [Bug 848440]
-
-2004-05-05 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinSock.c (SocketEventProc) : connect errors should fire both
- the readable and writable handlers because this is how it works on
- UNIX [Bug 794839]
-
- * generic/tclEncoding.c (TclFinalizeEncodingSubsystem):
- FreeEncoding(systemEncoding); moved to before the hash table iteration
- as it was causing a double free attempt under some conditions.
-
- * win/coffbase.txt: Added the tls extension to the list of preferred
- load addresses.
-
-2004-05-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/fileSystem.test (filesystem-1.39): replace 'file volumes'
- * tests/fileName.test (filename-12.9,10): lindex with direct C:/
- hard-coded because A:/ was being used and that is empty for most.
-
- * tests/winFCmd.test (winFCmd-16.12): test volumerelative $HOME
-
-2004-05-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclAlloc.c: Make sure Tclp*Alloc* routines get
- * generic/tclInt.h: declared in the TCL_MEM_DEBUG and
- * generic/tclThreadAlloc.c: TCL_THREADS configuration. [Bug 947564]
-
- * tests/tcltest.test: Test corrections for Mac OSX. Thanks to Steven
- Abner (tauvan). [Bug 947440]
-
-2004-05-04 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclEvent.c (TclSetLibraryPath): Suppress a warning.
-
-2004-05-03 Andreas Kupries <andreask@activestate.com>
-
- * Applied [Patch 868853], fixing a mem leak in TtySetOptionProc.
- Report and Patch provided by Stuart Cassoff <stwo@users.sf.net>.
-
-2004-05-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (TclCreateProc): comments corrected.
-
-2004-05-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript): setting the compilation
- namespace outside of the loop.
-
-2004-05-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:
- * generic/tclInt.h: reverted fix for [Bug 926445] of 2004-04-02,
- restoring TCL_ALIGN to the header file. Todd Helfter reported that the
- macro is required by tbcload.
-
-2004-05-03 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWin32Dll.c (TclpCheckStackSpace):
- * tests/stack.test (stack-3.1): Fix for undetected stack overflow in
- TclReExec on Windows. [Bug 947070]
-
-2004-05-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl: Corrected unique prefix matching of
- interactive command completion in [unknown]. [Bug 946952]
-
-2004-05-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (TclObjInvokeProc):
- * tests/proc.test (proc-3.6): fix for bad quoting of multi-word proc
- names in error messages [Bug 942757]
-
-2004-04-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/glob.n, doc/incr.n, doc/set.n: More examples.
- * doc/if.n, doc/rename.n, doc/time.n:
-
-2004-04-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Replaced Kevin Kenny's temporary
- * generic/tclThreadAlloc.c: fix for Bug 945447 with a cleaner,
- more permanent replacement.
-
-2004-04-30 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclThreadAlloc.c: Added a temporary (or so I hope!)
- inclusion of "tclWinInt.h" to avoid problems when compiling on
- Win32-VC++ with --enable-threads. [Bug 945447]
-
-2004-04-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/puts.n: Added a few examples.
-
-2004-04-29 Don Porter <dgp@users.sourceforge.net>
-
- * tests/execute.test (execute-8.2): Avoid crashes when there is
- limited system stack space (threads-enabled).
-
-2004-04-28 Miguel Sofer <msofer@users.sf.net>
-
- * doc/global.n:
- * doc/upvar.n:
- * generic/tclVar.c (ObjMakeUpvar):
- * tests/upvar.test (upvar-8.11):
- * tests/var.test (var-3.11): Avoid creation of unusable variables:
- [Bug 600812] [TIP 184].
-
-2004-04-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n: Fixed fault in documentation of -index option [943448]
-
-2004-04-26 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixFCmd.c (TclpObjNormalizePath): Corrected improper
- positioning of returned checkpoint. [Bug 941108]
-
-2004-04-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/open.n, doc/close.n: Updated (thanks to David Welton) to be
- clearer about pipeline errors and added example to open(n) that shows
- simple pipeline use. [Patches 941377,941380]
-
- * doc/DictObj.3: Added warning about the use of Tcl_DictObjDone and an
- example of use of iteration. [Bug 940843]
-
- * doc/Thread.3: Reworked to remove references to testing interfaces
- and instead promote the use of the Thread package. [Patch 932527]
- Also reworked and reordered the page for better readability.
-
-2004-04-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Removed obsolete declarations and #include's.
- * generic/tclInt.h: [Bugs 926459, 926486]
-
-2004-04-24 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWin32Dll.c (DllMain): Added DisableThreadLibraryCalls() for
- the DLL_PROCESS_ATTACH case. We're not interested in knowing about
- DLL_THREAD_ATTACH, so disable the notices.
-
-2004-04-24 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclPort.h:
- * macosx/Makefile:
- * unix/Makefile.in: followup on tcl header reform [FR 922727]: removed
- use of relative #include paths in tclPort.h to allow installation of
- private headers outside of tcl source tree; added 'unix' dir to
- compiler header search path; add newly required tcl private headers to
- Tcl.framework on Mac OSX.
-
-2004-04-23 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (Tcl_SetChannelOption): Fixed [SF Tcl Bug 930851].
- When changing the eofchar we have to zap the related flags to prevent
- them from prematurely aborting the next read.
-
-2004-04-25 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix to [Bug 940281]. Tcl_FSJoinPath will now
- always return a valid Tcl_Obj when the input is valid.
- * generic/tclIOUtil.c: fix to [Bug 931823] for a more consistent
- Tcl_FSPathSeparator() implementation which allows filesystems not to
- implement their Tcl_FSFilesystemSeparatorProc if they wish to use the
- default '/'. Also fixed associated memory leak seen with, e.g., tclvfs
- package.
- * doc/FileSystem.3: documented Tcl_FSJoinPath return values more
- clearly, and Tcl_FSFilesystemSeparatorProc requirements.
-
-2004-04-23 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWin32Dll.c: Removed my mistake from 4/19 of adding an exit
- handler to TclWinInit. TclWinEncodingsCleanup called from
- TclFinalizeFilesystem does the Tcl_FreeEncoding for us.
-
- * win/tclWinChan.c (Tcl_MakeFileChannel): Case for CloseHandle
- returning zero and not throwing a
- RaiseException(EXCEPTION_INVALID_HANDLE) now being done.
-
-2004-04-22 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclEvent.c: TclSetLibraryPath's use of caching the stringrep
- of the pathPtr object to TclGetLibraryPath called from another thread
- was ineffective if the original's stringrep had been invalidated as
- what happens when it gets muted to a list.
-
- * win/tclWinTime.c: If the Tcl_ExitProc (StopCalibration) is called
- from the stack frame of DllMain's PROCESS_DETACH, the wait operation
- should timeout and continue.
-
- * generic/tclInt.h:
- * generic/tclThread.c:
- * generic/tclEvent.c:
- * unix/tclUnixThrd.c:
- * win/tclWinThrd.c: Provisions made so masterLock, initLock, allocLock
- and joinLock mutexes can be recovered during Tcl_Finalize.
-
-2004-04-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/switch.n: Reworked the examples to be more systematically named
- and to cover some TIP#75 capabilities.
-
- * doc/cd.n: Documentation clarification from David Welton.
-
- * doc/exec.n: Added some examples, Windows ones from Arjen Markus and
- Unix ones by myself.
-
-2004-04-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/Hash.3: Added note to Tcl_{First,Next}HashEntry docs that
- deleting the element they return is supported (and is in fact the only
- safe update you can do to the structure of a hashtable while an
- iteration is going over it.)
-
- * doc/bgerror.n: Added example from David Welton. [Patch 939473]
-
- * doc/after.n: Added examples from David Welton. [Patch 938820]
-
-2004-04-19 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWin32Dll.c: Added an exit handler in TclWinInit() so
- tclWinTCharEncoding could be freed during Tcl_Finalize().
-
- * generic/tclEncoding.c: Added FreeEncoding(systemEncoding) in
- TclFinalizeEncodingSubsystem because its ref count was incremented in
- TclInitEncodingSubsystem.
-
-2004-04-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/read.n: Added example from David Welton. [Patch 938056]
-
-2004-04-19 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclObj.c (Tcl_GetDoubleFromObj) Corrected "short circuit"
- conversion of int to double. Reported by Jeff Hobbs on the Tcl'ers
- Chat.
-
-2004-04-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lreplace.n, doc/lrange.n, doc/llength.n: More examples for
- * doc/linsert.n, doc/lappend.n: the documentation.
-
-2004-04-16 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3: Corrected documentation of Tcl_FSUtime, and the
- corresponding filesystem driver Tcl_FSUtimeProc. [Bug 935838]
-
-2004-04-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/socket.n: Added example from [Patch 936245].
- * doc/gets.n: Added example based on [Patch 935911].
-
-2004-04-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclClock.c (Tcl_ClockObjCmd): Minor fault in a [clock
- clicks] error message.
-
-2004-04-07 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinInit.c (TclpSetInitialEncodings): note that WIN32_CE is
- also a unicode platform.
- * generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable):
- * generic/tclInt.h: Correct handling of UTF
- * unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually
- * win/tclWinFile.c (TclpFindExecutable): "clean", allowing the
- * win/tclWinInit.c (TclpInitLibraryPath): loading of Tcl from paths
- that contain multi-byte chars on Windows [Bug 920667]
-
- * win/configure: define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC,
- * win/configure.in: TCL_LIB_SPEC, TCL_PACKAGE_PATH in tclConfig.sh.
-
-2004-04-06 Don Porter <dgp@users.sourceforge.net>
-
- Patch 922727 committed. Implements three changes:
-
- * generic/tclInt.h: Reworked the Tcl header files into a clean
- * unix/tclUnixPort.h: hierarchy where tcl.h < tclPort.h < tclInt.h
- * win/tclWinInt.h: and every C source file should #include
- * win/tclWinPort.h: at most one of those files to satisfy its
- declaration needs. tclWinInt.h and tclWinPort.h also better organized
- so that tclWinPort.h includes the Windows implementation of
- cross-platform declarations, while tclWinInt.h makes declarations that
- are available on Windows only.
-
- * generic/tclBinary.c (TCL_NO_MATH): Deleted the generic/tclMath.h
- * generic/tclMath.h (removed): header file. The internal Tcl
- * macosx/Makefile (PRIVATE_HEADERS): header, tclInt.h, has a
- * win/tcl.dsp: #include <math.h> directly,
- and file external to Tcl needing libm should do the same.
-
- * win/Makefile.in (WIN_OBJS): Deleted the win/tclWinMtherr.c file.
- * win/makefile.bc (TCLOBJS): It's a vestige from matherr() days
- * win/makefile.vc (TCLOBJS): gone by.
- * win/tcl.dsp:
- * win/tclWinMtherr.c (removed):
-
- End Patch 922727.
-
- * tests/unixInit.test (unixInit-3.1): Default encoding on Darwin
- systems is utf-8. Thanks to Steven Abner (tauvan). [Bug 928808]
-
-2004-04-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/cmdAH.test (cmdAH-18.2): Added constraint because
- access(...,X_OK) is defined to be permitted to be meaningless when
- running as root, and OSX exhibits this. [Bug 929892]
-
-2004-04-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:
- * generic/tclInt.h: removed the macro TCL_ALIGN() from tclInt.h,
- replaced by the static macro ALIGN() in tclCompile.c [Bug 926445]
-
-2004-04-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.h: removed redundant #ifdef _TCLINT [Bug 928415],
- reported by tauvan.
-
-2004-04-02 Don Porter <dgp@users.sourceforge.net>
-
- * tests/tcltest.test: Corrected constraint typos: "nonRoot" ->
- "notRoot". Thanks to Steven Abner (tauvan). [Bug 928353]
-
-2004-04-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Removed obsolete tclBlockTime* declarations. [Bug
- 926454]
-
-2004-04-01 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: Fix to privately reported vfs bug with 'glob
- -type d -dir . *' across a vfs boundary. No tests for this are
- currently possible without effectively moving tclvfs into Tcl's test
- suite.
-
-2004-03-31 Don Porter <dgp@users.sourceforge.net>
-
- * doc/msgcat.n: Clarified message catalog file encodings. [Bug 811457]
- * library/msgcat/msgcat.tcl: Updated internals to make use of [dict]s
- to store message catalog data and to use [source -encoding utf-8] to
- access catalog files. Thanks to Michael Sclenker. [Patch 875055, RFE
- 811459] Corrected [mcset] to be able to successfully set a translation
- to the empty string. [mcset $loc $src {}] was incorrectly set the $loc
- translation of $src back to $src. Also changed [ConvertLocale] to
- minimally require a non-empty "language" part in the locale value. If
- not, an error raised prompts [Init] to keep looking for a valid locale
- value, or ultimately fall back on the "C" locale. [Bug 811461].
- * library/msgcat/pkgIndex.tcl: Bump to msgcat 1.4.1.
-
-2004-03-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclHash.c (HashStringKey): Cleaned up. This function is not
- faster, but it is a little bit clearer.
- * generic/tclLiteral.c (HashString): Applied logic from HashObjKey.
- * generic/tclObj.c (HashObjKey): Rewrote to fix fault which hashed
- every single-character object to the same hash bucket. The new code is
- shorter, simpler, clearer, and (happily) faster.
-
-2004-03-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC): reverting to the previous method for
- async tests in TEBC, as the new method turned out to be too costly.
- Async tests now run every 64 instructions.
-
-2004-03-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: New instruction code INST_START_CMD that
- * generic/tclCompile.h: allows checking the bytecode's validity
- * generic/tclExecute.c: [Bug 729692] and the interp's readyness
- * tests/interp.test (18.9): [Bug 495830] before running the command.
- * tests/proc.test (7.1): It also changes the mechanics of the async
- * tests/rename.test (6.1): tests in TEBC, doing it now at command
- start instead of every 16 instructions.
-
-2004-03-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: Fix to Windows glob where the pattern is a
- * generic/tclIOUtil.c: volume relative path or a network share [Bug
- * tests/fileName.test: 898238]. On windows 'glob' will now return
- * tests/fileSystem.test: the results of 'glob /foo/bar' and 'glob
- \\foo\\bar' as 'C:/foo/bar', i.e. a correct absolute path (rather than
- a volume relative path).
-
- Note that the test suite does not test commands like
- 'glob //Machine/Shared/*' (on a network share).
-
-2004-03-30 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: Fix to filename bugs recently
- * tests/fileName.test: introduced [Bug 918320].
-
-2004-03-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c (Tcl_Main, StdinProc): Append newline only
- * tests/basic.test (basic-46.1): to incomplete scripts
- as part of multi-line script construction. Do not add an extra
- trailing newline to the complete script. [Bug 833150]
-
-2004-03-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript): corrected possible segfault
- when a compilation returns TCL_OUTLINE_COMPILE after having grown the
- compile environment [Bug 925121].
-
-2004-03-27 Miguel Sofer <msofer@users.sf.net>
-
- * doc/array.n: added documentation for trace-realted behaviour of
- 'array get' [Bug 449893]
-
-2004-03-26 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bumped version number to 8.5a2 to distinguish
- * tools/tcl.wse.in: HEAD of CVS development from the recent 8.5a1
- * unix/configure.in: release.
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure.in:
-
- * unix/configure: autoconf-2.57
- * win/configure:
-
-2004-03-26 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: Fix to Windows-only volume relative path
- * tests/fileSystem.test: normalization. [Bug 923568]. Also fixed
- another volume relative bug found while testing.
-
-2004-03-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (NsEnsembleImplementationCmd): Fix messed up
- handling of strncmp result which just happened to work in some libc
- implementations. [Bug 922752]
-
-2004-03-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/StringObj.3: Inverted the sense of the documentation of how the
- bytes parameter is documented to match behaviour. [Bug 921464]
-
-2004-03-19 Kevin B. Kenny <kennykb@acm.org>
-
- * compat/strtoll.c:
- * compat/strtoull.c:
- * generic/tclIntDecls.h:
- * generic/tclMain.c:
- * generic/tclObj.c:
- * win/tclWinDde.c:
- * win/tclWinReg.c:
- * win/tclWinTime.c: Made HEAD build on Windows VC++ again.
-
-2004-03-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclIntDecls.h: Made HEAD build on Solaris again by applying
- fix recommended by Don Porter.
-
-2004-03-18 Reinhard Max <max@suse.de>
-
- * generic/tclIntDecls.h: Removed TclpTime_t. It wasn't really needed,
- * generic/tclInt.h: but caused warnings related to
- * generic/tclInt.decls: strict aliasing with GCC 3.3.
- * generic/tclClock.c:
- * generic/tclDate.c:
- * generic/tclGetDate.y:
- * win/tclWinTime.c:
- * unix/tclUnixTime.c:
-
- * generic/tclNamesp.c: Added temporary pointer variables to work
- * generic/tclStubLib.c: around warnings related to
- * unix/tclUnixChan.c: strict aliasing with GCC 3.3.
-
- * unix/tcl.m4: Removed -Wno-strict-aliasing.
-
-2004-03-18 Daniel Steffen <das@users.sourceforge.net>
-
- Removed support for Mac OS Classic platform [Patch 918142]
-
- * README:
- * compat/string.h:
- * doc/Encoding.3:
- * doc/FileSystem.3:
- * doc/Init.3:
- * doc/Macintosh.3 (removed):
- * doc/OpenFileChnl.3:
- * doc/OpenTcp.3:
- * doc/SourceRCFile.3:
- * doc/Thread.3:
- * doc/clock.n:
- * doc/exec.n:
- * doc/fconfigure.n:
- * doc/file.n:
- * doc/filename.n:
- * doc/glob.n:
- * doc/open.n:
- * doc/puts.n:
- * doc/resource.n (removed):
- * doc/safe.n:
- * doc/source.n:
- * doc/tclvars.n:
- * doc/unload.n:
- * generic/README:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclAlloc.c:
- * generic/tclBasic.c:
- * generic/tclCmdAH.c:
- * generic/tclDate.c:
- * generic/tclDecls.h:
- * generic/tclFCmd.c:
- * generic/tclFileName.c:
- * generic/tclGetDate.y:
- * generic/tclIOCmd.c:
- * generic/tclIOUtil.c:
- * generic/tclInitScript.h:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclMain.c:
- * generic/tclMath.h:
- * generic/tclNotify.c:
- * generic/tclPathObj.c:
- * generic/tclPlatDecls.h:
- * generic/tclPort.h:
- * generic/tclStubInit.c:
- * generic/tclTest.c:
- * generic/tclThreadJoin.c:
- * library/auto.tcl:
- * library/init.tcl:
- * library/package.tcl:
- * library/safe.tcl:
- * library/tclIndex:
- * mac/AppleScript.html (removed):
- * mac/Background.doc (removed):
- * mac/MW_TclAppleScriptHeader.h (removed):
- * mac/MW_TclAppleScriptHeader.pch (removed):
- * mac/MW_TclBuildLibHeader.h (removed):
- * mac/MW_TclBuildLibHeader.pch (removed):
- * mac/MW_TclHeader.h (removed):
- * mac/MW_TclHeader.pch (removed):
- * mac/MW_TclHeaderCommon.h (removed):
- * mac/MW_TclStaticHeader.h (removed):
- * mac/MW_TclStaticHeader.pch (removed):
- * mac/MW_TclTestHeader.h (removed):
- * mac/MW_TclTestHeader.pch (removed):
- * mac/README (removed):
- * mac/bugs.doc (removed):
- * mac/libmoto.doc (removed):
- * mac/morefiles.doc (removed):
- * mac/porting.notes (removed):
- * mac/tclMac.h (removed):
- * mac/tclMacAETE.r (removed):
- * mac/tclMacAlloc.c (removed):
- * mac/tclMacAppInit.c (removed):
- * mac/tclMacApplication.r (removed):
- * mac/tclMacBOAAppInit.c (removed):
- * mac/tclMacBOAMain.c (removed):
- * mac/tclMacChan.c (removed):
- * mac/tclMacCommonPch.h (removed):
- * mac/tclMacDNR.c (removed):
- * mac/tclMacEnv.c (removed):
- * mac/tclMacExit.c (removed):
- * mac/tclMacFCmd.c (removed):
- * mac/tclMacFile.c (removed):
- * mac/tclMacInit.c (removed):
- * mac/tclMacInt.h (removed):
- * mac/tclMacInterupt.c (removed):
- * mac/tclMacLibrary.c (removed):
- * mac/tclMacLibrary.r (removed):
- * mac/tclMacLoad.c (removed):
- * mac/tclMacMath.h (removed):
- * mac/tclMacNotify.c (removed):
- * mac/tclMacOSA.c (removed):
- * mac/tclMacOSA.r (removed):
- * mac/tclMacPanic.c (removed):
- * mac/tclMacPkgConfig.c (removed):
- * mac/tclMacPort.h (removed):
- * mac/tclMacProjects.sea.hqx (removed):
- * mac/tclMacResource.c (removed):
- * mac/tclMacResource.r (removed):
- * mac/tclMacSock.c (removed):
- * mac/tclMacTclCode.r (removed):
- * mac/tclMacTest.c (removed):
- * mac/tclMacThrd.c (removed):
- * mac/tclMacThrd.h (removed):
- * mac/tclMacTime.c (removed):
- * mac/tclMacUnix.c (removed):
- * mac/tclMacUtil.c (removed):
- * mac/tcltkMacBuildSupport.sea.hqx (removed):
- * tests/all.tcl:
- * tests/binary.test:
- * tests/cmdAH.test:
- * tests/cmdMZ.test:
- * tests/fCmd.test:
- * tests/fileName.test:
- * tests/fileSystem.test:
- * tests/interp.test:
- * tests/io.test:
- * tests/ioCmd.test:
- * tests/load.test:
- * tests/macFCmd.test (removed):
- * tests/osa.test (removed):
- * tests/resource.test (removed):
- * tests/socket.test:
- * tests/source.test:
- * tests/unload.test:
- * tools/cvtEOL.tcl (removed):
- * tools/genStubs.tcl:
- * unix/Makefile.in:
- * unix/README:
- * unix/mkLinks:
- * unix/tcl.spec:
- * win/README.binary:
- * win/tcl.dsp:
-
-2004-03-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n: Improved examples on the advanced capabilities of
- lsearch (with the right options, set element removal can be done)
- following discussion on tkchat.
-
-2004-03-16 Don Porter <dgp@users.sourceforge.net>
-
- * doc/catch.n: Compiled [catch] no longer fails to catch syntax
- errors. Removed the claims in the documentation that it does.
- * doc/return.n: Updated example to use [dict merge].
-
-2004-03-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure, unix/tcl.m4: add -Wno-strict-aliasing for GCC to
- suppress useless type puning warnings.
-
-2004-03-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/file.n: *roff formatting fix. [Bug 917171]
-
-2004-03-15 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinNotify.c: Fixed a mistake where the return value of
- MsgWaitForMultipleObjectsEx for "a message is in the queue" wasn't
- accurate. I removed the check on the case result==(WAIT_OBJECT_0 + 1)
- This was having the error of falling into GetMessage and waiting there
- by accident, which wasn't alertable through Tcl_AlertNotifier. I'll do
- some more study on this and try to find-out why.
-
-2004-03-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- IMPLEMENTATION OF TIP#163
- * generic/tclDictObj.c (DictMergeCmd): This is based on work by Joe
- * tests/dict.test (dict-20.*): English in Tcl [FRQ 745851]
- * doc/dict.n: but not exactly.
-
-2004-03-10 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclGetDate.y (TclGetDate): Fix so that [clock scan
- <timeOfDay> -gmt true] uses the GMT base date instead of the local
- one. [Bug 913513]
- * tests/clock.test: Added test cases for wrong ISO8601 week number
- [Bug 500285] and wrong GMT base date [Bug 913513]. Several tests still
- fail on Windows, and these are actual faults in [clock scan]. Fix is
- still pending.
- * generic/tclDate.c: Regenerated.
-
-2004-03-08 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: Fix to 'glob -path' near the root
- * tests/fileName.test: of the filesystem. [Bug 910525]
-
-2004-03-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c (TclParseInit): Modified TclParseInit so
- * generic/tclTest.c ([testexprparser]): that Tcl_Parse initialization
- conforms to documented promised about what fields will not be
- modified by what Tcl_Parse* routines. [Bug 910595]
-
-2004-03-05 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/configure.in: Check for define of MWMO_ALERTABLE in winuser.h.
- * win/tclWinPort.h: If MWMO_ALERTABLE is not defined in winuser.h then
- define it. This is needed for Mingw.
-
-2004-03-05 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclTest.c: Modified TesteventObjCmd to use a
- Tcl_QueuePosition in place of an 'int' for the enumerated queue
- position, to avoid a compiler warning on SGI. [Bug 771960]
-
-2004-03-05 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/registry.test: Applied fix from [Patch 910174] to make the test
- for an English-language system include any country code, rather than
- just English-United States.1252. Thanks to Pat Thoyts for the changes.
-
-2004-03-04 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/registry.test: Applied fixed from [Bug 766159] to skip two
- tests on Win98 that depend on a Unicode registry (NT specific).
-
-2004-03-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h (TclParseInit): Factored the common code
- * generic/tclParse.c (TclParseInit): for initializing a Tcl_Parse
- * generic/tclParseExpr.c: struct into one routine.
-
-2004-03-04 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/reg/pkgIndex.tcl: Added TIP #100 support to the
- * win/tclWinReg.c: registry package [patch 903831]
- This provides a Windows test of the TIP #100 mechanism and a sample to
- show how unloading an extension can be done.
-
-2004-03-04 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/dltest/pkgua.c: Fix minor syntax problems. [Bug 909288]
-
-2004-03-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.5a1 TAGGED FOR RELEASE ***
-
- * changes: updated for 8.5a1
-
-2004-03-03 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: default environment variable for VC++ is %MSDevDir%
- not %MSVCDir%, although vcvars32.bat sets both.
-
- * win/tclWinNotify.c (Tcl_WaitForEvent) : Allows an idling notifier to
- service "Asynchronous Procedure Calls" from its wait state. Only
- useful for extension authors who decide they might want to try
- "completion routines" with WriteFileEx(), as an example. From
- experience, I recommend that "completion ports" should be used instead
- as the execution of the callbacks are more managable.
-
-2004-03-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README: update patchlevel to 8.5a1
- * generic/tcl.h:
- * tools/tcl.wse.in, tools/tclSplash.bmp:
- * unix/configure, unix/configure.in, unix/tcl.spec:
- * win/README.binary, win/configure, win/configure.in:
-
- * unix/tcl.m4: update HP-11 build libs setup
-
-2004-03-01 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow 64-bit enabling on
- IRIX64-6.5* systems. [Bug 218561]
- * unix/configure: autoconf-2.57
-
- * generic/tclTrace.c (TclCheckInterpTraces): The TIP 62
- * generic/tclTest.c (TestcmdtraceCmd): implementation introduced a
- * tests/trace.test (trace-29.10): bug by testing the CallFrame
- level instead of the iPtr->numLevels level when deciding what traces
- created by Tcl_Create(Obj)Trace to call. Added test to expose the
- error, and made fix. [FRQ 462580]
-
-2004-02-28 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fileSystem.test: fix to Tcl Bug 905163.
- * tests/fileName.test: fix to Tcl Bug 904705.
-
- * doc/{various}.n: removed 'the the' typos.
-
-2004-02-26 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: fixed copyright year in Tcl.framework Info.plist
-
-2004-02-25 Don Porter <dgp@users.sourceforge.net>
-
- * tests/basic.test: Made several tests more robust to the
- * tests/cmdMZ.test: list-quoting of path names that might contain
- * tests/exec.test: Tcl-special chars like { or [. Should help us
- * tests/io.test: sort out [Bug 554068]
- * tests/pid.test:
- * tests/socket.test:
- * tests/source.test:
- * tests/unixInit.test:
-
-2004-02-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclLoad.c (Tcl_LoadObjCmd): Missing dereference caused
- segfault with non-loadable extension. [Bug 904307]
-
- * unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with very
- long hostnames. [Bug 888777]
-
-2004-02-25 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinDde.c: Removed some gcc warnings - except for the
- -Wconversion warning for GetGlobalAtomName. gcc is just wrong about
- this.
-
-2004-02-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- IMPLEMENTATION OF TIP#100 FROM GEORGIOS PETASIS
- * generic/tclLoad.c (Tcl_UnloadObjCmd): Implementation.
- * tests/unload.test: Test suite.
- * unix/dltest/pkgua.c: Helper for test suite.
- * doc/unload.n: Documentation.
- Also assorted changes (mostly small) to several other files.
-
-2004-02-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/regc_locale.c (cclass): Buffer was having its size reset
- instead of being released => memleak. [Bug 902562]
-
-2004-02-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclLoad.c (Tcl_LoadObjCmd): Fixed memory leak due to an
- improper error exit route.
-
-2004-02-20 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinSock.c (SocketThreadExitHandler): Don't call
- TerminateThread when WaitForSingleObject returns a timeout.
- Tcl_Finalize called from DllMain will pause all threads. Trust that
- the thread will get the close notice at a later time if it does ever
- wake up before being cleaned up by the system anyway.
-
-2004-02-17 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n:
- * library/tcltest/tcltest.tcl: Changed -verbose default value to
- {body error} so that detailed information on unexpected errors in
- tests is provided by default, even after the fix for [Bug 725253]
-
-2004-02-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/unixInit.test (unixInit-7.1):
- * unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist to
- prevent crash condition [Bug 772288]
-
-2004-02-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Bozo mistake in memory
- releasing order when in an error case. [Bug 898910]
-
-2004-02-16 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclTrace.c (TclTraceExecutionObjCmd)
- (TclTraceCommandObjCmd): fix possible mem leak in trace info.
-
-2004-02-12 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinInit.c (AppendEnvironment): Use the tail component of the
- passed in lib path instead of just blindly using lib+4. That worked
- when lib was "lib/..." but fails for other values. Thanks go to
- Patrick Samson for pointing this out.
-
-2004-02-10 David Gravereaux <davygrvy@pobox.com>
-
- * win/nmakehlp.c: better macro grepping logic.
-
-2004-02-07 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc:
- * win/rules.vc:
- * win/tcl.rc:
- * win/tclsh.rc: Added an 'unchecked' option to the OPTS macro so a
- core built with symbols can be linked to the non-debug enabled C
- run-time. As per discussion with Kevin Kenny. Called like this:
-
- nmake -af makefile.vc OPTS=unchecked,symbols
-
- This clarifies the meaning of the 'g' naming suffix to mean only that
- the binary requires the debug enabled C run-time. Whether the binary
- contains symbols or not is a different condition.
-
-2004-02-06 Don Porter <dgp@users.sourceforge.net>
-
- * doc/clock.n: Removed reference to non-existent [file ctime].
-
-2004-02-05 David Gravereaux <davygrvy@pobox.com>
-
- * docs/tclvars.n: Added clarification of the tcl_platform(debug) var
- that it only refers to the flavor of the C run-time, and not whether
- the core contains symbols.
-
-2004-02-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c (SkipToChar): Corrected CONST and type-casting
- issues that caused compiler warnings.
-
-2004-02-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c (StoreStatData): Removed improper refcount
- decrement of the varName parameter. This error was causing segfaults
- following test cmdAH-28.7.
-
- * library/tcltest/tcltest.tcl: Corrected references to non-existent
- $name variable in [cleanupTests]. [Bug 833637]
-
-2004-02-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Corrected parsing of single command
- line argument (option with missing value) [Bug 833910]
- * library/tcltest/pkgIndex.tcl: Bump to version 2.2.5.
-
-2004-02-02 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclIO.c (Tcl_Ungets): Fixes improper filling of the channel
- buffer. This is the buffer before the splice. [Bug 405995]
-
-2004-02-01 David Gravereaux <davygrvy@pobox.com>
-
- * tests/winPipe.test: more pass-thru commandline verifications.
- * win/tclWinPipe.c (BuildCommandLine): Special case quoting for '{'
- not required by the c-runtimes's parse_cmdline().
- * win/tclAppInit.c: Removed our custom setargv() in favor of the work
- provided by the c-runtime. [Bug 672938]
-
- * win/nmakehlp.c: defensive techniques to avoid static buffer
- overflows and a couple envars upsetting invocations of cl.exe and
- link.exe. [Bug 885537]
-
- * tests/winPipe.test: Added proof that BuildCommandLine() is not doing
- the "N backslashes followed a quote -> insert N * 2 + 1 backslashes
- then a quote" rule needed for the crt's parse_cmdline().
- * win/tclWinPipe.c: Fixed BuildCommandLine() to pass the new cases.
-
-2004-01-30 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Use the -GZ compiler switch when building for
- symbols. This is supposed to emulate the release build better to avoid
- hiding problems that only show themselves in a release build.
-
-2004-01-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix to [Bug 883143] in file normalization
-
-2004-01-29 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n:
- * generic/tclFCmd.c
- * generic/tclTest.c
- * library/init.tcl
- * mac/tclMacFile.c
- * tests/fileSystem.test: fix to [Bug 886352] where 'file copy -force'
- had inconsistent behaviour wrt target files with insufficient
- permissions, particular from vfs->native fs. Behaviour of '-force' is
- now always consistent (and now consistent with behaviour of 'file
- delete -force'). Added new tests and documentation and cleaned up the
- 'simplefs' test filesystem.
-
- * generic/tclIOUtil.c
- * unix/tclUnixFCmd.c
- * unix/tclUnixFile.c
- * win/tclWinFile.c: made native filesystems more robust to C code
- which asks for mount lists.
-
- * generic/tclPathObj.c: fix to [Bug 886607] removing warning/error
- with some compilers.
-
-2004-01-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclObj.c (SetBooleanFromAny): Rewrite to do more efficient
- string->bool conversion.
- Many other minor whitespace/style fixes to this file too.
-
-2004-01-27 David Gravereaux <davygrvy@pobox.com>
-
- * win/nmakehlp.c: Use '.\nul' as the sourcefile name instead of 'nul'
- so VC 5.2 doesn't try searching the path for it and failing with a
- possible dialogbox popping up about having to add a CD to an empty
- drive. Also added a SetErrorMode() call to disable any dialogs that
- cl.exe or link.exe might create. [Bug 885537]
-
-2004-01-22 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/file.n: clarified documentation of 'file system' [Bug 883825]
- * tests/fCmd.test: improved test result in failure case.
-
-2004-01-22 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * tests/fileSystem.test: 3 new tests
- * generic/tclPathObj.c: fix to [Bug 879555] in file normalization.
- * doc/filename.n: small clarification to Windows behaviour with
- filenames like '.....', 'a.....', '.....a'.
-
- * generic/tclIOUtil.c: slight improvement to native cwd caching on
- Windows.
-
-2004-01-21 David Gravereaux <davygrvy@pobox.com>
-
- * doc/Panic.3: Mentions of 'panic' and 'panicVA' removed from the
- documentation.
-
-2004-01-21 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * doc/FileSystem.3:
- * generic/tcl.decls:
- * generic/tclCmdAH.c
- * generic/tclDecls.h
- * generic/tclFCmd.c
- * generic/tclFileName.c
- * generic/tclFileSystem.h
- * generic/tclIOUtil.c
- * generic/tclInt.decls
- * generic/tclInt.h
- * generic/tclIntDecls.h
- * generic/tclPathObj.c
- * generic/tclStubInit.c
- * generic/tclTest.c
- * mac/tclMacFile.c
- * tests/fileName.test
- * tests/fileSystem.test
- * tests/winFCmd.test
- * unix/tclUnixFile.c
- * win/tclWin32Dll.c
- * win/tclWinFCmd.c
- * win/tclWinFile.c
- * win/tclWinInt.h
-
- Three main issues accomplished: (1) cleaned up variable names in the
- filesystem code so that 'pathPtr' is used throughout. (2) applied a
- round of filesystem optimisation with better handling and caching of
- relative and absolute paths, requiring fewer conversions. (3)
- clarifications to the documentation, particularly regarding the
- acceptable refCounts of objects. Some new tests added. Tcl benchmarks
- show a significant improvement over 8.4.5, and on Windows typically a
- small improvement over 8.3.5 (Unix still appears to require
- optimisation). TCL_FILESYSTEM_VERSION_2 introduced, but for internal
- use only. There should be no public incompatibilities from these
- changes. Thanks to dgp for extensive testing.
-
-2004-01-19 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem with
- the process list. The delayed cut operation after the wait was going
- stale by being outside the list lock. It now cuts within the lock and
- does a locked splice for when it needs to instead. [Bug 859820]
-
-2004-01-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompile.c, generic/tclCompile.h: Two new opcodes,
- INST_LIST_INDEX_IMM and INST_LIST_RANGE_IMM, that have operand(s) of
- new type OPERAND_IDX4 which represents indexes into things like lists
- (and perhaps other things eventually.)
- * generic/tclExecute.c (TclExecuteByteCode): Implementation of the new
- opcodes. INST_LIST_INDEX_IMM does a simple [lindex] with either front-
- or end-based simple indexing. INST_LIST_RANGE_IMM does an [lrange]
- with front- or end-based simple indexing for both the reference to the
- first and last items in the range.
- * generic/tclCompCmds.c (TclCompileLassignCmd): Generate bytecode for
- the [lassign] command.
-
-2004-01-17 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinInit.c: added #pragma comment(lib, "advapi32.lib") when
- compiling under VC++ so we don't need to specify it when linking.
-
-2004-01-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LassignObjCmd): Add more shimmering
- protection for when the list is also one of the variables.
-
- BASIC IMPLEMENTATION OF TIP#57
- * generic/tclCmdIL.c (Tcl_LassignObjCmd): Implementation of the
- [lassign] command that takes full advantage of Tcl's object API.
- * doc/lassign.n: New file documenting the command.
- * tests/cmdIL.test (cmdIL-6.*): Test suite for the command.
-
-2004-01-15 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinReg.c: Placed the requirement for advapi.lib into the
- object file itself with #pragma comment (lib, ...) when built with
- VC++. This will simplify linking for users of the static library.
-
- * win/rules.vc: Added new 'fullwarn' to the CHECKS commandline macro;
- sets $(FULLWARNINGS).
-
- * win/makefile.vc: Removed 'advapi.lib' from $(baselibs). Added new
- logic to crank-up the warning levels for both compile and link when
- $(FULLWARNINGS) is set. Some clean-up with how the resource files are
- built and how -DTCL_USE_STATIC_PACKAGES is sent when compiling the
- shells.
-
- * win/tclAppInit.c: Small change in how TCL_USE_STATIC_PACKAGES is
- used.
-
- * win/tcl.rc:
- * win/tclsh.rc: Some clean-up with how the resource files are built.
- Fixed 'OriginalFilename' problem that still thought a debug suffix was
- still 'd', now is 'g'.
-
-2004-01-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclDictObj.c (TraceDictPath, DictExistsCmd): Adjusted
- behaviour of [dict exists] so a failure to look up a dictionary along
- the path of dicts doesn't trigger an error. This is how it was
- documented to behave previously... [Bug 871387]
-
- * generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth relating
- to [Bug 876170].
- (SetDictFromAny): Make sure that lists retain their ordering even when
- converted to dictionaries and back.
- (TraceDictPath): Correct object reference count handling!
- (DictReplaceCmd, DictRemoveCmd): Stop object leak.
- (DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd):
- Simpler handling of reference counts when assigning to variables.
- * tests/dict.test (dict-19.2): Memory leak stress test
-
-2004-01-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Silence compiler warnings.
-
- Patch 876451: restores performance of [return]. Also allows forms such
- as [return -code error $msg] to be bytecompiled.
-
- * generic/tclInt.h: Factored Tcl_ReturnObjCmd() into two pieces:
- * generic/tclCmdMZ.c: TclMergeReturnOptions(), which can parse the
- options to [return], check their validity, and create the
- corresponding return options dictionary, and TclProcessReturn(), which
- takes that return options dictionary and performs the [return]
- operation.
-
- * generic/tclCompCmds.c: Rewrote TclCompileReturnCmd() to call
- TclMergeReturnOptions() at compile time so the return options
- dictionary is computed at compile time (when it is fully known). The
- dictionary is pushed on the stack along with the result, and the code
- and level values are included in the bytecode as operands. Also
- supports optimized compilation of un[catch]ed [return]s from procs
- with default options into the INST_DONE instruction.
-
- * generic/tclExecute.c: Rewrote INST_RETURN instruction to retrieve
- the code and level operands, pop the return options from the stack,
- and call TclProcessReturn() to perform the [return] operation.
-
- * generic/tclCompile.h: New utilities include TclEmitInt4 macro
- * generic/tclCompile.c: and TclWordKnownAtCompileTime().
-
- End Patch 876451.
-
- * generic/tclFileName.c (Tcl_GlobObjCmd): Latest changes to management
- of the interp result by Tcl_GetIndexFromObj() exposed improper interp
- result management in the [glob] command procedure. Corrected by
- adopting the Tcl_SetObjResult(Tcl_NewStringObj) pattern. This stopped
- a segfault in test filename-11.36. [Bug 877677]
-
-2004-01-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct, Tcl_WrongNumArgs):
- Create fresh objects instead of using the one currently in the
- interpreter, which isn't guaranteed to be fresh and unshared. The cost
- for the core will be minimal because of the object cache, and this
- fixes [Bug 875395].
-
-2004-01-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompExpr.c (CompileLandOrLorExpr): cosmetic changes.
-
-2004-01-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompExpr.c (CompileLandOrLorExpr): new logic, fewer
- instructions. As a side effect, the instructions INST_LOR and
- INST_LAND are now never used.
- * generic/tclExecute.c (INST_JUMP*): small optimisation; fix a bug in
- debug code.
-
-2004-01-11 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclWinThrd.c (Tcl_ConditionNotify): condPtr must be dereferenced
- to see if there are waiters else uninitialized datum is manipulated.
- [Bug 849007 789338 745068]
-
-2004-01-09 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tcl.h: Renamed and deprecated #defines moved to within the
- #ifndef TCL_NO_DEPRECATED block. This allows us to build Tcl to check
- for deprecated functions in use, such as panic() and Tcl_Ckalloc(). By
- request from DKF. Extensions that build with -DTCL_NO_DEPRECATED now
- have these macros as restricted.
- ***POTENTIAL INCOMPATIBILITY***
-
- * win/makefile.vc:
- * win/rules.vc: Added -DTCL_NO_DEPRECATED usage to makefile.vc.
- Called like this: nmake -af makefile.vc CHECKS=nodep
-
-2004-01-09 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclIOUtil.c: fix to infinite loop in TclFinalizeFilesystem
- [Bug 873311]
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2005 b/ChangeLog.2005
deleted file mode 100644
index f2d1b65..0000000
--- a/ChangeLog.2005
+++ /dev/null
@@ -1,3822 +0,0 @@
-2005-12-30 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStubLib.c: Corrected a typo in "missing Stubs table
- pointer."
-
-2005-12-27 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tcl.decls: Destubbed TclTomMathInitializeStubs - it is in
- * generic/tcl.h: the stub library, not the main shared
- * generic/tclBasic.c: library. Exported Tcl_InitBignumFromDouble.
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclStrToD.c:
-
- * generic/tclDecls.h:
- * generic/tclStubLib.c:
- * generic/tclStubInit.c: Regenerated.
-
- * generic/clock.tcl: Reverted to using the time zone abbreviation and
- not its name to "stop the bleeding" on [Bug 1386377]. This is *not* a
- good long-term solution, but there may not be one.
-
- * libtommath/bn_mp_sqrt.c: Improved the initial approximation to the
- square root, roughly doubling the speed of the routine. (This is a
- local change that needs to be communicated to Tom.)
-
- * win/Makefile.in: Corrected a bug where tommath_class.h and
- tommath_superclass.h were not installed, making it impossible for
- client code to compile against the tommath stubs.
-
- * library/tzdata: Updated to Olson's tzdata2005r. (Latest changes to
- Daylight Saving Time in Canada, plus redefinition of the Posix-style
- zones [e.g., EST5EDT] to be locale-independent.)
-
- * libtommath: Updated to Tom St.Denis's release 0.37.
-
-2005-12-20 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclThreadAlloc.c (Tcl_GetMemoryInfo): Format values as longs
- and not ints, so they are less likely to wrap on 64-bit machines.
-
-2005-12-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: Modified [string is double] to use
- * tests/string.test: TclParseNumber() to parse trailing whitespace.
- Ensures consistency, and makes it easier to cleanup after invalid
- internal reps left behind by parsing [Bugs 1360532 1382287].
-
- * generic/tclParseExpr.c: Added TCL_PARSE_NO_WHITESPACE to
- * generic/tclScan.c: TclParseNumber() calls since [scan] and [expr]
- * tests/scan.test: parsing don't want spaces in parsed numbers.
-
- * generic/tclInt.h: Added TCL_PARSE_NO_WHITESPACE flag to the
- * generic/tclStrToD.c: TclParseNumber() interface.
-
-2005-12-19 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/Tcl.n: Clarify what is going on in variable substitution
- following thread on comp.lang.tcl.
-
-2005-12-18 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileDictCmd): Ensure that we only do an
- 'endCatch' when there's a preceding 'beginCatch'. [Bug 1382528] Many
- thanks to Anton Kovalenko for finding this and pointing out that it was
- a catch stack handling problem!
-
-2005-12-14 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclIOUtil.c: workaround gcc warning "comparison is always
- * generic/tclTest.c: false due to limited range of data type".
-
- * macosx/Tcl.xcode/project.pbxproj:
- * macosx/Tcl.xcodeproj/project.pbxproj:
- * unix/Makefile.in: add new tclTomMath* files.
-
- * generic/tclBasic.c: replace panic with Tcl_Panic.
-
-2005-12-13 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tcl.decls: Added changes to export an additional stubs
- * generic/tclBasic.c: table to represent the 'libtommath' routines
- * generic/tclDecls.h: that Tcl uses and export them to callers.
- * generic/tclInt.decls: Reran 'genstubs'
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c:
- * generic/tclTomMath.decls:
- * generic/tclTomMath.h:
- * generic/tclTomMathDecls.h:
- * generic/tclTomMathInterface.c:
- * generic/tommath.h:
- * tools/fix_tommath_h.tcl:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc:
-
- * generic/tclClock.c: Made changes to silence a number of compiler
- * generic/tclIO.c: warnings when building with mingw.
- * generic/tclIORChan.c:
- * generic/tclLink.c:
- * generic/tclListObj.c:
- * generic/tclObj.c:
- * generic/tclParseExpr.c:
- * generic/tclProc.c:
- * generic/tclTimer.c:
- * win/tclWinChan.c:
- * win/tclWinConsole.c:
- * win/tclWinDde.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
- * win/tclWinReg.c:
- * win/tclWinSock.c:
-
-2005-12-13 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclExecute.c (TEBC:DICT_FIRST,DICT_DONE): Only decrease the
- references to the dictionary once the iteration completes. Do this by
- storing the dict in the iterator context variable. [Bug 1379349] Thanks
- to Ulrich Ring and Tobias Hippler for finding this.
-
-2005-12-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tcl.m4, unix/configure: Fix sh quoting error reported in
- bash-3.1+ [Bug 1377619] (schafer)
-
-2005-12-12 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/mathfunc.n: Changed two examples from the incorrect 'tcl::math::'
- to 'tcl::mathfunc::' [Bug 1378818]
-
-2005-12-09 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Define MACHINE for gcc builds. The
- lack of a definition of this variable in the manifest file was causing
- a runtime error in wish built with gcc.
-
-2005-12-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/lsearch.test (lsearch-10.8..10): If the -start is off the end,
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): searching should find nothing
- at all. [Bug 1374778]
-
-2005-12-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/Makefile.in, win/makefile.vc: Add Win x64 and CE build support
- * win/tcl.m4, win/configure: CE still requires C code fixes.
-
- * generic/tcl.h: use struct __stat64 (not _stat64) for MSC_VER >= 1400
- (i.e. latest Platform SDK).
-
-2005-12-07 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/socket.n: Cross-referenced the socket documentation better to the
- fconfigure documentation on the topic of asynch sockets.
- * doc/fconfigure.n: Added keyword to documentation of -blocking option
- so that people looking for "asynch" can find it as well.
-
-2005-12-05 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixPort.h (Darwin): fix incorrect __DARWIN_UNIX03 configure
- overrides that were originally copied from Darwin CVS (rdar://3693001)
-
-2005-12-05 Kevin B. Kenny <kennykb@acm.org>
-
- * tools/tclZIC.tcl: Updated to reflect changes in calling sequence when
- GetJulianDateFromEraYearMonthDay moved to C.
- * library/tzdata: Regenerated from Olson's tzdata2005p.tar.gz - the
- 'systemv' changes appear not to affect Tcl's processing of the dates.
-
-2005-12-05 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/configure.in: move check for fts API to configure.in and run it
- * unix/tcl.m4: on all platforms, since Linux glibc2 and *BSDs
- also have this; using fts is more efficient than a recursive
- opendir/readdir.
- * unix/tclUnixFCmd.c (TraverseUnixTree): add support to fts code for
- platforms with stat64.
- * unix/configure:
- * unix/tclConfig.h.in: regen.
-
-2005-12-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure: Use fts file API on Darwin if available.
- * unix/tcl.m4: Addresses file delete issues in readdir noted
- * unix/tclUnixFCmd.c: in [Bug 1034337]. (steffen)
- Remove redundant stat call for each file in DoCopyFile. (steffen)
-
-2005-12-02 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c: Moved a tiny bit more of [clock format] from run
- * library/clock.tcl: time to compile time, and fixed a l10n bug in the
- process. [Bug 1371446]. Also, conditoned the call to SetupTimeZone to
- speed the common case where TZData($timezone) already exists, and
- achieved a puny speedup by making ::tcl::clock::getenv not throw
- errors.
- * unix/Makefile.in: Made some changes to support a 'make' command that
- is present on some antiquated versions of Solaris.
-
-2005-12-01 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Continued rationalizing the code, eliminating
- numerous redundant [mc] calls. Added another time boost by precompiling
- a [::format] command to do the bulk of the work of [clock format].
-
-2005-12-01 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/Makefile.in: Add remaining dependency info. While automated
- maintenance of this information would be good, having it at all is much
- better than a poke in the eye with a sharp stick...
-
-2005-12-01 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclClock.c: fix warning.
-
- * unix/tcl.m4 (Darwin): fix error when MACOSX_DEPLOYMENT_TARGET unset
- * unix/configure: regen.
-
-2005-11-30 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/Makefile.in: Add dependency information relating to tclCompile.h
- since when the list of opcodes changes it is usually useful to rebuild
- everything that depends on it (but which is nonetheless a small
- fraction of the total set of Tcl source files).
-
- ***POTENTIAL INCOMPATIBILITY*** for bytecode savers/loaders. See below
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Arrange for very simple
- [switch] invocations to be compiled into hash lookups into jump tables;
- only a very specific kind of [switch] can be safely compiled this way,
- but that happens to be the most common kind. This makes around 5-10%
- difference to the speed of execution of clock.test.
- * generic/tclExecute.c (TEBC:INST_JUMP_TABLE): New instruction to allow
- for jumps to locations looked up in a hashtable. Requires a new AuxData
- type, tclJumptableInfoType (supported by the functions DupJumptableInfo
- and FreeJumptableInfo in tclCompCmds.c) so anything that saves bytecode
- containing this *must* be updated!
-
-2005-11-30 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclClock.c: Fixed a bad refcount in previous commit that led
- to a corrupted heap. Also silenced a warning that some compilers gave
- about the excessively long constant for JULIAN_SEC_POSIX_EPOCH. Also
- fixed a bug where [clock format] would fail in the :localtime zone for
- times before the Posix Epoch. Thanks to Miguel Sofer for pointing out
- all of these. Also rationalized the code a little bit by moving parts
- of [clock scan] into C, eliminating some code that was duplicated in
- the C and Tcl layers.
-
-2005-11-29 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclBasic.c: Moved a big part of [clock format] down
- * generic/tclClock.c: to the C level in order to make it go faster.
- * generic/tclInt.h: Preliminary measurements suggest that it
- * generic/clock.tcl: more than doubles in speed with this change.
-
-2005-11-29 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Allow [lsearch -regexp] to
- process REs that contain backreferences. This expensive mode of
- operation is only used if the RE would otherwise cause a compilation
- failure. [Bug 1366683]
-
-2005-11-28 Kevin Kenny <kennykb@acm.org>
-
- * tools/tclZIC.tcl (convertTimeOfDay): Corrected a typo that caused
- wrong DST transitions in any time zone where the transition is
- specified as local Standard Time (as opposed to wall-clock or UTC).
- (Also updated the code to be bignum-safe.)
- * tests/clock.test (clock-51.1): Added regression test for the above.
- * library/tzdata: Updated to Olson's 'tzdata2005o' (changes for Cuba,
- Nicaragua, Jordan, and Georgia) and regenerated. Thanks to Paul
- Mackerras for reporting this problem.
-
-2005-11-27 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4 (Darwin): add 64bit support, check for Tiger copyfile(),
- add CFLAGS to SHLIB_LD to support passing -isysroot in env(CFLAGS) to
- configure (flag can't be present twice, so can't be in both CFLAGS and
- LDFLAGS during configure), don't use -prebind when deploying on 10.4,
- define TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING (rdar://3171542).
- (SC_ENABLE_LANGINFO, SC_TIME_HANDLER): add/fix caching, fix obsolete
- autoconf macros. Sync with tk/unix/tcl.m4.
-
- * unix/configure.in: fix obsolete autoconf macros, sync gratuitous
- formatting/ordering differences with tk/unix/configure.in.
-
- * unix/Makefile.in: add CFLAGS to tclsh/tcltest link to make executable
- linking the same as during configure (needed to avoid losing any linker
- relevant flags in CFLAGS, in particular flags that cannot be in
- LDFLAGS). Avoid concurrent linking of tclsh and compiling of
- tclTestInit.o or xtTestInit.o during parallel make.
- (checkstubs, checkdoc, checkexports): dependency and Darwin fixes
- (dist): add new macosx files.
-
- * unix/tclLoadDyld.c (TclpDlopen): use NSADDIMAGE_OPTION_WITH_SEARCHING
- on second NSAddImage only. [Bug 1204237]
- (TclGuessPackageName): should not be MODULE_SCOPE.
- (TclpLoadMemory): ppc64 and endian (i386) fixes, add support for
- loading universal (fat) bundles from memory.
-
- * unix/tclUnixFCmd.c:
- * macosx/tclMacOSXFCmd.c: ppc64 and endian (i386) fixes.
- (TclMacOSXCopyFileAttributes): add support for new Tiger copyfile() API
- to enable copying of xattrs & ACLs by [file copy].
-
- * generic/tcl.h: add Darwin specifc configure overrides for TCL_WIDE
- defines to support fat compiles of ppc and ppc64 at the same time,
- (replaces Darwin CVS fix by emoy, rdar://3693001). add/correct location
- of version numbers in macosx files.
-
- * generic/tclInt.h: clarify fat compile comment.
-
- * unix/tclUnixPort.h: add Darwin specifc configure overrides to support
- fat compiles, where configure runs only once for multiple architectures
- (replaces Darwin CVS fix by emoy, rdar://3693001).
-
- * macosx/tclMacOSXBundle.c:
- * macosx/tclMacOSXNotify.c:
- * unix/tclUnixNotfy.c:
- * unix/tclUnixPort.h: fix #include order to support compile time
- override of HAVE_COREFOUNDATION in tclUnixPort.h when building for
- ppc64
-
- * macosx/Tcl.pbproj/default.pbxuser (new file):
- * macosx/Tcl.pbproj/jingham.pbxuser:
- * macosx/Tcl.pbproj/project.pbxproj:
- * macosx/Tcl.xcode/default.pbxuser (new file):
- * macosx/Tcl.xcode/project.pbxproj (new file):
- * macosx/Tcl.xcodeproj/default.pbxuser (new file):
- * macosx/Tcl.xcodeproj/project.pbxproj (new file): new/updated
- projects for Xcode 2.2 on 10.4, Xcode 1.5 on 10.3 & ProjectBuilder on
- 10.2, with native tcltest targets and support for universal (fat)
- compiles.
-
- * macosx/README: clarification/cleanup, document new Xcode projects and
- universal (fat) builds via CFLAGS (i.e. all of ppc ppc64 i386 at once).
-
- * unix/Makefile.in:
- * unix/aclocal.m4:
- * unix/configure.in:
- * unix/dltest/Makefile.in:
- * macosx/configure.ac (new file): add support for inclusion of
- unix/configure.in by macosx/configure.ac, allows generation of a config
- headers enabled configure script in macosx (required by Xcode
- projects).
-
- * macosx/GNUmakefile: rename from Makefile to avoid overwriting by
- configure run in tcl/macosx, add support for reusing configure cache,
- build target fixes, remove GENERIC_FLAGS override now handled by
- tcl.m4.
-
- * generic/tcl.decls: add Tcl_Main declaration as comment to avoid
- 'checkstubs' target complaining about it missing from stubs.
-
- * generic/regex.h:
- * generic/tclDate.c:
- * generic/tclEnv.c:
- * generic/tclGetDate.y:
- * generic/tclIOUtil.c:
- * generic/tclObj.c:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c:
- * generic/tclPathObj.c:
- * generic/tclThreadAlloc.c:
- * generic/tclThreadStorage.c:
- * generic/tclTrace.c:
- * generic/tclVar.c:
- * generic/tommath.h:
- * tools/fix_tommath_h.tcl:
- * unix/tclUnixFCmd.c: ensure externally visible symbols not contained
- in stubs table are declared as MODULE_SCOPE (or as static if not used
- outside of own source file). These changes allow 'make checkstubs' to
- complete without error on Darwin with gcc 4.
-
- * generic/rege_dfa.c (getvacant):
- * generic/regexec.c (cfind):
- * generic/tclCompExpr.c (CompileSubExpr):
- * generic/tclNamesp.c (NamespaceEnsembleCmd):
- * unix/tclUnixChan.c (TclUnixWaitForFile): initialise variables to
- silence gcc 4 warnings.
-
- * generic/tclExecute.c (TclExecuteByteCode): fix unused variable
- warning when NO_WIDE_TYPE is defined.
-
- * generic/regguts.h: only #define NDEBUG if not already #defined.
-
- * unix/tclUnixNotfy.c:
- * macosx/tclMacOSXNotify.c: sync whitespace & comments.
-
- * unix/tclUnixPort.h:
- * win/tclWinPort.h: remove declaration of obsolete&unused TclpMutex
- API.
-
- * unix/configure:
- * unix/tclConfig.h.in: regen.
-
-2005-11-21 Andreas Kupries <andreask@activestate.com>
-
- * unix/Makefile.in (install-libraries): Updated Makefile to new
- * win/Makefile.in (install-libraries): version of the http package.
- This fixes the ifneeded/provide mismatch reported when trying to
- require http. Should we maybe try to automatically extract the version
- number from the http code to prevent future breakage ?
-
- This follows the update of the version number by dgp on Nov 15 (No
- entry found in the ChangeLog).
-
-2005-11-20 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclStubLib.c: Don't set tclStubsPtr to 0 when
- Tcl_PkgRequireEx() fails [Fix for [Bug 1091431] "Tcl_InitStubs failure
- crashes wish"]
-
-2005-11-18 Miguel Sofer <msofer@users.sf.net>
-
- * tests/trace.test (trace-34.5): [Bug 1047286], added a second test
- illustrating the role of "ns in callStack" in the ns's visibility
- during deletion traces.
-
-2005-11-18 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Restored several missing lines near the %w format group
- so that %w and %W are documented with their actual behaviour. [Bug
- 1359183]
-
-2005-11-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIO.c (TclFinalizeIOSubsystem): preserve statePtr until we
- retrieve the next statePtr from it.
-
-2005-11-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclObj.c (GetBignumFromObj): replace NULL with
- tclEmptyStringRep to stop memcpy from complaining in a debug build
- (the corresponding branch is eliminated by the optimiser otherwise).
-
-2005-11-18 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (TclFinalizeIOSubsystem): Applied Pat Thoyts' patch
- for [Bug 1359094]. This moves the retrieval of the next channel state
- to the end of the loop, as the called closeproc may close other
- channels, i.e. modify the list we are iterating, invalidating any
- pointer retrieved earlier.
-
-2005-11-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclListObj.c: Restored the SetListFromAny routine to the
- * generic/tclObj.c: "list" Tcl_ObjType, and restored the
- Tcl_RegisterObjType() call for "list". This addresses the needs of some
- "bridge" extensions to examine whether the Tcl_ObjType of a Tcl_Obj is
- that of the "list" Tcl_ObjType.
-
-2005-11-18 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * library/http/http.tcl (http::geturl): Improved syntactic validation
- of URLs, and better error messages in some cases. [Bug 1358369]
-
-2005-11-17 Miguel Sofer <msofer@users.sf.net>
-
- * tests/namespace.test: fix comment
-
-2005-11-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStrToD.c: More data in the "can't happen" Tcl_Panic to
- aid debugging.
-
- * generic/tclBasic.c (CallCommandTraces): Save/restore the interp
- result during traces to fix [Bug 1355342].
-
-2005-11-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * tests/namespace.test: fix for [Bug 1354540] and [Bug 1355942]. The
- new tests 7.3-6 and the modified 51.13 fail due to the unrelated [Bug
- 1355342]
-
- * tests/trace.test: added tests 20.13-16 for [Bug 1355342]
-
-2005-11-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken):
- * generic/tclObj.c (Tcl_GetCommandFromObj): more partial fixes for
- [Bug 1354540] - making sure that cached references to a command being
- deleted cannot be made reusable by a delete trace.
-
-2005-11-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_FindCommand): Do not find commands in dead
- namespaces on the path. Partial fix for [Bug 1354540].
-
-2005-11-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Revised TclParseNumber interface to enable
- * generic/tclScan.c: revision to the [scan] command implementation
- * generic/tclStrToD.c: to permit tests scan-4.44,55 to pass again.
- [Bug 1348067].
-
-2005-11-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken):
- * generic/tclObj.c (Tcl_GetCommandFromObj): bump the cmd epoch early
- to insure that cached references to this command are invalidated.
- Partial fix for [Bug 1352734] - at least insures that namespace-51.13
- does not cause a panic. The test is still marked as knownbug, pending
- resolution of what is actually the correct return value ([Bug
- 1354540])
-
-2005-11-09 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclTimer.c: Changed [after] so that it behaves correctly
- * tests/timer.test: with negative arguments [Bug 1350293] and
- arguments that overflow a 32-bit word. [Bug 1350291]
-
-2005-11-08 Don Porter <dgp@users.sourceforge.net>
-
- * tests/compile.test: Updated tests with changed behavior
- * tests/execute.test: due to addition of bignums.
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/parseExpr.test:
- * tests/platform.test:
- * tests/string.test:
-
-2005-11-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFCmd.c (MAX_READDIR_UNLINK_THRESHOLD): reduce to 130
- based on errors seen on OS X 10.3 with lots of links in a dir.
- [Bug 1034337 followup]
-
-2005-11-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/Makefile.in (gdb-test): Added a new target to make it easier to
- run the test suite inside a debugger.
-
-2005-11-08 Don Porter <dgp@users.sourceforge.net>
-
- * tests/compExpr-old.test: Updated tests with changed behavior due
- to addition of bignums.
-
- * tests/expr.test: Portable tests expr-46.13-18 [Bug 1341368]
-
- * generic/tclPkg.c: Corrected inconsistencies in the value returned
- * tests/pkg.test: by Tcl_PkgRequire(Ex) so that the returned
- values will always agree with what is stored in the package database.
- This way repeated calls to Tcl_PkgRequire(Ex) have the same results.
- Thanks to Hemang Lavana. [Bug 1162286].
-
-2005-11-08 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclTrace.c (TraceVarEx): Factor out heart of Tcl_TraceVar2
- (TclTraceVariableObjCmd,TraceVarProc): Use the new internal API to
- arrange for the clientData to be cleaned up at the same time as the
- rest of the main trace record. This simplifies the code a bit at the
- same time.
-
-2005-11-07 Miguel Sofer <msofer@users.sf.net>
-
- * tests/trace.test (trace-13.2-4): added tests to detect leak, see [Bug
- 1348775]. The recently added trace-8.9 test is now 13.4.
-
-2005-11-07 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/dict.test (dict-19.2): arrange for the stress testing code to
- only stress test the dict code and not the trace code as well. [Bug
- 1342858]
-
-2005-11-05 Miguel Sofer <msofer@users.sf.net>
-
- * tests/trace.test (trace-8.9): added test to detect leak, see [Bug
- 1348775].
-
-2005-11-04 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinPort.h: Applied [Patch 1267871] by Matt Newman for
- * win/tclWinPipe.c: extended error code support on Windows.
- * tests/exec.test: Tests for extended error codes.
- * generic/tclPipe.c: Permit long codes (platform macros permitting).
-
-2005-11-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBinary.c:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * generic/tclIOCmd.c:
- * generic/tclLink.c:
- * generic/tclTest.c:
- * generic/tclVar.c: fix for [Bug 1334947]. The functions TclPtrSetVar,
- Tcl_ObjSetVar2 and Tcl_SetVar2Ex now always consume the newValuePtr
- argument - i.e., they will free a 0-refCount object if they failed to
- set the variable. Fixed all callers in the core.
-
-2005-11-04 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclGetDate.y: Added abbreviations for the Korean
- * library/clock.tcl: timezone. [Patch 1298737]
- * generic/tclDate.c: Regenerated.
-
- * tools/findBadExternals.tcl: Added this script, which locates external
- symbols that do not begin with 'Tcl' or 'tcl' and hence might be in
- conflict with other link libraries. Thanks to George Peter Staplin for
- the idea and the initial version of the script. [Bug 1263012]
-
- * unix/Makefile.in: Trimmed a bunch of fat out of the tommath/
- directory in 'make dist'. [RFE 1333318]
-
- * unix/tcl.m4: Added code to enable [load] on LynxOS. Thanks to
- heidibr@users.sf.net for the patch. [Bug 1163896]. Removed the last
- vestiges of GNU dld from the Unix build [RFE 1071992].
-
- * unix/tclLoadDld.c: Removed.
- * unix/configure: Regenerated.
-
-2005-11-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * generic/tclVar.c:
- * tests/trace.test: fix for [Bugs 1338280/1337229]; changed to use the
- same approach as the 8.4 patch in the ticket (i.e., removed the patch
- committed on 2005-31-10).
-
-2005-11-03 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWin32Dll.c: Applied [Patch 1256872] to provide unicode
- * win/tclWinConsole.c: support in the console on suitable systems.
- * win/tclWinInt.h: Patch by Anton Kovalenko
-
-2005-11-02 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- Applied [Patch 1096916] to support building with MSVC 8.
- * generic/regerror.c: Avoid use of reserved word.
- * generic/tcl.h: Select the right Tcl_Stat structure
- * generic/tclDate.c: Casts to handle 64 bit time_t case.
- * tests/env.test: Include essential envvar on Win32
- * win/nmakehlp.c: Handle new return codes.
- * win/makefile.vc: Use the selected options.
- * win/rules.vc: Check options are applicable
- * win/tclWinPort.h: Disable deprecated function warnings
- * win/tclWinSock.c: Provide default value to avoid warning.
- * win/tclWinTime.c: Add casts to handle 64bit time_t type.
-
-2005-11-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c (TclCheckExecutionTraces): Corrected mistaken
- assumption that all command traces are set at the script level.
- Report/fix from Jacques H. de Villiers. [Bug 1337941]
-
- * tests/unixNotfy.test (1.1,2): Update error message whitespace to
- match changes in code.
-
- * tests/expr-old.test (expr-32.52): Use int(.) to restrict result of
- left shift to the C long range.
-
- * expr.test (expr-46.13): Added test that illustrates shortcoming of
- [Patch 1340260].
-
-2005-10-31 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c: fix for [Bugs 1338280/1337229]. Thanks Don.
- * tests/trace.test: fix duplicate test numbers
-
-2005-10-31 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * win/tclWinSerial.c (SerialSetOptionProc): Cleaned up option parsing
- to produce more informative error messages and separate error and
- non-error code paths better.
- * tests/ioCmd.test (iocmd-8-19): Updated.
-
-2005-10-29 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclTrace.c (TraceVarProc): [Bug 1337229], partial fix. Ensure
- that a second call with TCL_TRACE_DESTROYED does not lead to a second
- call to Tcl_EventuallyFree(). It is still true that that second call
- should not happen, so the bug is not completely fixed.
- * tests/trace.test (test-18.3-4): added tests for [Bug 1337229] and
- [Bug 1338280].
-
-2005-10-23 Vince Darley <vincentdarley@sourceforge.net>
-
- * generic/tclFileName.c: fix to memory leak in glob [Bug 1335006] Obj
- leak detection and patch by Eric Melbardis.
-
- * tests/fCmd.test:
- * win/tclWinFile.c: where appropriate windows API is available, try to
- set 'nlink' and 'ino' stat fields (previously they were always 0). [Bug
- 1325803]
-
-2005-10-22 Miguel Sofer <msofer@users.sf.net>
-
- * tests/foreach.test (foreach-8.1): added test for [Bug 1189274]
-
-2005-10-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_INCR_*): fixed [Bug 1334570]. Obj leak
- detection and patch by Eric Melbardis.
-
-2005-10-21 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (RefineApproximation): Plugged a memory leak
- where two intermediate results were not freed on one return path. [Bug
- 1334461]. Thanks to Eric Melbardis for the patch.
-
-2005-10-21 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/binary.n: Clarify that virtually all code that uses the 'h'
- format in [binary scan] should be using the 'H' format instead. It is
- nearly always a bug to use the other!
-
-2005-10-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclListObj.c (TclLsetFlat):
- * tests/lset.test (lset-10.3): fixed handling of unshared lists with
- shared sublists, [Bug 1333036] reported by neuronstorm.
-
-2005-10-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIORChan.c (PassReceivedError,PassReceivedErrorInterp):
- Fix crash caused by passing -1 as the length to TclNewStringObj(). Only
- Tcl_NewStringObj (the function call, not the macro) handles that sort
- of thing correctly. This makes ioCmd.test pass again.
-
-2005-10-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclClock.c: Removed some dead code.
- * generic/tclCmdIL.c:
- * generic/tclCompCmds.c:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * generic/tclLiteral.c:
- * generic/tclParseExpr.c:
- * generic/tclScan.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
-
-2005-10-19 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclIORChan.c: General cleanup, removing checks that are
- unnecessary due to the general contracts of other functions in the
- core, converting to using ANSI declarations, etc. Note that nearly the
- whole file has changed, but it is often just cosmetic.
-
-2005-10-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_DICT_APPEND, INST_DICT_LAPPEND): fixed
- faulty peephole optimisation that can cause crashes, [Bug 1331475]
- reported by Aric Bills.
-
-2005-10-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Added optimization for I32L64 systems to avoid
- using bignums to perform int multiplies. The improvement shows up most
- dramatically in tclbench's matrix.bench.
-
-2005-10-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Restored some optimizations of the
- INST_INCR_SCALAR1_IMM opcode.
-
-2005-10-14 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_ClearChannelHandlers): removed change dated
- 2005-10-04 (see below). Look into [Bug 1323992] for detailed
- discussion.
-
- * generic/tcl.h: Fixed bad definition of CRTEXPORT which should have
- been CRTIMPORT rather. This broke compilation of generic/tclMain.c and
- was probably introduced by mistake while applying the fix for [Bug
- 1256937] below.
-
-2005-10-14 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c (TclIncrObj, TclExecuteByteCode): Tidied up a
- couple of infelicitous do {...} while(0) constructs.
-
-2005-10-14 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tcl.h: Fix for [Bug 1256937] - correctly decorate
- * generic/tclMain.c: imported functions from msvcrt in static builds.
-
-2005-10-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/format.test: "Forward"-port of test updates relating to [Bug
- 1284178]. The bug itself was fixed by TIP#237.
-
-2005-10-13 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_ClearChannelHandlers): temporary ifdef
- TCL_THREADS changes done to de-activate pending event processing when
- channel is being closed/cutted.
-
-2005-10-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Removed obsolete use of NO_ERRNO_H.
- * tools/man2tcl.c:
- * unix/tcl.m4:
- * unix/tclConfig.h.in:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * compat/tclErrno.h: Removed obsolete file.
-
- * generic/tclStrToD.c (TclParseNumber): Missing goto caused crash when
- parsing "Na". [Bug 1325833]
-
-2005-10-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (GetNumberFromObj): Restored some lost
- optimizations for empty string values. We avoid cost of a call to
- TclParseNumber just to tell us an empty string isn't a number.
-
-2005-10-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclPathObj.c (SetFsPathFromAny): TclGetString macro must not
- be combined with post-increment arguments. [Bug 1325099]
-
-2005-10-12 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c (Tcl_ExecuteByteCode, TclIncrObj): Several
- common cases inlined in hopes of gaining a little performance in [incr]
-
-2005-10-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c: New convenience macro CompileTokens().
-
-2005-10-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrections to the NO_WIDE_TYPE build. Also
- added missing "break" to a switch that broke wide XOR operations.
-
-2005-10-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInterp.c (DeleteScriptLimitCallback)
- (SetScriptLimitCallback): Improve the interlocking between the script
- limit callback record and the hash table of current such records, to
- prevent crashes in callbacks that create callbacks.
- (Tcl_LimitSetTime): Reset the correct flag. Problem reported by
- Nicolas Castagne <castagne@imag.fr> on comp.lang.tcl
-
-2005-10-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Fixing errors in last commit. (Two commits, the
- second removes wrong comment).
-
-2005-10-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclStrToD.c:
- * generic/tclStringObj.c: Initialise variables to avoid compiler
- warnings ([Bug 1320818] among others).
-
-2005-10-08 Don Porter <dgp@users.sourceforge.net>
-
- TIP#237 IMPLEMENTATION
-
- [kennykb-numerics-branch] Resynchronized with the HEAD; at this
- checkpoint [-rkennykb-numerics-branch-20051008], the HEAD and
- kennykb-numerics-branch contain identical code.
-
- [kennykb-numerics-branch] Merge updates from HEAD
-
- * generic/tclExecute.c: More performance macros and special handling of
- the wide integer type for performance on 32-bit systems.
-
-2005-10-07 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Macro GetNumberFromObj() is version of
- TclGetNumberFromObj() that saves a function call for common uses.
-
- * generic/tclInt.h: Made #undef NO_WIDE_TYPE the default on 32-bit
- systems. Being able to use 64-bit values without leaping to mp_int
- should help with performance.
-
- * generic/tclObj.c: Bug fixes in the #undef NO_WIDE_TYPE
- * generic/tclExecute.c: configuration.
-
- * generic/tclExecute.c: Improved performance of comparison opcodes and
- bitwise operations and removed yet more dead code.
-
-2005-10-07 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFCmd.c (TraverseUnixTree): Adjust 2004-11-11 change to
- * tests/fCmd.test (fCmd-20.2): account for NFS special files
- with a readdir rewind threshold. [Bug 1034337]
-
-2005-10-06 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Improved performance of INST_RSHIFT and
- INST_LSHIFT.
-
-2005-10-05 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Improved performance of INST_MULT, INST_DIV,
- INST_ADD, and INST_SUB and replaced a "goto... label" with a "break
- from loop" in TclIncrObj() and removed some dead code.
-
-2005-10-05 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclPipe.c (TclCreatePipeline): Fixed [Bug 1109294]. Applied
- the patch provided by David Gravereaux.
-
- * doc/CrtChannel.3: Fixed [Bug 1104682], by application of David
- Welton's patch for it, and added a note about wideSeekProc.
-
- * generic/tclIORChan.c (RcClose): Removed unreachable panic/return
- statements. This fixes the remainder of [Bug 1286256].
-
-2005-10-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/env.test (env-6.1):
- * win/tclWinPort.h: define USE_PUTENV_FOR_UNSET 1
- * generic/tclEnv.c (TclSetEnv, TclUnsetEnv): add USE_PUTENV_FOR_UNSET
- to existing USE_PUTENV define to account for various systems that have
- putenv(), but can't unset env vars with it. Note difference between
- Windows and Linux for actually unsetting the env var (use of '=').
- Correct the resizing of the environ array. We assume that we are in
- full ownership, but that's not correct.[Bug 979640]
-
-2005-10-04 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
- * generic/tclExecute.c: Updated TclIncrObj() to more efficiently add
- native long integers. Also updated IllegalExprOperandType and the
- INST_UMINUS, INST_UPLUS, INST_BITNOT, and INST_TRY_CVT_TO_NUMERIC
- sections for performance.
-
- * generic/tclBasic.c: Updated more callers to make use of
- TclGetNumberFromObj. Removed some dead code.
-
-2005-10-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708]
-
- * tests/http.test: do not URI encode -._~ according
- * library/http/http.tcl (init): to RFC3986. [Bug 1182373] (aho)
-
- * unix/tclLoadShl.c (TclpDlopen): use DYNAMIC_PATH on second shl_load
- only. [Bug 1204237]
-
- * doc/scan.n: scan %[] requires "one or more chars" [Bug 1277503]
-
- * tests/winFile.test (getuser): allow valid Windows usernames. [Bug
- 1311285]
-
- * generic/tclParse.c (Tcl_ParseCommand): add code that recognizes {} in
- addition to {expand} for word expansion (make with
- -DALLOW_EMPTY_EXPAND).
-
-2005-10-04 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_ClearChannelHandlers): now deletes any
- outstanding timer for the channel. Also, prevents events still in the
- event queue from triggering on the current channel.
-
- * generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early if passed
- NULL argument.
-
-2005-10-03 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclBasic.c: Re-implemented ExprRoundFunc and
- ExprEntierFunc to use TclGetNumberFromObj.
-
- * generic/tclInt.h: Added new routine TclGetNumberFromObj to
- * generic/tclObj.c: provide efficient access to the actual
- internal rep of a numeric Tcl_Obj without conversions.
-
-2005-10-03 Kevin Kenny <kennykb@acm.org>
-
- * tools/loadICU.tcl: Changed the file names of message catalogs to
- lowercase.
- * tools/makeTestCases.tcl:
- * library/tzdata/*: Olson's tzdata2005n.tar.gz. Includes new DST
- rules for USA and a number of changes to other locales.
- * tests/clock.test: Regenerated for new US DST rules.
-
-2005-09-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c: Separate encoding conversion of command line
- arguments from list formatting. [Bug 1306162].
-
-2005-09-30 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclStringObj.c: Bug fix: Missing cast to large enough
- integral size before << operations led to broken [format %llx] results.
- Thanks to Robert Henry for reporting the bug.
-
-2005-09-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/mathfunc.n: implementation for TIP #255, expr min/max
- * library/init.tcl:
- * tests/info.test, tests/expr-old.test:
-
-2005-09-27 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tcl.h: Changed name of the new Tcl_Obj intrep field
- * generic/tclObj.c: from "bignumValue" to "ptrAndLongRep" as
- * generic/tclProc.c: described in TIP 237, and more suitable for
- other more general uses.
-
-2005-09-27 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/binary.test (binary-14.18): Added test for [Bug 1116542] though
- the bug itself was already fixed by unrelated changes.
-
-2005-09-26 Kevin Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merge updates from HEAD.
-
-2005-09-26 Kevin Kenny <kennykb@acm.org>
-
- * libtommath/: Updated to release 0.36.
- * generic/tommath.h: Regenerated.
- * generic/tclTomMathInterface.h: Added ten missing aliases for mp_*
- functions to avoid namespace pollution in Tcl's exported symbols. [Bug
- 1263012]
-
-2005-09-23 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * unix/Makefile.in: Added -DMP_PREC=4 switch to all compiles so
- * win/Makefile.in: that minimum memory requirements of mp_int's
- * win/makefile.vc: will not be quite so large. [Bug 1299153].
-
- * generic/tclStrToD.c: Fixed memory leak. [Bug 1299803].
- * generic/tclObj.c:
-
-2005-09-20 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Revise TclIncrObj() to call
- Tcl_GetBignumAndClearObj.
-
- * generic/tcl.decls: Add Tcl_GetBignumAndClearObj.
- * generic/tclObj.c:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2005-09-16 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclInt.h: Added TclBNInitBigNumFromWideInt() so
- * generic/tclTomMathInterface.c: that every caller isn't required to
- duplicate the sign logic to use the unsigned interface.
-
- * generic/tclBasic.c: Reduce the number of places where Tcl intrudes
- * generic/tclExecute.c: into the internal format details of the mp_int
- * generic/tclObj.c: struct.
- * generic/tclStrToD.c:
- * generic/tcLStringObj.c:
-
- * generic/tclTomMath.h: Added mp_cmp_d to routines from libtommath
- * unix/Makefile.in: used by Tcl.
- * win/Makefile.in:
- * win/makefile.vc:
-
- * libtommath/bn_mp_add_d.c: Bug fix. For mp_add_d(&a, d, &c), when &a
- has the value -d, then the value &c computed should be zero, but
- mp_add_d was producing an inconsistent zero value with a sign field of
- MP_NEG, something like a value of -0, which other routines in
- libtommath can't handle.
-
- * generic/tclExecute.c: Dropped all creation of "bigOne" values and
- just use tommath routines that accept the value "1" directly.
-
-2005-09-15 Miguel Sofer <msofer@users.sf.net>
-
- * doc/ParseCmd.3: copy/paste fix [Bug 1292427]
-
-2005-09-15 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merge updates from HEAD.
-
- * generic/tclStringObj.c (TclAppendFormattedObjs): Revision to
- eliminate one round of string copying.
-
- * generic/tclBasic.c: More callers of TclObjPrintf and
- * generic/tclCkalloc.c: TclFormatToErrorInfo.
- * generic/tclCmdMZ.c:
- * generic/tclExecute.c:
- * generic/tclIORChan.c:
- * generic/tclMain.c:
- * generic/tclProc.c:
- * generic/tclTimer.c:
- * generic/tclUtil.c:
- * unix/tclUnixFCmd.c
-
- * unix/configure: autoconf-2.59
-
-2005-09-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl to
- transparently open large files on RHEL 3. [Bug 1287638]
-
-2005-09-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Bug fixes: ObjPrintfVA needed to
- support "*" fields and needed to interpret precision limits on %s
- conversions as a maximum number of bytes, not Tcl_UniChars, to take
- from the (char *) argument.
-
- * generic/tclBasic.c: Updated several callers to use
- * generic/tclCkalloc.c: TclFormatToErrorInfo() and/or
- * generic/tclCmdAH.c: TclObjPrintf().
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * generic/tclIORChan.c:
- * generic/tclIOUtil.c:
- * generic/tclNamesp.c:
- * generic/tclProc.c:
-
- * library/init.tcl: Keep [unknown] in sync with errorInfo
- formatting rules.
-
-2005-09-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: First caller of TclFormatToErrorInfo.
-
- * generic/tclInt.h: Using stdarg.h conventions, add more
- * generic/tclStringObj.c: fixed arguments to TclFormatObj() and
- TclObjPrintf(). Added new routine TclFormatToErrorInfo().
-
- * generic/tcl.h: Explicitly standardized on the use of stdarg.h
- * generic/tclBasic.c: conventions for functions with variable number
- * generic/tclInt.h: of arguments. Support for varargs.h has been
- * generic/tclPanic.c: implicitly gone for some time now. All
- * generic/tclResult.c: TCL_VARARGS* macros purged from Tcl sources,
- * generic/tclStringObj.c: leaving only some deprecated #define's
- * tools/genStubs.tcl: in tcl.h for the sake of older extensions.
-
- * generic/tclDecls.h: make genstubs
-
- * doc/AddErrInfo.3: Replaced all documented requirement for use of
- * doc/Eval.3: TCL_VARARGS_START() with requirement for use of
- * doc/Panic.3: va_start().
- * doc/SetResult.3:
- * doc/StringObj.3:
-
-2005-09-12 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merge updates from HEAD.
-
- * generic/tclCmdAH.c: Added support for the "ll" width
- * generic/tclStringObj.c: specifier to [format].
-
- * generic/tclStringObj.c (TclAppendFormattedObjs): Bug fix: make
- sure %ld formats force the collection of a wide value, when the value
- could be a different long.
-
-2005-09-09 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (RcDecodeEventMask): Added missing type
- declaration for the parameter 'mask'. This fixes the [Bug 1286256]. The
- other warning can be removed only by removing the panic/return code.
-
-2005-09-09 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merge updates from HEAD.
-
-2005-09-09 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclStringObj.c: Added two missing casts to silence messages
- from MSVC6.
-
-2005-09-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: New internal routine TclObjPrintf()
- * generic/tclStringObj.c: is similar to TclFormatObj() but
- accepts arguments in non-Tcl_Obj format.
-
- * generic/tclInt.h: New internal routines TclFormatObj()
- * generic/tclStringObj.c: and TclAppendFormattedObjs() to offer
- sprintf()-like means to append to Tcl_Obj. Work in progress toward
- [RFE 572392].
-
- * generic/tclCmdAH.c: Compiler directive NEW_FORMAT when #define'd
- directs the [format] command to be implemented in terms of the new
- TclAppendFormattedObjs() routine.
-
-2005-09-08 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- TIP#254 IMPLEMENTATION
-
- * generic/tclLink.c (LinkTraceProc,ObjValue): Added many new of C var
- * generic/tcl.h: to link to, making it
- * doc/LinkVar.3: easier to seamlessly
- * generic/tclTest.c (TestlinkCmd): couple C code and Tcl
- * tests/link.test: scripts in an
- application. [Patch 1242844]
-
-2005-09-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtf.c (Tcl_UniCharToUtf): Corrected handling of negative
- * tests/utf.test (utf-1.5): Tcl_UniChar input value. Incorrect
- handling was producing byte sequences outside of Tcl's legal internal
- encoding. [Bug 1283976].
-
-2005-09-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInt.h (List): Added flag to keep track of whether a list
- * generic/tclListObj.c: with a string rep is provably canonical.
- * generic/tclUtil.c (Tcl_ConcatObj): Do efficient concatenation and
- * generic/tclBasic.c (Tcl_EvalObjEx): evaluation when the list is
- canonical, and not just when the list is pure. This should make the
- "pure list" hacking introduced in 8.3 much more robust.
-
-2005-09-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop
- symbol from leaking outside the Tcl library. [Bug 1263012]
-
-2005-09-02 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclScan.c: Bug fix: The %o, %x, %i formats of [scan] must
- not accept any 0b or 0o prefixes. [scan $s %o] must continue to work
- even with KILL_OCTAL enabled.
-
- * generic/tclInt.h: Added TCL_PARSE_SCAN_PREFIXES to the flags
- * generic/tclStrToD.c: accepted by TclParseNumber.
-
-2005-09-01 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixSock.c (InitializeHostName): Synchronized use of static
- modifier in declaration and definition of function.
-
- * unix/tclUnixChan.c (FileTruncateProc): Synchronized use of static
- modifier in declaration and definition of function.
-
- * generic/tclResult.c (ReleaseKeys): Synchronized use of static
- modifier in declaration and definition of function.
-
- * generic/tclListObj.c (NewListIntRep): Synchronized use of static
- modifier in declaration and definition of function.
-
- * generic/tclEncoding.c (InitializeEncodingSearchPath): Synchronized
- use of static modifier in declaration and definition of function.
-
- * generic/tclEncoding.c (FillEncodingFileMap): Synchronized use of
- static modifier in declaration and definition of function.
-
- * generic/tclIORChan.c (RcNewHandle): Synchronized use of static
- modifier in declaration and definition of function.
-
-2005-09-01 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclObj.c: TclParseNumber calls meant to parse an integer
- value now pass the TCL_PARSE_INTEGER_ONLY flag.
-
- * generic/tclScan.c: Extended [scan] to accept the %lld, %llo, %llx,
- and %lli formats. Numeric scanning is now done via TclParseNumber calls
-
- * generic/tclInt.h: Extended TclParseNumber to accept new flag
- * generic/tclStrToD.c: values TCL_PARSE_INTEGER_ONLY,
- TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller
- more control over the parsing rules.
-
-2005-08-31 Vince Darley <vincentdarley@sourceforge.net>
-
- * doc/FileSystem.3:
- * unix/tclUnixFile.c:
- * windows/tclWinFile.c: clarify that Tcl_FSMatchInDirectory may be
- called with a NULL interpreter, and fix the code so this is allowed.
- Tcl's core itself (tclEncoding.c:FillEncodingFileMap()) calls this
- with a NULL interpreter.
-
-2005-08-30 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclObj.c: Extended bignum support to include bignums so
- large they will not pack into a Tcl_Obj. When they outgrow Tcl's string
- rep length limits, a panic will result.
-
- * generic/tclTomMath.h: Added mp_sqrt to routines from
- * unix/Makefile.in: libtommath used by Tcl.
- * win/Makefile.in:
- * win/makefile.vc:
-
- * generic/tclBasic.c: Extended sqrt(.) so that range covers the
- entire double range, accepting as many bignums in the domain as that
- will allow.
-
-2005-08-29 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl (::tcl::tm::roots): Accepted Don Porter's patch for
- [Bug 1189657]. Syncs the implementation to the specification (TIP #189)
-
-2005-08-29 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merge updates from HEAD.
-
- * generic/tclBasic.c: Restored round(.) to the Tcl 8.4 rules.
-
-2005-08-29 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclBasic.c (ExprMathFunc): Restored "round away from zero"
- * tests/expr.test (expr-46.*): behaviour to the "round" function.
- Added test cases for the behavior, including the awkward case of a
- number whose fractional part is 1/2-1/2ulp. [Bug 1275043]
-
-2005-08-26 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c: Moved Tcl_{Cut,Splice}Channel to
- {Cut,Splice}Channel for internal use, and created new public functions
- for Tcl_{Cut,Splice}Channel which walk the whole stack of
- transformations and invoke the necessary thread actions. Added code to
- Tcl_(Un)StackChannel to properly invoke the thread actions when pushing
- and popping transformations on/from a channel.
-
-2005-08-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (NamespaceEnsembleCmd): Reset the result after
- creating an ensemble to clear any result object sharing (potentially
- caused by delete traces) so that we can safely return the name of the
- ensemble. Previously, this caused crashes in Snit's test suite.
-
-2005-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and
- unsafe crashes from happening when working with very large string
- representations. [Bug 1267380]
-
- * generic/tclExecute.c (TEBC:INST_DICT_LAPPEND): Stop dropping a
- duplicated object on the floor, which was a memory leak (and a wrong
- result too). Thanks to Andreas Kupries for reporting this.
-
-2005-08-25 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merge updates from HEAD
-
- * generic/tclExecute.c: Bug fix. INST_RSHIFT: shift of negative values
- produced incorrect results.
-
- * generic/tclExecute.c: Bug fix. INST_*SHIFT opcodes stack management.
- [expr 0<<6] should be 0, not 6.
-
- * generic/tclBasic.c: Extended the domain of round(.) to all non-Inf,
- non-NaN doubles, using bignums for the result as needed.
-
-2005-08-24 Andreas Kupries <andreask@activestate.com>
-
- TIP#219 IMPLEMENTATION
-
- * doc/SetChanErr.3: ** New File **. Documentation of the new channel
- API functions.
- * generic/tcl.decls: Stub declarations of the new channel API.
- * generic/tclDecls.h: Regenerated
- * generic/tclStubInit.c:
-
- * tclIORChan.c: ** New File **. Implementation of the reflected
- channel.
- * generic/tclInt.h: Integration of reflected channel and new error
- * generic/tclIO.c: propagation into the generic I/O core.
- * generic/tclIOCmd.c:
- * generic/tclIO.h:
- * library/init.tcl:
-
- * tests/io.test: Extended testsuite.
- * tests/ioCmd.test:
- * tests/chan.test:
- * generic/tclTest.c:
- * generic/tclThreadTest.c:
-
- * unix/Makefile.in: Integration into the build machinery.
- * win/Makefile.in:
- * win/Makefile.vc:
-
-2005-08-24 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of
- * tests/binary.test (binary-65.*) formatting floating point
- numbers with the largest and smallest possible significands, and added
- test cases for them.
-
-2005-08-24 Kevin Kenny <kennykb@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Corrected some TRACE bugs that prevented
- compilation with --enable-symbols=all.
- * generic/tclStrToD.c: Revised commentary to prepare for a renaming of
- the file, removed some dead code, and fixed a bug where
- TclBignumToDouble failed on huge negative numbers.
- * tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint'
- to large/small significand tests.
- * tests/expr.test (expr-45.*) Added missing braces around expressions.
-
-2005-08-24 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclBasic.c: Revised implementation of the ceil(.) and
- * generic/tclInt.h: floor(.) math functions in light of the
- * generic/tclStrToD.c: revised comparison operators, so that it is
- always true that ($x <= ceil($x)) and ($x >= floor($x)). The simple
- approach of "convert to double and call ceil() or floor()" could not
- guarantee that.
-
- * generic/tclExecute.c: Bug fix: TclBignumToDouble return -Inf when
- appropriate. Removed declarations of removed routines.
-
- * generic/tclExecute.c: Revised the type promotion rules of the
- comparison operators so that they form proper equivalence classes over
- the set of numeric strings.
-
-2005-08-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure.in:
- * win/configure: Regen.
- * win/configure.in: Update minimum autoconf version to 2.59.
-
-2005-08-23 Kevin Kenny <kennykb@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * generic/tclInt.h:
- * generic/tclObj.c (Tcl_GetBooleanFromObj, SetDoubleFromAny,
- Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetBignumFromObj):
- * generic/tclParseExpr.c (GetLexeme):
- * generic/tclScan.c (Tcl_ScanObjCmd):
- * generic/tclStrToD.c (TclParseNumber):
- * tests/binary.test (binary-62.1-65.7):
- * tests/expr.test (expr-40.1-42.1):
- * scan.test (scan-14.1,14.2):
- Modified Tcl_ParseNumber to accept an argument to force interpretation
- as decimal, and modified [scan] to use it. Corrected a bug where Not a
- Number with hexadecimal information bits returned consistently
- incorrect values. #ifdef-ed out some code that is needed only for IBM
- hexadecimal floating point. Fixed bugs in code to handle the corner
- cases of smallest and largest significands. Added test cases to improve
- test coverage in generic/tclStrToD.c. Added test cases for 0b notation
- (TIP #114). Removed TclStrToD, and the static functions that it calls,
- which are now dead code (TclParseNumber now does all input
- floating-point conversions.)
-
-2005-08-23 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclStrToD.c: Bug fix: set shift magnitude properly whether
- we're expanding to mp_int type or not.
-
- * generic/tclExecute.c: Bug fix: ACCEPT_NAN under INST_UMINUS.
-
- * generic/tclStrToD.c: New macros TIP_114_FORMATS and KILL_OCTAL to
- configure acceptance of 0o and 0b numbers and rejection of "leading
- zero as octal".
-
- * generic/tclBasic.c: Re-used the guts of int(.) and wide(.) math
- functions to perform conversions in OldMathFuncProc.
-
- * generic/tclBasic.c: Support for ACCEPT_NAN.
- * generic/tclExecute.c:
-
- * generic/tclInt.decls: Restored TclExprFloatError to internal stubs
- * generic/tclBasic.c: table, and moved definition back to
- * generic/tclExecute.c: tclExecute.c from tclBasic.c to handle #undef
- ACCEPT_NAN.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclInt.h: New internal macros TclIsNaN and TclIsInfinite
- * generic/tclBasic.c: replace the IS_NAN and IS_INF macros scattered
- * generic/tclExecute.c: here and there.
- * generic/tclObj.c:
- * generic/tclStrToD.c:
- * generic/tclUtil.c:
-
-2005-08-22 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclConfig.h.in: autoheader-2.59.
-
-2005-08-22 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclInt.h: New ACCEPT_NAN macro to mark code that
- * generic/tclCmdAH.c: supports or disables accepting of the NaN
- * generic/tclExecute.c: value at various points.
- * generic/tclLink.c:
-
- * generic/tclStrToD.c: Bug fix. Parsing of +/- Infinity was reversed.
-
- * generic/tclTestObj.c: Disabled unused [testconvertobj] command.
-
- * generic/tclBasic: Added [expr {entier(.)}]. Rewrote int(.) and
- wide(.) to use the same guts, accepting all non-Inf doubles as
- arguments.
-
- * generic/tclInt.h: New routine TclInitBignumFromDouble.
- * generic/tclStrToD.c: Modified to return code and write error
- message.
-
- * generic/tclInt.h: TCL_WIDE_INT_IS_LONG implies NO_WIDE_TYPE.
- * generic/tclObj.c: Removed now unnecessary tests of the
- * generic/tclStrToD.c: TCL_WIDE_INT_IS_LONG definition.
-
- * generic/tclInt.h: New internal routine TclSetBignumIntRep
- * generic/tclObj.c: consolidates packing of bignum value into a
- * generic/tclStrToD.c: Tcl_Obj within one source code file.
-
- * tests/expr.test: Corrected the wideIs64bit constraint.
- * tests/format.test:
- * tests/scan.test:
-
-2005-08-21 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclInt.h: Moved TclParseInteger to tclUtil.c and
- * generic/tclParseExpr.c: made it static.
- * generic/tclUtil.c:
-
- * generic/tclInt.decls: Moved TclExprFloatError to tclBasic.c and made
- * generic/tclBasic.c: it static.
- * generic/tclExecute.c:
-
- * generitc/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclExecute.c: errno, IS_NAN, IS_INF, LLD no longer called in
- this file; dropped/disabled support for them.
-
- * generic/tclCompExpr.c: errno no longer used in these files;
- * generic/tclParseExpr.c: dropped support "hack" for it.
-
- * generic/tclStrToD.c: Disabled out of date support "hack" for errno.
-
- * generic/tclBasic.c: Eliminated VerifyExprObjType. Initialize errno
- to zero in OldMathFuncProc.
-
-2005-08-19 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclBasic.c: Updated OldMathFuncProc and ExprAbsFunc to do
- less invasion into numeric Tcl_Obj internals. Made ExprDoubleFunc,
- ExprIntFunc, ExprWideFunc, and ExprRoundFunc bignum-aware. Revised
- ExprSrandFunc error message.
-
- * generic/tclProc.c: Wrapped a few tclWideIntType uses in
- * generic/tclCmdMZ.c: #ifndef NO_WIDE_TYPE.
-
- * generic/tclInt.h: #define'd NO_WIDE_TYPE.
-
- * generic/tclVar.c: Replaced TclPtrIncrVar and TclPtrIncrWideVar
- * generic/tclInt.h: with TclPtrIncrObjVar and replaced TclIncrVar2
- * generic/tclInt.decls: and TclIncrWideVar2 with TclIncrObjVar2. New
- routines call on TclIncrObj to do the work.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclCmdIL.c: Rework Tcl_IncrObjCmd and the INST_*INCR*
- * generic/tclExecute.c: opcodes to use the new routines.
-
-2005-08-18 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Fixed string rep invalidation bug in
- * tests/dict.test (dict-11.17): INST_DICT_INCR_IMM rewrite.
-
- * generic/tclDictObj.c: DictIncrCmd rewrite to use TclIncrObj.
-
- * generic/tclInt.h: TclIncrObj static -> internal
- * generic/tclExecute.c:
-
-2005-08-17 George Peter Staplin <GeorgePS@XMission.com>
-
- * generic/tclBasic.c: eliminate a namespace clash caused by
- BuiltinFuncTable not being static.
-
- * generic/tclObj.c: fix a namespace clash caused by a missing
- static for pendingObjData.
-
-2005-08-17 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclEvent.c (Tcl_Finalize): Removed a copy-and-paste accident
- that caused a (mostly harmless) double finalize of the load and
- filesystem subsystems.
- * tests/clock.test: Eliminated the bad test clock-43.1, and split
- clock-50.1 into two tests, with a more permissive check on the error
- message for an out-of-range value.
-
-2005-08-17 Kevin Kenny <kennykb@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclBasic.c (Tcl_Expr{Long,Double}{,Obj}): Updated to
- * generic/tclTest.c: deal with
- * tests/expr-old.test: bignums (well,
- * tests/expr.test: mostly).
- Added a missing "errno=0;" in ExprUnaryFunc so that spurious error
- returns aren't detected.
- Added test cases for Tcl_Expr* and Tcl_Expr*Obj because there was very
- poor test coverage in those areas.
- * generic/tclParseExpr.c: Reworked parsing of numbers to call
- TclParseNumber rather than trying to do things locally.
- * generic/tclStrToD.c: Corrected a comment. Changed so that *endPtrPtr
- does not include any trailing whitespace.
-
-2005-08-17 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: New routine TclIncrObj to centralize the
- increment operation needed in many places. Updated INST_DICT_INCR_IMM
- to make use of it.
-
-2005-08-16 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Made bit shifting opcodes and INST_MOD
- bignum-aware.
-
- * tests/scan.test: Making << bignum-aware means that repeated
- * tests/string.test: left shifting cannot turn a positive into a
- negative. Revised [int_range] and [largest_int] utility commands in the
- test suite that relied on that happening. Without revision they became
- infinite loops.
-
- * generic/tclExecute.c: Made binary bitwise opcodes bignum-aware.
-
- * generic/tclTomMath.h: Added mp_or and mp_xor to routines from
- * unix/Makefile.in: libtommath used by Tcl.
- * win/Makefile.in:
- * win/makefile.vc:
-
-2005-08-15 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Updates from HEAD.
- * generic/tclExecute.c: More revisions to IllegalExprOperandType.
- Merged INST_BITNOT with INST_UMINUS and make it bignum-aware according
- to the rule: ~a = -a - 1. Disabled unused code and noted more TODOs.
-
- * generic/tclInt.decls: Disabled TclLooksLikeInt() and all callers.
- * generic/tclUtil.c:
- * generic/tclCompCmds.c:
-
- * generic/tclBasic.c: Rewrite of VerifyExprObjType().
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclExecute.c: Updated execution of comparison bytecodes to
- be bignum-aware, routing string compares through INST_STR_CMP.
-
-2005-08-14 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Updated execution of arithmetic bytecodes to
- be bignum-aware, and to allow calculations on NaN to produce a NaN
- result. INST_UMINUS updated to call mp_neg.
-
- * generic/tclTomMath.h: Added mp_and, mp_expt_d, and mp_neg to
- * unix/Makefile.in: routines from libtommath used by Tcl.
- * win/Makefile.in:
- * win/makefile.vc:
-
-2005-08-13 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclObj.c: Extended Bignum auto-narrowing to auto-narrow
- to tclWideIntType when appropriate; this helps keep things working as
- the bytecode execution code is migrated to supporting bignums.
-
- * generic/tclExecute.c: Major overhaul of IllegalExprOperandType.
- Changed several TclNewFooObj() calls to more logically appropriate
- ones. Added several TODO comments marking opportunies for future work.
- Made more use of the eePtr->constants. Made INST_UMINUS bignum aware.
-
-2005-08-12 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Simplify doCondJump. Use eePtr->constants as
- result of INST_DICT_NEXT, INST_LAND, and INST_LOR. Separate INST_LNOT
- from INST_UMINUS and simplify.
-
-2005-08-12 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (MktimeObjCmd):
- * library/clock.tcl (GetSystemTimeZone, LoadZoneinfoFile)
- (ReadZoneinfoFile):
- * tests/clock.test (clock-50.1):
- Added functionality to read /etc/localtime if it exists, so that Tcl's
- time can track system time on Linux even if TZ is not set. Changed
- ::tcl::clock::Mktime to check for failure, and added a test case that
- mimics failure but is really success.
-
-2005-08-11 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclExecute.c: Rewrite of INST_LAND/INST_LOR to take advantage
- of loss of "pure double" issues. Merged INST_UPLUS with
- INST_TRY_CVT_TO_NUMERIC and updated to use improved rules for impure
- "double"s as well.
-
- * generic/tclStrToD.c: Restored conditional generation of
- tclWideIntType values by TclParseNumber so that Tcl's not completely
- broken while bignum calculation support is incomplete. The NO_WIDE_TYPE
- macro can be used to disable this.
-
- * generic/tclBasic.c (ExprAbsFunc): First pass making [expr abs(.)]
- bignum-aware.
-
-2005-08-11 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclEvent.c: Eliminated the USE_THREAD_STORAGE option
- * generic/tclInt.h: (which is on in every build generated by
- * generic/tclThread.c: by the standard configurator).
- * generic/tclThreadStorage.c: Eliminated the code for thread specific
- * unix/configure: data without USE_THREAD_STORAGE and
- * unix/tcl.m4: radically refactored the code for
- * unix/tclConfig.h.in: USE_THREAD_STORAGE so that it has fewer
- * unix/tclUnixThrd.c: dependencies on the order of
- * win/configure: finalization. (Also, made 'make
- * win/Makefile.in: distclean' on Windows clean just a little
- * win/rules.vc: bit cleaner.)
- * win/tcl.m4:
- * win/tclWinThrd.c:
-
-2005-08-10 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclTomMath.h: Added mp_shrink, mp_to_unsigned_bin,
- * unix/Makefile.in: mp_to_unsigned_bin_n, and mp_unsigned_bin_size
- * win/Makefile.in: to routines from libtommath used by Tcl.
- * win/makefile.vc:
-
- * generic/tommath.h: make gentommath_h
-
- * generic/tclObj.c: Substantial rewrite to make all number parsing
- flow through TclParseNumber(). Also established the NO_WIDE_TYPE and
- BIGNUM_AUTO_NARROW #ifdef's to help track the assumptions of different
- portions of the code.
-
- * generic/tclInt.h: Added NO_WIDE_TYPE #ifdefs
-
-2005-08-10 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclEvent.c (Tcl_Finalize): Pushed Tcl_FinalizeLoad and
- Tcl_ResetFilesystem down after Tcl_FinalizeThreadAlloc because we can't
- unload DLL's until after their TSD keys are finalized. (Note that we'll
- still see aborts if an unloaded DLL has TSD - that still needs to be
- fixed.
-
- * tests/compExpr-old.test (compExpr-3.8): Made tests conditional on
- * tests/expr.test (expr-3.8): 'unix' because they get
- stack overflows on Win32 threaded builds,
-
-2005-08-09 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclPathObj.c: fix to [file rootname] bug in optimized code
- path reported on comp.lang.tcl.
-
-2005-08-08 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
-
- * generic/tclObj.c: Replaced some goto's with loops and started
- use of BIGNUM_AUTO_NARROW and NO_WIDE_TYPE.
-
-2005-08-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclThreadStorage.c: Stop exposing the guts of the thread
- storage system through the internal stubs table. Client code should
- always use the standard API.
-
-2005-08-05 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch]
- * generic/tclObj.c: Rewrote Tcl_GetDoubleFromObj().
-
-2005-08-05 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixInit.c (localeTable): Solaris uses a non-standard name
- for the cp1251 charset. Thanks to Victor Wagner for reporting this.
- [Bug 1252475]
-
-2005-08-05 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/makefile.vc: Removed unused file ldAout.tcl.
- * win/makefile.bc: [Bug 1244361]
-
- * tests/binary.test: Cleaned up testing for scanning of NaN. [Bug
- 1246264]
-
- * generic/tclBasic.c (ExprAbsFunc): Added code to handle the corner
- * tests/expr.test (expr-38.1): case of applying 'abs' to the
- smallest 32-bit integer. [Bug 1241572]
-
-2005-08-04 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CloseChannel): Fixed comment nit, added apparently
- missing word to complete a sentence.
-
- * generic/tclObj.c (Tcl_DbDecrRefCount): Fixed whitespace nit in panic
- message.
-
-2005-08-04 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Updated from HEAD
-
- * generic/tclObj.c: Rewrote Tcl_GetBooleanFromObj() and supporting
- routines to make use of TclParseNumber. This reduces the potential
- number of times a string value must be scanned.
-
- * generic/tclObj.c: Simplified routines that manage the typeTable.
- Deleted the UpdateStringOfBoolean() routine, that can never be called.
-
-2005-08-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Untangled some dependencies in the
- * generic/tclEvent.c: order of finalization routines.
- * generic/tclInt.h: [Bug 1251399]
- * generic/tclObj.c:
-
-2005-08-02 Don Porter <dgp@users.sourceforge.net>
-
- [kennykb-numerics-branch] Updated from HEAD
-
-2005-07-30 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds for
- bugs/changes in behaviour in Mac OS X 10.4 Tiger.
-
-2005-07-29 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (InfoGlobalsCmd): Even in high-speed mode, still
- have to take care with non-existant variables. [Bug 1247135]
-
-2005-07-28 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/README: Update link to msys_mingw8.zip.
-
-2005-07-28 Don Porter <dgp@users.sourceforge.net>
-
- * tests/compExpr-old.test: Still more conversion of "nonPortable"
- * tests/error.test: tests into tests with constraints that
- * tests/expr-old.test: describe the limits of their
- * tests/expr.test: portability. Also more consolidation
- * tests/fileName.test: of constraint synonyms.
- * tests/format.test: wideis64bit, 64bitInts => wideIs64bit
- * tests/get.test: wideIntegerUnparsed => wideIs32bit
- * tests/load.test: wideIntExpressions => wideBiggerThanInt
- * tests/obj.test:
- * tests/parseExpr.test: Dropped "roundOffBug" constraint that
- * tests/string.test: protected from buggy sprintf.
-
-2005-07-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclPipe.c (TclCreatePipeline): Arrange for POSIX systems to
- * unix/tclUnixPipe.c (TclpOpenFile): use the O_APPEND flag for
- * tests/exec.test (exec-19.1): files opened in a pipeline
- like ">>this". Note that Windows cannot support such access; there is
- no equivalent flag on the handle that can be set at the kernel-call
- level. The test is unix-specific in every way. [Bug 1245953]
-
-2005-07-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: Converted the $::tcl_precision value to be kept
- per-thread to prevent different threads from stomping on each others'
- formatting prescriptions.
-
- ***POTENTIAL INCOMPATIBILITY*** Multi-threaded programs that set the
- value of ::tcl_precision will now have to set it in each thread.
-
- * tests/expr.test: Consolidated equivalent constraints into
- * tests/fileName.test: single definitions and (more precise) names:
- * tests/get.test: longis32bit, 32bit, !intsAre64bit => longIs32bit
- * tests/listObj.test: empty => emptyTest; winOnly => win
- * tests/obj.test: intsAre64bit => longIs64bit
- Also updated some "nonPortable" tests to use constraints that mark
- precisely what about them isn't portable, so the tests can run where
- they work.
-
- * library/init.tcl ([unknown]): Corrected return code handling in the
- portions of [unknown] that expand incomplete commands during
- interactive operations. [Bug 1214462].
-
-2005-07-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/configure.in: Check for a $prefix/share directory and add it the
- the package if found. This will check for Tcl packages in
- /usr/local/share when Tcl is configured with the default dist install.
- [Patch 1231015]
-
-2005-07-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_CallWhenDeleted): Converted to use
- per-thread counter, rather than a process global one that required
- mutex protection. [RFE 1077194]
-
- * generic/tclNamesp.c (TclTeardownNamespace): Re-ordering so that
- * tests/trace.test (trace-34.4): command delete traces fire
- while the command still exists. [Bug 1047286]
-
-2005-07-24 Mo DeJong <mdejong@users.sourceforge.net>
-
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH):
- * win/configure: Regen.
- * win/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH): Split confused search
- for tclsh on PATH and build and install locations into two macros.
- SC_PROG_TCLSH searches just the PATH. SC_BUILD_TCLSH determines the
- name of the tclsh executable in the Tcl build directory. [Bug 1160114]
- [Patch 1244153]
-
-2005-07-23 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Updates to the Tcl script library to make use
- * library/history.tcl: of Tcl 8.4 features. Forward port of
- * library/init.tcl: appropriate portions of [Patch 1237755].
- * library/package.tcl:
- * library/safe.tcl:
- * library/word.tcl:
-
-2005-07-23 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/string.test: Add string is tests for functionality that was not
- tested.
- * win/README: Update msys + mingw URL. Remove old Cygwin + mingw info.
-
-2005-07-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_DICT_*): stop 2 compiler warnings for
- uninitialised variables.
-
-2005-07-23 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TEBC:INST_DICT_INCR_IMM): Fix the incrementor
- to work correctly with wide values.
-
-2005-07-21 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictCmd): First run at a compiler
- * generic/tclExecute.c (TclExecuteByteCode): for dictionaries. Also
- added an instruction to support 'finally'-like clauses, exposed more of
- the dict guts to the rest of the core, and defined a few tests to
- exercise more obscure parts of the compiler's operation that were bugs
- during development.
-
-2005-07-21 Kevin B. Kenny <kennykb@acm.org>
-
- * library/ldAout.tcl (***REMOVED***): Removed support for ancient
- * unix/configure: BSD's, IRIX 4, RISCos and
- * unix/Makefile.in: Ultrix. Removed two files whose
- * unix/tcl.m4: code is used only on those
- * unix/tclLoadAout.c (***REMOVED***): antique platforms.
-
- ***POTENTIAL INCOMPATIBILITY*** if anyone actually uses those
- platforms; it is to be noted though, that an error in the installer has
- actually not caused a necessary file to be installed on those platforms
- in several releases, and nobody's complained.
-
-2005-07-16 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (RefineResult): Plugged a stupid memory leak in
- RefineResult (called from Tcl_StrToD). [Tk Bug 1227781]
-
-2005-07-15 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (TclClockLocaltimeObjCmd,ThreadSafeLocalTime):
- * library/clock.tcl (GuessWindowsTimeZone, ClearCaches):
- * tests/clock.test (clock-49.1, clock-49.2):
- Handle correctly the case where localtime() returns NULL to report a
- conversion error. Also handle the case where the Windows registry
- contains timezone values that can be mapped to a tzdata file name but
- the corresponding file does not exist or is corrupted, by falling back
- on a Posix timezone string instead; this last case will avoid calls to
- localtime() in starpacks on Windows. [Bug 1237907]
-
-2005-07-14 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCompile.c: Update to follow style guidelines.
- (TclPrintInstruction): Reorganize to do better printing out of bytecode
- with far fewer "special hacks" for particular opcodes.
- * generic/tclCompile.h: Requires two new opcode types.
-
-2005-07-13 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixSock.c: Use a ProcessGlobalValue to store the value
- * win/tclWinSock.c: returned by Tcl_GetHostName() ([info
- hostname]). Also re-order initialization of the value on Windows to
- favor GetComputerName() over gethostname() as a source of the
- information.
-
-2005-07-12 Kevin Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Updated from HEAD
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * generic/tclInt.h:
- * generic/tclObj.c (Tcl_GetDoubleFromObj, SetDoubleFromAny)
- (Tcl_GetIntFromObj, SetIntOrWideFromAny):
- * generic/tclStrToD.c (TclParseNumber, etc.):
- * tclTomMathInterface.c (TclBNInitBignumFromWideUInt):
- * tests/obj.test (obj-1.1, obj-2.2, obj-3.1, obj-3.2):
-
- Initial attempt at an implementation of TIP #249, comprising a unified
- parser and modifications to the Tcl_Get*FromObj routines to use it.
- Further integration of the parser is necessary and planned.
-
-2005-07-12 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/lsearch.n: Clarify documentation of -exact option; wording was
- open to misinterpretation by non-English speakers.
-
-2005-07-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c: General style cleanup.
-
-2005-07-08 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): Reimplement long and wide
- type integer division and modulus operations so that the smallest and
- largest integer values are handled properly. The divide operation is
- more efficient since it no longer does a modulus or negation and only
- checks for a remainder when the quotient will be a negative number.
- The modulus operation is now a bit more complex because of a number of
- special cases dealing with the smallest and largest integers.
- * tests/expr.test: Add test cases for division and modulus operations
- on the smallest and largest integer values for 32 and 64 bit types.
- [Patch 1230205]
-
-2005-07-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclLink.c: Simplified LinkTraceProc [Bug 1208108].
-
-2005-07-05 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Purged use of TCLTESTARGS [RFE 1161550].
-
- * generic/tclUtil.c: Converted TclFormatInt() into a macro.
- * generic/tclInt.decls: [RFE 1194015]
- * generic/tclInt.h:
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclNamesp.c: Allow for [namespace import] of a command
- * tests/namespace.test: over a previous [namespace import] of itself
- without throwing an error. [RFE 1230597]
-
-2005-07-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictForCmd, DictFilterCmd): Interlocking of
- dictionary internal representations is now done in the core of the dict
- iterator. Purge the last attempts at doing it at a higher level as they
- didn't work and were no longer needed.
-
-2005-07-01 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixNotfy.c: protect against spurious wake-ups while waiting
- on the condition variable when tearing down the notifier thread [Bug
- 1222872].
-
-2005-06-28 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode): When parsing an integer
- operand for a unary minus expression operator, check for a wide integer
- that is actually LONG_MIN. If found, convert back to a long int type.
- * tests/expr.test: Add constraint for 32bit long int type and 64bit
- wide int type. Add tests that parse the smallest/largest long int and
- wide int values.
-
-2005-06-24 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclEvent.c (Tcl_Finalize):
- * generic/tclInt.h:
- * generic/tclPreserve.c (TclFinalizePreserve): Changed the finalization
- logic so that Tcl_Preserve finalizes after exit handlers run; a lot of
- code called from Tk's exit handlers presumes that Tcl_Preserve will
- still work even from an exit handler.
-
-2005-06-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Make file safe to re-[source] without
- destroying registered auto_mkindex_parser hooks.
-
-2005-06-23 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWinChan.c: More rewriting of __asm__ blocks that implement
- * win/tclWinFCmd.c: SEH in GCC, because mingw's gcc 3.4.2 is not as
- forgiving of violations committed by the old code and caused panics.
- [Bug 1225957]
-
-2005-06-23 Daniel Steffen <das@users.sourceforge.net>
-
- * tools/tcltk-man2html.tcl: fixed useversion glob pattern to accept
- multi-digit patchlevels.
-
-2005-06-22 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinFile.c: Potential buffer overflow. [Bug 1225571] Thanks to
- Pat Thoyts for discovery and fix.
-
-2005-06-22 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclInt.h: Changed the finalization
- * generic/tclEvent.c (Tcl_Finalize): logic to defer the
- * generic/tclIO.c (TclFinalizeIOSubsystem): shutdown of the pipe
- * unix/tclUnixPipe.c (TclFinalizePipes): management until after all
- * win/tclWinPipe.c (TclFinalizePipes): channels have been closed,
- in order to avoid a situation where the Windows PipeCloseProc2 would
- re-establish the exit handler after exit handlers had already run,
- corrupting the heap. [Bug 1225727] Also corrected a potential read of
- uninitialized memory in PipeClose2Proc [Bug 1225044]
-
-2005-06-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclInt.h: Followup to change made on 2005-06-18 by Daniel
- Steffen. There are compilers (*) who error out on the redefinition of
- WORDS_BIGENDIAN. We have to undef the previous definition (on the
- command line) first to make this acceptable. (*): AIX native.
-
-2005-06-21 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclFileName.c: Changed [file split] and [file join] to treat
- Windows drive letters similarly to ~ syntax and make sure that they
- appear with "./" in front when they are in intermediate components of
- the path. [Bug 1194458]
- * tests/fileName.test: Added test for the above bug.
-
-2005-06-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Added missing walk of the list of active
- * generic/tclTrace.c: traces to cleanup references to traces being
- * generic/tclInt.h: deleted. [Bug 1201035] Made the walk of the
- * tests/trace.test (trace-34.*): active trace list aware of the
- direction of trace scanning, so the proper correction can be made.
- [Bug 1224585]
-
-2005-06-21 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS): Only enable the 'compile' special
- debugging feature when requested in configure.in; removes irrelevant
- junk from the configure files of extensions that use Tcl's tcl.m4.
-
-2005-06-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompile.h (INST_PUSH_RETURN_OPTIONS): New opcode to allow
- * generic/tclCompCmds.c (TclCompileCatchCmd): compilation of
- * generic/tclCompile.c: TIP#90 catch [Bug
- * generic/tclExecute.c (TclExecuteByteCode): 1219112]
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Ensure we spill to the
- command form in all cases where it generates an error.
-
-2005-06-20 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Generate an error if a mode
- argument like -exact is passed more than once to the switch command.
- The previous implementation silently accepted invalid switch
- invocations like [switch -exact -glob $str ...].
- * tests/for.test: Check some error cases when invoking continue and
- break inside a for loop next script.
- * tests/switch.test: Add checks for shortened version of a mode
- argument like -exact. Add test for more than one mode argument. Add
- test for odd case of passing a variable as a body script.
-
-2005-06-18 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with
- fat compiles on Darwin (i.e. ppc and i386 at the same time), the
- configure AC_C_BIGENDIAN check is not sufficient in this case because a
- single run of the compiler builds for two architectures with different
- endianness.
-
- * unix/tcl.m4 (Darwin): add -headerpad_max_install_names to LDFLAGS to
- ensure we can always relocate binaries with install_name_tool.
-
- * unix/configure: autoconf-2.59
-
-2005-06-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): Fix for [Bug 1154163]; only
- * tests/format.test: insert 'l' modifier when it is needed.
-
-2005-06-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclTimer.c (AfterDelay): Split out the code to manage
- synchronous-delay [after] commands.
- * tests/interp.test (interp-34.10): Time limits and synch-delay [after]
- did not mix well... [Bug 1221395]
-
-2005-06-14 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Only delete a
- * tests/namespace.test (namespace-49.2): command from the hashtable on
- reentrant processing if it has not been already deleted; at least three
- deletes of the same command are possible. [Bug 1220058]
- * generic/tclTrace.c (TraceCommandProc): Remove bogus error message
- creation when traces trigger in situations where the command has
- already been deleted.
-
-2005-06-13 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFCmd.c: correct fix to file mkdir 2005-06-09 [Bug 1219176]
-
-2005-06-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c: Factor out some common idioms into named forms
- for greater clarity.
-
-2005-06-10 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n: Fold in the descriptive parts of the documentation for
- all the commands that [chan] builds on top of.
-
-2005-06-09 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFCmd.c: fix to race condition in file mkdir [Bug 1217375]
- * doc/glob.n: improve glob documentation [Bug 1190891]
-
-2005-06-09 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/expr.n, doc/mathfunc.n: Fix minor typos [Bug 1211078] and add
- mention of distinctly-relevant [namespace path] subcommand.
-
-2005-06-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Reduced the Tcl_ObjTypes "index",
- * generic/tclIndexObj.c: "ensembleCmd", "localVarName", and
- * generic/tclNamesp.c: "levelReference" to file static scope.
- * generic/tclProc.c:
- * generic/tclVar.c:
-
- * generic/tclObj.c: Restored registration of the "procbody"
- Tcl_ObjType, as required by the tclcompiler application.
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2005-06-07 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIO.c (Tcl_ChannelTruncateProc): Stop proliferation of
- * generic/tcl.h: channel type versions
- * doc/CrtChannel.3: following advice from AKu
-
- Bump patchlevel to a4 to distinguish from a3 release.
-
- * generic/tclInt.h (INTERP_TRACE_IN_PROGRESS): Add flag so the error
- * generic/tclIndexObj.c (Tcl_WrongNumArgs): messages from ensembles
- * generic/tclIOCmd.c (Tcl_ReadObjCmd): can be correct.
-
- TIP#208 IMPLEMENTATION
-
- * library/init.tcl: Create the chan ensemble.
- * tests/chan.test: Rudimentary test suite.
- * doc/chan.n: General documentation.
-
- TRUNCATION API (part of TIP#208)
- * generic/tcl.h, generic/tcl.decls: Declaration of the API.
- * doc/CrtChannel.3, doc/OpenFileChnl.3: Documentation of the API.
- * generic/tclBasic.c (Tcl_CreateInterp): Create the mapping into Tcl.
- * generic/tclIOCmd.c (TclChanTruncateObjCmd): Implementation of
- Tcl-level truncation API.
- * generic/tclIO.c (Tcl_TruncateChannel): Generic C-level truncation API
- implementation.
- * unix/tclUnixChan.c (FileTruncateProc): Basic implementation of
- truncating driver.
-
- * win/tclWinChan.c (FileTruncateProc): Added implementation of file
- truncation for Windows.
- * tests/chan.test (chan-15.2): Added real test of truncation.
-
-2005-06-06 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWin32Dll.c: Corrected another buglet in the assembly code for
- stack probing on Win32/gcc. [Bug 1213678]
- * generic/tclObj,c: Added missing 'static' on definition of
- UpdateStringOfBignum, and removed a 'switch' on a 'long long' operand
- (which HP-UX native 'cc' seems unable to handle). [Bug 1215775]
-
-2005-06-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- *** 8.5a3 TAGGED FOR RELEASE ***
-
- * unix/Makefile.in (dist): add libtommath
-
-2005-06-03 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * library/parray.tcl (parray): Only generate the sorted list of element
- names once. Thanks to Andreas Leitgeb for spotting this.
-
-2005-06-03 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: fixed 'embedded' target.
-
-2005-06-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in (html): add BUILD_HTML_FLAGS optional var
- * tools/tcltk-man2html.tcl: add a --useversion to prevent confusion
- when multiple Tcl source dirs exist.
-
-2005-06-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: For compatibility with earlier Tcl releases,
- * generic/tclResult.c: when a command procedure simply does a
- * generic/tclTest.c: "return TCL_RETURN;" we must interpret that
- * tests/result.test: the same as
- "return Tcl_SetReturnOptions(interp, Tcl_NewObj());" [Bug 1209759].
-
-2005-06-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Allow compilation of
- -nocase -glob [switch]es (only one we know how to compile).
-
- TIP#241 IMPLEMENTATION from Joe Mistachkin
-
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd, Tcl_LsortObjCmd):
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Implementation of -nocase
- option for [lsearch], [lsort] and [switch] commands.
- * win/tclWinPort.h: Win uses nonstandard function names...
- * tests/cmdIL.test, tests/lsearch.test, tests/switch.test: Tests
- * doc/lsearch.n, doc/lsort.n, doc/switch.n: Docs
-
- * generic/tclCompCmds.c (TclCompileLindexCmd): Compile the most common
- case of [lindex] more efficiently.
-
- * unix/tclUnixNotfy.c (Tcl_FinalizeNotifier): Pass the correct number
- of arguments to Tcl_JoinThread.
-
-2005-05-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/configure.in, unix/tcl.m4: Standardize generation of help
- messages to always use AC_HELP_STRING and always (except for --with-tcl
- and --with-tk, where the default is complex) say what the default is.
-
-2005-05-31 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixNotfy.c: the notifier thread is now created as joinable
- thread and it is properly joined in Tcl_FinalizeNotifier. This is an
- attempt to fix the [Bug 1082283].
-
-2005-05-30 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * win/tclWinThrd.c: Fixed [Bug 1204064]
-
-2005-05-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP #229 IMPLEMENTATION
-
- * generic/tclNamesp.c (Tcl_FindCommand, TclResetShadowedCmdRefs)
- (NamespacePathCmd, SetNsPath, UnlinkNsPath, TclInvalidateNsPath):
- Implementation of the [namespace path] command and the command name
- resolution engine.
- * doc/info.n, doc/namespace.n: Doc updates.
- * tests/namespace.test (namespace-51.*): Test updates.
- * generic/tclResolve.c (BumpCmdRefEpochs, Tcl_SetNamespaceResolvers):
- * generic/tclBasic.c (Tcl_CreateCommand, Tcl_CreateObjCommand): Ensure
- that people don't see stale paths.
- * generic/tclInt.h (Namespace, NamespacePathEntry): Structure defs.
- * generic/tclCmdIL.c (InfoCommandsCmd): Updates to [info commands].
-
-2005-05-26 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Makefile: moved & corrected EMBEDDED_BUILD check.
-
- * unix/configure.in: corrected framework finalization to softlink stub
- library to Versions/8.x subdir instead of Versions/Current.
- * unix/configure: autoconf-2.59
-
-2005-05-25 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCmdMZ.c (Tcl_TimeObjCmd): add necessary cast
-
-2005-05-25 Don Porter <dgp@users.sourceforge.net>
-
- TIP#182 IMPLEMENTATION [Patch 1165062]
-
- * doc/mathfunc.n: New built-in math function bool().
- * generic/tclBasic.c:
- * tests/expr.test:
- * tests/info.test:
-
-2005-05-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl: Updated [unknown] to be sure the [return]
- * tests/init.test: options from an auto-loaded command are seen
- correctly by the caller.
-
-2005-05-24 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/env.test: added DYLD_FRAMEWORK_PATH to the list of env vars
- that need to be handled specially.
-
- * macosx/Makefile:
- * macosx/README:
- * macosx/Tcl-Info.plist.in (new file):
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/tcl.m4:
- * unix/tclUnixInit.c: moved all Darwin framework build support from
- macosx/Makefile into the standard unix configure/make buildsystem, the
- macosx/Makefile is no longer required to build Tcl.framework (but its
- functionality is still available for backwards compatibility).
- * unix/configure: autoconf-2.59
-
- * generic/tclIOUtil.c (TclLoadFile):
- * generic/tclInt.h:
- * unix/tcl.m4:
- * unix/tclLoadDyld.c: added support for [load]ing .bundle binaries in
- addition to .dylib's: .bundle's can be [unload]ed (unlike .dylib's),
- and can be [load]ed from memory, e.g. directly from VFS without needing
- to be written out to a temporary location first. [Bug 1202209]
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * generic/tclCmdMZ.c (Tcl_TimeObjCmd): change [time] called with a
- count > 1 to return a string with a float value instead of a rounded
- off integer. [Bug 1202178]
-
- * doc/expr.n:
- * doc/string.n: fixed roff syntax complaints from 'make html'.
-
-2005-05-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Corrected parser to recognize all
- boolean literals accepted by Tcl_GetBoolean, including prefixes like
- "y" and "f", and to allow "eq" and "ne" as function names in the proper
- context. [Bug 1201589].
-
-2005-05-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (TclEvalObjvInternal): Rewrite for greater
- clarity; although 'goto' is Bad, the contortions you have to go through
- to avoid it can be worse...
-
-2005-05-19 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c (Tcl_InitNotifier): fixed crashing CFRelease
- of runLoopSource in Tcl_InitNotifier (reported by Zoran):
- CFRunLoopAddSource doesn't CFRetain, so can only CFRelease the
- runLoopSource in Tcl_FinalizeNotifier.
-
-2005-05-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_ExprBoolean): Rewrite as wrapper around
- Tcl_ExprBooleanObj.
-
- * generic/tclCmdMZ.c ([string is boolean/true/false]): Rewrite dropping
- string-based Tcl_GetBoolean call, so that internal reps are kept for
- subsequent quick boolean operations.
-
- * generic/tclExecute.c: Dropped most special handling of the "boolean"
- Tcl_ObjType, since that type should now be rarely encountered.
-
- * doc/BoolObj.3: Rewrite of documentation dropping many details
- about the internals of Tcl_Objs. Shorter documentation focuses on the
- function and use of the routines.
-
- * generic/tclInt.h: Revision to the "boolean" Tcl_ObjType, so that
- * generic/tclObj.c: only string values like "yes" and "false" are
- * tests/obj.test: kept as the "boolean" Tcl_ObjType. The string
- values "0" and "1" are kept as "int" Tcl_ObjType, which also produce
- quick calls to Tcl_GetBooleanFromObj(). Since this internal change
- means a Tcl_ConvertToType to a "boolean" Tcl_ObjType might not produce
- a Tcl_Obj of type "boolean", the registration of the "boolean" type is
- also removed.
- ***POTENTIAL INCOMPATIBILITY***
- For callers of Tcl_GetObjType on the type name "boolean".
-
-2005-05-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclObj.c (TclInitObjSubsystem): Removed the
- * tests/listObj.test: registration of the Tcl_ObjType's "list",
- * tests/obj.test: "procbody", "index", "ensembleCommand",
- "localVarName", and "levelReference". The only reason to register a
- Tcl_ObjType is to have it returned by Tcl_GetObjType, and the only
- reason for that is to retrieve a (Tcl_ObjType *) to pass to
- Tcl_ConvertToType(). None of the types above can support a
- Tcl_ConvertToType() call; they panic. Better not to offer something
- than to lead users into a panic.
- ***POTENTIAL INCOMPATIBILITY***
- For callers of Tcl_GetObjType on the type names listed above.
-
-2005-05-15 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * win/tclWin32Dll.c: conditioned definition of EXCEPTION_REGISTRATION
- structures on HAVE_NO_SEH, to fix a bug in buildability on MSVC.
-
-2005-05-14 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls:
- * generic/tclTest.c:
- * generic/tclUtil.c:
- * win/tclWin32Dll.c: fixed link error due to direct access by tclTest.c
- to the MODULE_SCOPE tclPlatform global: renamed existing
- TclWinGetPlatform() accessor to TclGetPlatform() and moved it to
- generic code so that it can be used by on all platforms where
- MODULE_SCOPE is enforced.
-
- * macosx/tclMacOSXBundle.c:
- * unix/tclUnixInit.c:
- * unix/tcl.m4 (Darwin): made use of CoreFoundation API configurable and
- added test of CoreFoundation availablility to allow building on ppc64,
- replaced HAVE_CFBUNDLE by HAVE_COREFOUNDATION; test for availability of
- Tiger or later OSSpinLockLock API.
-
- * unix/tclUnixNotfy.c:
- * unix/Makefile.in:
- * macosx/tclMacOSXNotify.c (new file): when CoreFoundation is
- available, use new CFRunLoop based notifier: allows easy integration
- with other event loops on Mac OS X, in particular the TkAqua Carbon
- event loop is now integrated via a standard tcl event source (instead
- of TkAqua upon loading having to finalize the exsting notifier and
- replace it with its custom version). [Patch 1202052]
-
- * tests/unixNotfy.test: don't run unthreaded tests on Darwin since
- notifier may be using threads even in unthreaded core.
-
- * unix/tclUnixPort.h:
- * unix/tcl.m4 (Darwin): test for thread-unsafe realpath during
- configure, as Darwin 7 and later realpath is threadsafe.
-
- * macosx/Makefile: enable configure caching.
-
- * unix/configure.in: wrap tclConfig.h header in #ifndef _TCLCONFIG so
- that it can be included more than once without warnings from gcc4.0 (as
- happens e.g. when including both tclInt.h and tclPort.h)
-
- * macosx/tclMacOSXBundle.c:
- * unix/tclUnixChan.c:
- * unix/tclLoadDyld.c:
- * unix/tclUnixInit.c: fixed gcc 4.0 warnings.
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: make genstubs
-
-2005-05-13 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWin32Dll.c: Further rework of the SEH logic. All
- EXCEPTION_REGISTRATION records are now in the activation record rather
- than pushed on the stack.
-
-2005-05-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Dropped the TCL_NO_MATH configuration. It's
- * generic/tclBinary.c: believed this has not been working in a long
- * generic/tclExecute.c: time. Tcl needs math.h. [RFE 1200680]
- * unix/Makefile.in:
-
-2005-05-12 Kevin Kenny <kennykb@acm.org>
-
- * doc/mathfunc.n: Changed NAME line to match the name of the page.
-
-2005-05-11 Kevin Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Resynchronized with the HEAD; at this
- checkpoint [-rkennykb-numerics-branch-20050511], the HEAD and
- kennykb-numerics-branch contain identical code.
-
-2005-05-11 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c (TclStrToD, RefineResult, ParseNaN): Changed the
- code to cast 'char' to UCHAR explicitly when using ctype macros, to
- silence complaints from the Solaris compiler.
-
-2005-05-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixFCmd.c: add lint attr to enum to satisfy strictly
- compliant compilers that don't like trailing ,s.
-
- * tests/string.test: string-10.[21-30]
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): add extra checks to prevent
- possible UMR in unichar cmp function for string map.
-
-2005-05-10 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclBinary.c (FormatNumber): Fixed a bug where NaN's resulted
- in reads of uninitialized memory when using 'd', 'q', or 'Q' format.
- * generic/tclStrToD.c (ParseNaN, TclFormatNaN): Added code to handle
- the peculiarities of HP's PA_RISC, which uses a different 'quiet' bit
- in NaN from everyone else.
- * libtommath/tommath_superclass.h: Corrected C++-style comment.
-
-2005-05-10 Kevin Kenny <kennykb@acm.org>
-
- Merged all changes on kennykb-numerics-branch back into the HEAD.
- TIP's 132 and 232 are now Final.
-
-2005-05-10 Kevin Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged changes from HEAD.
-
-2005-05-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (ExponLong, ExponWide):
- * tests/expr.test (expr-23.34/35): fixed special case 'i**0' for i>0
- [Bug 1198892]
-
-2005-05-09 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
- * win/tclWin32Dll.c (TclpCheckStackSpace, TclWinCPUID): Reworked
- structured event handling to function even with -fomit-frame-pointers.
-
-2005-05-08 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
- * generic/tclStrToD.c: Made code more portable by finding a workaround
- for MSVC's 'volatile' issue that does not require conditional
- compilation.
- * win/tclWin32Dll.c (TclWinCPUID): Removed structured event handling
- from the GCC code since (a) bad code is generated by the instruction
- scheduling with -O2, and (b) it's not needed on any reasonably modern
- CPU.
-
-2005-05-07 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
- * generic/tclEvent.c: Moved initialization of tclStrToD.c's
- * generic/tclInt.h: static constants into a procedure called
- * generic/tclStrToD.c: from TclInitSubsystems to avoid double checked
- locking protocol. Cleaned up an issue where MSVC ignored the
- 'volatile' specifier, causing incorrect comparison of an underflowed
- number against zero.
-
-2005-05-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tcl.m4, unix/configure: correct Solaris 10 (5.10) check and add
- support for x86_64 Solaris cc builds.
-
-2005-05-05 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged with HEAD.
-
-2005-05-05 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinThrd.c: Corrected a compilation error on the
- --enable-threads configuration.
-
-2005-05-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.decls: Converted TclMatchIsTrivial to a macro.
- * generic/tclInt.h:
- * generic/tclUtil.c:
- * generic/tclIntDecls.h: `make genstubs`
- * generic/tclStubInit.c:
- * generic/tclBasic.c: Added callers of TclMatchIsTrivial where a
- * generic/tclCmdIL.c: search can be done more efficiently when it is
- * generic/tclCompCmds.c:recognized that a pattern match is really an
- * generic/tclDictObj.c: exact match. [Patch 1076088]
- * generic/tclIO.c:
- * generic/tclNamesp.c:
- * generic/tclVar.c:
-
- * generic/tclCompCmds.c: Factored common efficiency trick into a
- macro named CompileWord.
-
- * generic/tclCompCmds.c: Replaced all instance of
- * generic/tclCompile.c: TCL_OUT_LINE_COMPILE with TCL_ERROR.
- * generic/tclInt.h: Now that we've eradicated the mistaken
- * tests/appendComp.test: notion of a "compile-time error", we
- can use the TCL_ERROR return code to signal any failure to produce
- bytecode.
-
-2005-05-03 Don Porter <dgp@users.sourceforge.net>
-
- * doc/DString.3: Eliminated use of identifier "string" in Tcl's
- * doc/Environment.3: public C API to avoid conflict/confusion with
- * doc/Eval.3: the std::string of C++.
- * doc/ExprLong.3, doc/ExprLongObj.3, doc/GetInt.3, doc/GetOpnFl.3:
- * doc/ParseCmd.3, doc/RegExp.3, doc/SetResult.3, doc/StrMatch.3:
- * doc/Utf.3, generic/tcl.decls, generic/tclBasic.c, generic/tclEnv.c:
- * generic/tclGet.c, generic/tclParse.c, generic/tclParseExpr.c:
- * generic/tclRegexp.c, generic/tclResult.c, generic/tclUtf.c:
- * generic/tclUtil.c, unix/tclUnixChan.c:
-
- * generic/tclDecls.h: `make genstubs`
-
-2005-05-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.decls:
- * generic/tclBasic.c: Simplified implementation of Tcl_ExprString.
- * tests/expr-old.test:
-
- * generic/tclDecls.h: `make genstubs`
-
-2005-04-30 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixNotfy.c: applied dkf's tkMacOSXNotify.c cleanup changes.
-
-2005-04-29 Don Porter <dgp@users.sourceforge.net>
-
- TIP#176 IMPLEMENTATION [Patch 1165695]
-
- * generic/tclUtil.c: Extended TclGetIntForIndex to recognize index
- formats including end+integer and integer+/-integer.
-
- * generic/tclCmdMZ.c: Extended the -start switch of [regexp] and
- [regsub] to accept all index formats known by TclGetIntForIndex.
-
- * doc/lindex.n: Updated docs to note new index formats.
- * doc/linsert.n, doc/lrange.n, doc/lreplace.n, doc/lsearch.n:
- * doc/lset.n, doc/lsort.n, doc/regexp.n, doc/regsub.n, doc/string.n:
-
- * tests/cmdIL.test: Updated tests.
- * tests/compile.test, tests/lindex.test, tests/linsert.test:
- * tests/lrange.test, tests/lreplace.test, tests/lsearch.test:
- * tests/lset.test, tests/regexp.test, tests/regexpComp.test:
- * tests/string.test, tests/stringComp.test, tests/util.test:
-
-2005-04-28 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test (7.1): Alternative fix for the 2004-11-11 commit.
-
-2005-04-27 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl: Corrected flaw in interactive command
- * tests/main.test: auto-completion. [Bug 1191409].
-
- TIP#183 IMPLEMENTATION [Patch 577093]
-
- * generic/tclIOUtil.c (TclGetOpenModeEx): New routine.
- * generic/tclInt.h:
-
- * generic/tclIO.c (Tcl_OpenObjCmd): Support for "b" and
- * doc/open.n: "BINARY" in "access" argument to [open].
- * tests/ioCmd.test:
-
-2005-04-26 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclBinary.c (FormatNumber): Dredge the NaN out of the
- internal representation if Tcl_GetDoubleFromObj returns TCL_ERROR on a
- NaN.
-
- * generic/tclObj.c (Tcl_GetDoubleFromObj): Restored silent
- overflow/underflow behaviour that the merge of 2004-04-25 messed up.
- Thanks to Don Porter for calling attention to this bug. Also removed an
- uninitialised memory reference in this function that valgrind caught.
- Also changed to return TCL_ERROR on a pure NaN.
-
- * generic/tclStrToD.c (RefineResult): Added a test for the initial
- approximation being HUGE_VAL; this test avoids EDOM being returned from
- ldexp on some platforms on input values exceeding the floating point
- range.
-
- * tests/expr.test (expr-29.*, expr-30.*): Added further tests of
- overflow/underflow on input conversions.
-
-2005-04-25 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- [kennykb-numerics-branch] Merged with HEAD.
-
- * doc/CrtMathFunc.n: Revised documentation for TIP 232
-
-2005-04-25 Daniel Steffen <das@users.sourceforge.net>
-
- * compat/string.h: fixed memchr() protoype for __APPLE__ so that we
- build on Mac OS X 10.1 again.
-
- * generic/tclNotify.c (TclFinalizeNotifier): fixed notifier not being
- finalized in unthreaded core (was testing for notifier initialization
- in current thread by checking thread id != 0 but thread id is always 0
- in untreaded core).
-
- * win/tclWinNotify.c (Tcl_WaitForEvent):
- * unix/tclUnixNotfy.c (Tcl_WaitForEvent): don't call ScaleTimeProc for
- zero wait times (as specified in TIP 233).
-
- * unix/Makefile.in: added @PLAT_SRCS@ to SRCS and split out NOTIFY_SRCS
- from UNIX_SRCS for parity with UNIX_OBJS & NOTIFY_OBJS.
-
- * unix/tcl.m4 (Darwin): added configure checks for recently added
- linker flags -single_module and -search_paths_first to allow building
- with older tools (and on Mac OS X 10.1), use -single_module in SHLIB_LD
- and not just T{CL,K}_SHLIB_LD_EXTRAS, added unexporting from Tk of
- symbols from libtclstub to avoid duplicate symbol warnings, added
- PLAT_SRCS definition for Mac OS X, defined MODULE_SCOPE to
- __private_extern__.
- (SC_MISSING_POSIX_HEADERS): added caching of dirent.h check.
-
- * unix/configure: autoconf-2.59
-
-2005-04-25 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * library/tzdata/America/Boise:
- * library/tzdata/America/Chicago:
- * library/tzdata/America/Denver
- * library/tzdata/America/Indianapolis:
- * library/tzdata/America/Los_Angeles:
- * library/tzdata/America/Louisville:
- * library/tzdata/America/Managua:
- * library/tzdata/America/New_York:
- * library/tzdata/America/Phoenix:
- * library/tzdata/America/Port-au-Prince:
- * library/tzdata/America/Indiana/Knox:
- * library/tzdata/America/Indiana/Marengo:
- * library/tzdata/America/Indiana/Vevay:
- * library/tzdata/America/Kentucky/Monticello:
- * library/tzdata/America/North_Dakota/Center:
- * library/tzdata/Asia/Tehran:
- Olson's tzdata2005i. Corrects exact time at which Standard Time was
- adopted in the US (generally, noon, Standard Time, rather than noon,
- Local Mean Time). Adopts new civil rules for Nicaragua and Iran.
-
-2005-04-25 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl: Use "ni" and "in" operators.
-
-2005-04-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: fix for [Bug 1189274].
-
-2005-04-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclLiteral.c: Silence compiler warnings.
- * generic/tclObj.c: [Bug 1188863].
-
-2005-04-22 Don Porter <dgp@users.sourceforge.net>
-
- The 2005-04-21 changes to Tcl_GetBooleanFromObj were done to bring it
- into agreement with its docs. Further investigation reveals it was the
- docs that were incorrect.
-
- * doc/BoolObj.3: Corrections to the documentation of
- Tcl_GetBooleanFromObj to bring it into agreement with what this public
- interface has always done, including noting the difference in function
- between Tcl_GetBooleanFromObj and Tcl_GetBoolean.
-
- * generic/tclGet.c: Revised Tcl_GetBoolean to no longer be a
- wrapper around Tcl_GetBooleanFromObj (different function!).
-
- * generic/tclObj.c: Removed TclGetTruthValueFromObj routine that
- was added yesterday. Revisions so that only Tcl_GetBoolean-approved
- values get the "boolean" Tcl_ObjType. This retains the fix for [Bug
- 1187123].
- * tests/string.test: Test string-23.0 for Bug 1187123.
-
- * generic/tclInt.h: Revert most recent change.
- * generic/tclBasic.c:
- * generic/tclCompCmds.c:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * tests/obj.test:
-
-2005-04-21 Don Porter <dgp@users.sourceforge.net>
-
- * doc/GetInt.3: Convert argument "string" to "str" to agree with code.
- Also clarified a few details on int and double formats.
- * generic/tclGet.c: Radical code simplification. Converted
- Tcl_GetFoo() routines into wrappers around Tcl_GetFooFromObj(). Reduces
- code duplication, and the resulting potential for inconsistency.
-
- * generic/tclObj.c: Several changes:
-
- - Re-ordered error detection code so all values with trailing garbage
- receive a "not an integer" message instead of an "integer too large"
- message.
- - Removed inactive code meant to deal with strtoul* routines that fail
- to parse leading signs. All of them do, and if any are detected that
- do not, the correct fix is replacement with compat/strtoul*.c, not a
- lot of special care by the callers.
- - Tcl_GetDoubleFromObj now avoids shimmering away a "wideInt" intrep.
- - Fixed Tcl_GetBooleanFromObj to agree with its documentation and with
- Tcl_GetBoolean, accepting only "0" and "1" and not other numeric
- strings. [Bug 1187123]
- - Added new private routine TclGetTruthValueFromObj to perform the more
- permissive conversion of numeric values to boolean that is needed by
- the [expr] machinery.
-
- * generic/tclInt.h (TclGetTruthValueFromObj): New routine.
- * generic/tclExecute.c: Updated callers to call new routine.
- * generic/tclBasic.c: Updated callers to call new routine.
- * generic/tclCompCmds.c: Updated callers to call new routine.
- * generic/tclDictObj.c: Updated callers to call new routine.
- * tests/obj.test: Corrected bad tests that actually expected
- values like "47" and "0xAC" to be accepted as booleans.
-
- * generic/tclLiteral.c: Disabled the code that forces some literals
- into the "int" Tcl_ObjType during registration. We can re-enable it if
- this change causes trouble, but it seems more sensible to let Tcl's
- "on-demand" shimmering rule, and not try to pre-guess things.
-
-2005-04-20 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
- * doc/expr.n:
- * doc/mathfunc.n (new file): Revised documentation for TIP 232
-
-2005-04-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclGet.c (Tcl_GetInt): Corrected error that did not
- * generic/tclObj.c (Tcl_GetIntFromObj): permit 0x80000000 to be
- recognized as an integer on TCL_WIDE_INT_IS_LONG systems [Bug 1090869].
-
-2005-04-20 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclFileName.c: Silenced a compiler warning about '/*' within
- a comment.
-
-2005-04-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Added unsupported command
- * generic/tclCmdAH.c: [::tcl::unsupported::EncodingDirs] to permit
- * generic/tclInt.h: query/set of the encoding search path at
- * generic/tclInterp.c: the script level. Updated init.tcl to make
- * library/init.tcl: use of the new command. Also updated several
- coding practices in init.tcl ("eq" for [string equal], etc.)
-
-2005-04-19 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (Initialize): Put initialization code into a proc
- to avoid inadvertently clobbering global variables. [Bug 1185933]
- * tests/clock.test (clock-48.1): Added regression test for the above
- bug.
- Thanks to Ulrich Ring for reporting this bug.
-
-2005-04-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/Var.c (Tcl_ArrayObjCmd - ARRAY_NAMES): fix Tcl_Obj leak. [Bug
- 1084111]
-
-2005-04-16 Zoran Vasiljevic <vasiljevic@users.sf.net>
-
- * generic/tclIOUtil.c: force clenaup of the interp result in
- TclLoadFile(). Some implementations of TclpFindSymbol() will seed the
- interp result with error message when unable to find the requested
- symbol (this is not considered to be an error).
-
- Set of changes correcting huge memory waste (not a leak) when a thread
- exits. This has been introduced in 8.4.7 within an attempt to correctly
- cleanup after ourselves when Tcl library is being unloaded with the
- Tcl_Finalize() call.
-
- This fixes the [Bug 1178445]
-
- * generic/tclInt.h: added prototypes for TclpFreeAllocCache() and
- TclFreeAllocCache()
-
- * generic/tclThreadAlloc.c: modified TclFinalizeThreadAlloc() to
- explicitly call TclpFreeAllocCache with the NULL-ptr as argument
- signalling cleanup of private tsd key used only by the threading
- allocator.
-
- * unix/tclUnixThrd.c: fixed TclpFreeAllocCache() to recognize when
- being called with NULL argument. This is a signal for it to clean up
- the tsd key associated with the threading allocator.
-
- * win/tclWinThrd.c: renamed TclWinFreeAllocCache to TclpFreeAllocCache
- and fixed to recognize when being called with NULL argument. This is a
- signal for it to clean up the tsd key associated with the threading
- allocator.
-
-2005-04-13 Don Porter <dgp@users.sourceforge.net>
-
- * tests/unixInit.test: Disabled obsolete tests and removed code
- * tests/encoding.test: that supported them.
- * generic/tclInterp.c:
-
- * library/init.tcl: Use auto-loading to bring in Tcl Module support
- * library/tclIndex: as needed. This reduces startup time by
- * library/tm.tcl: delaying this initialization to a later time.
-
-2005-04-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: missing semicolons caused failure to compile
- with TCL_COMPILE_DEBUG.
-
-2005-04-13 David Gravereaux <davygrvy@pobox.com>
-
- * generic/tclIO.c (Tcl_SetChannelBufferSize): Lowest size limit
- * tests/io.test: changed from ten bytes to one byte. Need for
- * tests/iogt.test: this change was proven by Ross Cartlidge
- <rossc@cisco.com> where [read stdin 1] was grabbing 10 bytes followed
- by starting a child process that was intended to continue reading from
- stdin. Even with -buffersize set to one, nine chars were getting lost
- by the buffersize over reading for the native read() caused by [read].
-
-2005-04-13 Don Porter <dgp@users.sourceforge.net>
-
- * unix/tclUnixInit.c (TclpGetEncodingNameFromEnvironment): Reversed
- order of verifying candidate [encoding system] value, checking against
- a table in memory first before calling Tcl_GetEncoding and potentially
- scanning through the filesystem. Also ordered the table so that a
- binary search could be used within it. Improves startup time a bit more
- on some systems.
-
-2005-04-13 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.n: Added a missing '--' on several [switch] commands to
- improve performance of [clock format] and related operations. [FRQ
- 1182459]
-
-2005-04-13 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/fcopy.n: Improved documentation on copying binary files, added an
- example and mentioned the use of [file copy].
- * doc/fconfigure.n: Improved documentation of -encoding binary option.
- This is all following comments from Steve Manning <steve@manning.net>
- on comp.lang.tcl that the current documentation was not clear.
-
-2005-04-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c:Commented out the functions
- TclPrintInstruction(), TclPrintObject() and TclPrintSource() when not
- debugging the compiler, as they are never called in that case.
-
-2005-04-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c: Corrected bad syntax of Tcl_Panic() call.
-
- * generic/tclUtil.c (TclGetProcessGlobalValue): More robust handling
- of bad TclInitProcessGlobalValueProc behavior; an immediate panic
- rather than a mysterious crash later.
-
- * generic/tclEncoding.c: Several changes to the way the
- encodingFileMap cache is maintained. Previously, it was attempted to
- keep the file map filled and up to date with changes in the encoding
- search path. This contributed to slow startup times since it required
- an expensive "glob" operation to fill the cache. Now the validity of
- items in the cache are checked at the time they are used, so the cache
- is permitted to fall out of sync with the encoding search path. Only
- [encoding names] and Tcl_GetEncodingNames() now pay the full expense.
- [Bug 1177363]
-
-2005-04-12 Kevin B. Kenny <kennykb@acm.org>
-
- * compat/strstr.c: Added default definition of NULL to accommodate
- building on systems with badly broken headers. [Bug 1175161]
-
-2005-04-11 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tools/tclZIC.tcl: Rewrote to take advantage of more features of Tcl
- 8.5 (on which it was dependent anyway). Also added a [package require]
- line to formalize the relationship.
-
-2005-04-11 Kevin Kenny <kennykb@users.sf.net>
-
- [kennykb-numerics-branch] Merged with HEAD. Updated to libtommath 0.35.
-
- * generic/tclBasic.c: Attempted to repeat changes that applied to
- tclExecute.c in Miguel Sofer's commit of 2005-04-01, together with
- (possibly) a few more uses of his new object creation macros. Also
- plugged a memory leak in TclObjInvoke. [Bug 1180368]
-
-2005-04-10 Kevin Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Montevideo:
- * library/tzdata/Asia/Almaty:
- * library/tzdata/Asia/Aqtau:
- * library/tzdata/Asia/Aqtobe:
- * library/tzdata/Asia/Baku:
- * library/tzdata/Asia/Jerusalem:
- * library/tzdata/Asia/Oral:
- * library/tzdata/Asia/Qyzylorda:
- * library/tzdata/Indian/Chagos:
- * library/tzdata/Indian/Cocos: Olson's tzdata2005h
-
-2005-04-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclObjInvoke): Plug memory leak. [Bug 1180368]
-
-2005-04-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: fix possible leak of expansion Tcl_Objs
-
-2005-04-09 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/README: updated requirements for OS & developer tool versions
- and other small fixes/cleanup.
-
- * generic/tclListObj.c (Tcl_ListObjIndex): added missing NULL return
- when getting index from an empty list.
-
- * unix/tcl.m4 (Darwin): added -single_module linker flag to
- TCL_SHLIB_LD_EXTRAS and TK_SHLIB_LD_EXTRAS.
- * unix/configure: autoconf-2.59
-
-2005-04-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h (TclGetEncodingFromObj): New function to
- * generic/tclEncoding.c (TclGetEncodingFromObj): retrieve a
- Tcl_Encoding value, as well as cache it in the internal rep of a new
- "encoding" Tcl_ObjType.
- * generic/tclCmdAH.c (Tcl_EncodingObjCmd): Updated to call new
- function so that Tcl_Encoding's used by [encoding convert*] routines
- are not freed too quickly. [Bug 1077262]
-
-2005-04-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Rewritten to be able to
- handle the other form of [switch] and generate slightly simpler (but
- longer) code.
-
-2005-04-06 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/upvar.n, doc/unset.n, doc/tell.n, doc/tclvars.n, doc/subst.n:
- * doc/seek.n, doc/scan.n, doc/regsub.n, doc/registry.n, doc/regexp.n:
- * doc/read.n, doc/puts.n, doc/pkgMkIndex.n, doc/open.n, doc/lreplace.n:
- * doc/lrange.n, doc/load.n, doc/llength.n, doc/linsert.n, doc/lindex.n:
- * doc/lappend.n, doc/info.n, doc/gets.n, doc/format.n, doc/flush.n:
- * doc/fileevent.n, doc/file.n, doc/fblocked.n, doc/close.n:
- * doc/array.n, doc/Utf.3, doc/TraceVar.3, doc/StrMatch.3, doc/RegExp.3:
- * doc/PrintDbl.3, doc/OpenTcp.3, doc/OpenFileChnl.3, doc/Object.3:
- * doc/Notifier.3, doc/LinkVar.3, doc/IntObj.3, doc/Interp.3:
- * doc/GetOpnFl.3, doc/GetIndex.3, doc/Eval.3, doc/CrtMathFnc.3:
- * doc/CrtFileHdlr.3, doc/CrtCommand.3, doc/CrtChannel.3:
- * doc/Backslash.3: Purge old .VS/.VE macro instances.
-
- * tools/man2html2.tcl (IPmacro): Rewrote to understand what .IP really
- is (.IP and .TP are really just two ways of doing the same thing).
- Change below made this relevant.
- * doc/re_syntax.n: Change some uses of .TP to .IP to work around bugs
- in various *roff implementations. Also reworded the atom descriptions
- slightly.
-
-2005-04-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (ExprSrandFunc): Replaced incursions into the
- * generic/tclUtil.c (TclGetIntForIndex): intreps of numeric types with
- simpler calls of Tcl_GetIntFromObj and Tcl_GetLongFromObj, now that
- those routines are better behaved wrt shimmering. [Patch 1177219]
-
-2005-04-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclObj.c: Change in TclDecrRefCount and TclFreeObj, to speed
- up the freeing of simple Tcl_Obj [Patch 1174551]
-
-2005-04-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: small opts in obj handling
-
-2005-04-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: converted a few function calls to macros.
-
-2005-04-01 Miguel Sofer <msofer@users.sf.net>
-
- * doc/ListObj.3:
- * generic/tclBasic.c:
- * generic/tclCmdIL.c:
- * generic/tclConfig.c:
- * generic/tclExecute.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclListObj.c:
- * generic/tclStubInit.c:
- * generic/tclVar.c: Changed the internal representation of lists to
- (a) reduce the malloc/free calls at list creation (from 2 to 1), (b)
- reduce the cost of handling empty lists (we now never create a list
- internal rep for them), (c) allow refcounting of the list internal rep.
- The latter permits insuring that the pointers returned by
- Tcl_ListObjGetElements remain valid even if the object shimmers away
- from its original list type. This is [Patch 1158008]
-
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * generic/tclStringObj.c:
- (1) defined new internal macros for creating and setting frequently
- used obj types (int,long, wideInt, double, string). Changed TEBC to use
- eg 'TclNewIntObj(objPtr, i)' to avoid the function call in 'objPtr =
- Tcl_NewIntObj(i)'
- (2) ExecEnv now stores two Tcl_Obj* pointing to the constants "0" and
- "1", for use by TEBC.
- (3) slight reduction in cost of INST_START_CMD
-
-2005-03-31 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_JUMP_TRUE/FALSE): replaced "test and
- branch" with "compute index into table"
-
-2005-03-30 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/FileSystem.3: Defined loadHandle argument. [Bug 1172401]
-
-2005-03-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tcl.m4, win/configure: do not require cygpath in macros to allow
- msys alone as an alternative.
-
-2005-03-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.h: Move the TclInterpReady() declaration from
- * generic/tclInt.h: tclCompile.h to tclInt.h. Should have been done
- as part of the 1115904 bug fix on 2005-03-18.
-
- * generic/tclThreadTest.c: Stop providing the phony package
- "Thread 1.0" when the [::testthread] command is defined. It's never
- used by anything, and conflicts with loading the real "Thread" package.
-
-2005-03-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks for
- immediate operand usage to permit leading space and sign characters.
- Restores more efficient bytecode for [incr x -1] that got lost in the
- CONST string reforms of Tcl 8.4. [Bug 1165671]
-
- * generic/tclBasic.c (Tcl_EvalEx): Restored recursion limit
- * generic/tclParse.c (TclSubstTokens): testing in nested command
- * tests/basic.test (basic-46.4): substitutions within direct
- * tests/parse.test (parse-19.*): script evaluation (Tcl_EvalEx)
- that got lost in the parser reforms of Tcl 8.1. Added tests for correct
- behavior. [Bug 1115904]
-
-2005-03-15 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c:
- * win/tclWinFile.c:
- * tests/winFCMd.test: fix to 'file pathtype' and 'file norm' failures
- on reserved filenames like 'COM1:', etc.
-
-2005-03-15 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * unix/tcl.m4: Updated the OpenBSD configuration and regenerated
- * unix/configure: the configure script.
-
-2005-03-15 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged with HEAD.
-
- * generic/tclBasic.c (many):
- * generic/tclCompExpr.c (CompileMathFuncCall):
- * generic/tclCompile.h:
- * generic/tclExecute.c (many):
- * generic/tclParseExpr.c (ParsePrimaryExpr):
- * tests/compExpr-old.test:
- * tests/compExpr.test:
- * tests/compile.test:
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/for.test:
- * tests/parseExpr.test: Initial implementation of TIP #232.
-
- * generic/tclObj.c (Tcl_DbNewBignumObj): Fixed typo that broke
- --enable-symbols=mem build
- * tests/binary.test (binary-40.3, binary-40.6): Corrected tests to
- allow NaN(7ffffffffffff).
-
-2005-03-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: fixed INST_PUSH1's debugging code (wrong obj
- ref passed to TRACE_WITH_OBJ).
-
-2005-03-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: fixed INST_RETURN's stack effect in
- tclInstructionTable (-1 instead of -2)
-
-2005-03-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c: removed debugging line
-
-2005-03-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c (TclCheckInterpTraces): Corrected mistaken cast
- of ClientData to (TraceCommandInfo *) when not warranted. Thanks to
- Yuri Victorovich for the report. [Bug 1153871]
- * generic/tcl.h: Moved flag values TCL_TRACE_ENTER_EXEC and
- * generic/tclInt.h: TCL_TRACE_LEAVE_EXEC from public interface into
- private. Should be used only by internal workings of execution traces.
-
-2005-03-09 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged from HEAD.
-
- * doc/PrintDbl.3:
- * doc/tclVars.n: Documented new semantics for tcl_precision.
- * generic/tclExecute.c (Tcl_ExecuteByteCode): Removed the check for
- division-by-zero on IEEE-754 machines.
- * generic/tclUtil.c (Tcl_PrintDouble): Corrected bug where numbers in
- the range [1e-4 .. 1.) were printed incorrectly.
- * tests/compExpr-old.test (compExpr-old-11.13): Revised test case for
- division by zero.
- * tests/expr-old.test (expr-34.11, expr-34.12): Revised test cases for
- overflow in pow() to deal with infinities.
- * tests/expr.test (expr-11.13, expr-29.1, expr-29.2): Revised test case
- for division by zero and for underflow on input conversions.
- * tests/parseExpr.test (parseExpr-16.11): Revised test case for
- overflow on input conversion.
- * tests/string.test (string-6.38 deleted): Removed test case for
- underflow on input conversion, which is no longer an error.
- * tests/util.test (util-10.*): Added test case for the bug in tclUtil.c
-
-2005-03-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/makefile.vc: clarify necessary defined vars that can come from
- MSVC or the Platform SDK.
-
-2005-03-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/string.n: Minor typo. [Bug 1158247]
-
-2005-03-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: new peephole optimisation for INST_PUSH1; fixed
- the peephole opt in INST_POP so that it is not used when
- TCL_COMPILE_DEBUG is defined.
-
-2005-03-04 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
-
- * generic/tclCmdMZ.c: Changed [scan] to treat out-of-range floating
- point values as infinities and zeroes.
- * generic/tclExecute.c: Changed [expr] to be permissive about
- infinities, allowing them to propagate.
- * generic/tclGet.c: Changed Tcl_GetDouble to be permissive about
- over/underflow.
- * generic/tclObj.c: Changed SetDoubleFromAny to be permissive about
- over/underflow.
- * generic/tclParseExpr.c: Made [expr] permissive about input numbers
- out of range.
-
-2005-03-03 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
-
- * generic/tclInt.h:
- * generic/tclStrToD.c (Tcl_DoubleDigits, TclFormatNaN):
- * generic/tclUtil.c (Tcl_PrintDouble): Changed the signature of
- TclDoubleDigits so that it accepts a pointer to the signum of the
- argument, and returns the signum via that pointer. Added very hacky
- code to handle IEEE signed zeroes in Tcl_DoubleDigits. (It can't be
- done other than as a hack until C9x; C89 simply doesn't deal with the
- concept of -0.0). Added output conversion of tagged NaN values.
- * generic/tclBinary.c (FormatNumber): Changed to allow [binary format]
- to handle NaN.
- * tests/binary.test (binary-60.1): Added a quick-n-dirty test to make
- sure that NaN's can be scanned and formatted.
- * generic/tclParseExpr.c (GetLexeme, ParseMaxDoubleLength): Modified so
- that tagged NaN (e.g., NaN(DEADBEEF)) can be recognized.
-
-2005-03-02 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged with HEAD as of 2005-02-23.
-
- * generic/tclExecute.c: Broadened test for NaN to work on Windows.
- * generic/tclInt.h:
- * generic/tclStrToD.c (Tcl_DoubleDigits):
- * generic/tclUtil.c (Tcl_PrintDouble, TclPrecTraceProc): Added
- Tcl_DoubleDigits to format 'double' numbers with the minimum number of
- significant digits to yield correct rounding. Modified tcl_precision
- to accept 0 as a precision (meaning "minimum digits"), and made 0 the
- default. [TIP #132]
- * generic/tclObj.c: Made NaN's throw an error in Tcl_GetDoubleFromObj.
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: Added libtommath/bn_mp_init_set.c to the build.
- * libtommath/tommath.h (mp_iseven): Fixed a bug that caused zero to
- test 'odd'.
- * generic/tommath.h: Regenerated.
- * tests/binary.test:
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/scan.test: Corrected a number of tests that depended on
- tcl_precision, and removed the {eformat} condition from tests that no
- longer require it.
- * tests/util.test: Corrected a number of tests that depended on
- tcl_precision, and removed the {eformat} condition from tests that no
- longer require it. Added a series of tests for correct rounding in
- Tcl_PrintDouble. [TIP #132].
-
-2005-03-01 David N. Welton <davidw@dedasys.com>
-
- * doc/CrtSlave.3: Changed to Tcl_Object to Tcl_Obj in the man page.
-
-2005-02-24 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Better use of [glob -types] to avoid
- * tests/tcltest.test: failed attempts to [source] a directory, and
- similar matters. Thanks to "mpettigr". [Bug 1119798]
-
- * library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.8
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2005-02-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/CrtChannel.3 (THREADACTIONPROC): Formatting fix. [Bug 1149605]
-
-2005-02-17 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinFCmd.c (TraverseWinTree): use wcslen on wchar, not
- Tcl_UniCharLen.
-
-2005-02-16 Miguel Sofer <msofer@users.sf.net>
-
- * doc/variable.n: fix for [Bug 1124160], variables are detected by
- [info vars] but not by [info locals].
-
-2005-02-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in: remove SHLIB_LD_FLAGS (only for AIX, inlined into
- * unix/tcl.m4: SHLIB_LD). Combine AIX-* and AIX-5 branches in
- * unix/configure: SC_CONFIG_CFLAGS. Correct gcc builds for AIX-4+
- and HP-UX-11. autoconf-2.59 gen'd.
-
-2005-02-11 Miguel Sofer <msofer@users.sf.net>
-
- * tests/basic.test (basic-26.3): new test
-
-2005-02-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (Tcl_EvalObjEx):
- * tests/basic.test (basic-26.2): preserve the arguments passed to TEOV
- in the pure-list branch, in case the list shimmers away. Fix for [Bug
- 1119369], reported by Peter MacDonald.
-
-2005-02-10 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: fix for test failures introduced on 2005-01-17
- [Bug 1119092]
-
-2005-02-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/binary.n: Made the documentation of sign bit masking and [binary
- scan] consistent. [Bug 1117017]
-
-2005-02-08 David N. Welton <davidw@dedasys.com>
-
- * doc/CrtChannel.3: Typo: return->returns.
-
-2005-02-06 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
-
- * generic/tclStrToD.c (TclStrToD, SafeLdExp): Added code to manage the
- FPU precision on gcc+x86. Enabled fast conversion of floats with small
- exponents now that precision is correct.
- * tests/expr.test: Corrected test for the smallest representible value
- to the right IEEE values.
-
-2005-02-06 David N. Welton <davidw@dedasys.com>
-
- * doc/Thread.3: One-word grammar fix.
-
-2005-02-05 David N. Welton <davidw@dedasys.com>
-
- * doc/Thread.3: Fixed sentence describing flags for Tcl_CreateThread.
-
- * doc/FileSystem.3: Cleaned up typo in Tcl_FSNewNativePath
- documentation.
-
- * generic/tclPathObj.c: Cleaned up typo in comment.
-
-2005-02-03 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
-
- * generic/tclStrToD.c (TclStrToD, RefineResult, SafeLdExp): Added code
- to ensure that 'ldexp' is never called with a value that will underflow
- * tests/expr.test: Added tests for the smallest representible value,
- and rounding between it and zero. (The tests reflect current
- behaviour; plan is to change the specification of Tcl so that input
- conversion of doubles underflows silently.)
-
-2005-02-02 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclProc.c (TclInitCompiledLocals): Add check for type of the
- framePtr->procPtr->bodyPtr passed to TclInitCompiledLocals and panic if
- it is not the correct type. If the body of the proc is not of the
- compiled byte code type then the code will crash. This was discovered
- while tracking down a crash in Itcl, that crash is fixed by Itcl patch
- 1115085.
-
-2005-02-01 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Merged with HEAD as of today.
-
- * generic/tclInt.decls: Changed numbers of new stubs to resolve a
- conflict.
- * generic/tclInt.h: Added new TclStrToD routine that replaces the
- native 'strtod' throughout Tcl.
- * generic/tclCmdMZ (Tcl_StringObjCmd):
- * generic/tclGet.c (Tcl_GetDouble):
- * generic/tclObj.c (SetBooleanFromAny, SetDoubleFromAny):
- * generic/tclParseExpr.c (GetLexeme):
- * generic/tclScan.c (Tcl_ScanObjCmd): Replaced all uses of the native
- 'strtod' with a TclStrToD routine that performs correct rounding and
- handles denormals.
- * generic/tclStrToD.c: (new file)
- New scanning function for extracting 'double' from a string that rounds
- correctly, and handles denormals and infinities.
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc:
- Added tclStrToD.c and the tommath routines that support it.
-
- These changes represent a partial implementation of TIP #132. Output
- conversion of floating point numbers, and proper handling of infinities
- within expressions, still need to be addressed.
-
-2005-02-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (TclCompEvalObj): Removed stray statement left
- behind in prior code reorganization.
-
-2005-01-31 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure: autoconf-2.57
-
-2005-01-30 Joe English <jenglish@users.sourceforge.net>
-
- * unix/configure.in: Restored two double-evals that were removed in the
- DBGX purge; these are still needed on some platforms to account for
- TCL_TRIM_DOTS. [Bug 1112654]
-
- * unix/configure: NOT REGENERATED: only have autoconf 2.59 here, need
- to find someone with autoconf 2.57.
-
-2005-01-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/configure, unix/tcl.m4: add solaris 64-bit gcc build support.
- [Bug 1021871]
-
-2005-01-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/expr-old.test (expr-old-37.2): Added test for [Bug 1109484]
-
-2005-01-27 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble)
- (Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484]
-
-2005-01-26 Andreas Kupries <andreask@activestate.com>
-
- TIP#218 IMPLEMENTATION
-
- * generic/tclDecls.h: Regenerated from tcl.decls.
- * generic/tclStubInit.c:
-
- * doc/CrtChannel.3: Documentation of extended API,
- * generic/tcl.decls: extended testsuite, and
- * generic/tcl.h: implementation. Removal of old
- * generic/tclIO.c: driver-specific TclpCut/Splice
- * generic/tclInt.h: functions. Replaced with generic
- * tests/io.test: thread-action calls through the
- * unix/tclUnixChan.c: new hooks. Update of all builtin
- * unix/tclUnixPipe.c: channel drivers to version 4.
- * unix/tclUnixSock.c: Windows drivers extended to
- * win/tclWinChan.c: manage thread state in a thread
- * win/tclWinConsole.c: action handler.
- * win/tclWinPipe.c:
- * win/tclWinSerial.c:
- * win/tclWinSock.c:
-
-2005-01-25 Don Porter <dgp@users.sourceforge.net>
-
- * library/auto.tcl: Updated [auto_reset] to clear auto-loaded
- commands in namespaces other than :: and to clear auto-loaded commands
- that do not happen to be procs. [Bug 1101670]
- ***POTENTIAL INCOMPATIBILITY***
-
-2005-01-25 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4 (Darwin): fixed bug with static build linking to dynamic
- library in /usr/lib etc instead of linking to static library earlier in
- search path. [Bug 956908] Removed obsolete references to Rhapsody.
- * unix/configure: autoconf-2.57
-
-2005-01-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclStubInit.c: Regenerated the stubs support code from the
- * generic/tclDecls.h: modified tcl.decls (TIP #233, see below).
-
- * doc/GetTime.3: Implemented TIP #233, i.e. the
- * generic/tcl.decls: 'Virtualization of Tcl's Sense of Time'.
- * generic/tcl.h: Declared, implemented, and documented the
- * generic/tclInt.h: specified new API functions. Moved the
- * unix/tclUnixEvent.c: native (OS) access to time information
- * unix/tclUnixNotfy.c: into standard handler functions. Inserted
- * unix/tclUnixTime.c: hooks calling on the handlers where native
- * win/tclWinNotify.c: access was done before, and where scaling
- * win/tclWinTime.c: between domains (real/virtual) is required.
-
-2005-01-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclThread.c: Typo police. Fixed some nits
- * generic/tclCmdAH.c: in header comments of functions.
- * generic/tclBasic.c: (Missing --).
- * generic/tclFileName.c:
-
-2005-01-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/FileSystem.3: Add missing ARGUMENTS section definitions for
- arguments to Tcl_FSLink. [Bug 1106272]
-
-2005-01-21 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch]
-
- * unix/Makefile.in: Updated Makefile to build libtommath on Unix as
- well as Windows. [Bug 1106865]
-
- * generic/tclTestObj.c (TestbignumobjCmd): Silenced a compiler warning
- about a mismatched 'const'.
-
-2005-01-20 Kevin B. Kenny <kennykb@acm.org>
-
- [kennykb-numerics-branch] Development checkpoint.
-
- * compat/strtoll.c: Reverted to HEAD.
- * compat/strtoull.c:
- * doc/Ensemble.3:
- * generic/tclBasic.c:
- * generic/tclCmdIL.c:
- * generic/tclNamesp.c:
- * generic/tclPathObj.c:
- * generic/tclPort.h:
- * unix/configure:
- * unix/configure.in:
- * unix/tcl.m4:
- * win/configure:
- * win/configure.in:
- * win/rules.vc:
- * win/tcl.m4:
-
- * generic/tcl.h: Added declarations for bignum types, and for a
- 'bignumValue' in the Tcl_Obj structure.
- * generic/tclInt.h: Added declarations of interface procedures for
- memory allocation in libtommath.
-
- * generic/tcl.decls: Added new interface to bignum objects.
- * generic/tclInt.decls: Added internal stubs for bignum routines used
- by the test code in tclTestObj.c.
-
- * generic/tclDecls/h: Regen.
- * generic/tclIntDecls.h:
- * generic/tclStubInit.h:
-
- * tools/fix_tommath_h.tcl: (New file) Script to edit
- libtommath/tommath.h and produce generic/tommath.h so that storage
- classes, allocation routines, and data types conform to Tcl's
- conventions.
- * generic/tommath.h: (New file) Generated by the above.
-
- * generic/tclTomMath.h: (New file) Additional declarations to be
- included in tommath.h when building Tcl.
-
- * generic/tclTomMathInterface.c: (New file) Small 'glue' routines
- adapting tommath's API to Tcl.
-
- * libtommath/bn_fast_s_mp_mul_digs.c:
- * libtommath/bn_mp_mul_d.c:
- * libtommath/bn_mp_read_radix.c:
- * libtommath/tommath.h: Applied suggested changes from Tom St Denis
- that correct an off-by-one error in single-digit multiplication
- (leading to a pointer smash if uncorrected) and change the string
- argument to 'mp_read_radix' from 'char*' to 'const char*'.
-
- * libtommath/bn_mp_radix_size.c: Local patch to ensure that sufficient
- memory is requested even if the number has a single digit.
-
- * libtommath/bn_mp_read_radix.c: Local patch to return MP_VAL if the
- input string contains an invalid character.
-
- * generic/tclObj.c: Added accessor functions for bignums.
- * generic/tclTestObj.c: Added a 'testbignumobj' command to exercise the
- accessor functions for bignums.
-
- * win/Makefile.in: Added rules for making libtommath.
-
-2005-01-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- TIP#235 IMPLEMENTATION
-
- * doc/Ensemble.3: Documentation for the new public API.
- * generic/tclNamesp.c (Tcl_CreateEnsemble,...): Rename of
- * generic/tcl.decls: existing API into TIPped form.
-
-2005-01-19 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/tclWinChan.c (FileCloseProc): Invoke TclpCutFileChannel() to
- remove a FileInfo from the thread local list before deallocating it.
- This should have been done via an earlier call to Tcl_CutChannel, but I
- was running into a crash in the next call to Tcl_CutChannel during the
- I/O finalization stage.
-
-2005-01-18 Kevin Kenny <kennykb@acm.org>
-
- * library/tzdata/GMT+0:
- * library/tzdata/GMT-0:
- * library/tzdata/GMT0:
- * library/tzdata/Greenwich:
- * library/tzdata/Navajo:
- * library/tzdata/Universal:
- * library/tzdata/Zulu:
- * library/tzdata/America/Asuncion:
- * library/tzdata/America/Rosario:
- * library/tzdata/Asia/Jerusalem:
- * library/tzdata/Brazil/Acre:
- Routine update per Olson's tzdata2005c. Removed links to links
- (Greenwich in several aliases; Navajo; Acre). Updated Paraguayan DST
- rules and "best guess" at this year's Israeli rules.
-
-2005-01-17 Vince Darley <vincentdarley@users.sourceforge.net>
-
- * generic/tclFileName.c: fix for glob failure on Windows shares [Bug
- 1100542].
-
- * doc/pkgMkIndex.n: added documentation that 'pkg_mkIndex -lazy' is not
- a good idea. [Bug 1101678]
-
-2005-01-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tests/compile.test (compile-17.1): Document known issue with binding
- time of compiled command interpretations in [expr].
-
- * generic/tclIOUtil.c (TclFSFileAttrIndex): New helper function so that
- we don't need to hard-code attribute indexes. [Bug 1100671]
-
-2005-01-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/string.n: Removed the term 'set' from the documentation of the
- [string trim] commands, as it caused confusion.
-
-2005-01-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tcl.m4 (SC_PATH_{TCL,TK}CONFIG): Added code to detect the case
- when the --with-tcl/--with-tk arguments point to the config scripts
- themselves and not their directory. If this is the case, they now
- complain but keep working. [FRQ 951247]
- * unix/configure: autoconf-2.57
-
-2005-01-10 Joe English <jenglish@users.sourceforge.net>
-
- * unix/Makefile.in, unix/configure.in, unix/tcl.m4,
- * unix/tclConfig.sh.in, unix/dltest/Makefile.in:
- Remove ${DBGX}, ${TCL_DBGX} from Tcl build system [Patch 1081595].
- * unix/configure: regenerated
-
-2005-01-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixFCmd.c (TclUnixCopyFile): Convert u_int to unsigned to
- make clashes with types in standard C headers less of a problem. [Bug
- 1098829]
-
-2005-01-09 Joe English <jenglish@users.sourceforge.net>
-
- * unix/tclUnixThrd.c, unix/tclUnixPort.h: Remove readdir_r() and
- related #ifdeffery (see [Bug 1095909]).
- * unix/tcl.m4, unix/tclConfig.h.in: Don't check for HAVE_READDIR_R.
- * unix/configure: Regenerated.
-
-2005-01-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * library/http/http.tcl (http::mapReply): Significant performance
- enhancement by using [string map] instead of [regsub]/[subst], and
- update version requirement to Tcl8.4. [Bug 1020491]
-
-2005-01-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/lsearch.n, doc/re_syntax.n: Convert to other form of emacs mode
- control comment to prevent problems with old versions of man. [Bug
- 1085127]
-
-2005-01-05 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/winDde.test: Fixed broken test result.
-
-2005-01-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInt.h, generic/tclPort.h: Move the #include of tclConfig.h
- *first* before any reference to tcl.h so that the build configuration
- is loaded before the first reference to any system headers. Issue
- reported by Art Haas on tcl-core.
-
-2005-01-04 Don Porter <dgp@users.sourceforge.net>
-
- * tests/fCmd.test (fCmd-18.10): Added notNetworkFilesystem constraint.
- [Bug 456665]
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" ***
- *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2007 b/ChangeLog.2007
deleted file mode 100644
index 404bc4d..0000000
--- a/ChangeLog.2007
+++ /dev/null
@@ -1,5921 +0,0 @@
-2007-12-31 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: Clarified meaning of dictionary values following
- discussion on comp.lang.tcl.
-
-2007-12-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c: More [lsort] data handling streamlines. The
- function MergeSort is gone, essentially inlined into Tcl_LsortObjCmd.
- It is not a straight inlining, two loops over all lists elements where
- merged in the process: the linked list elements are now built and
- merged into the temporary sublists in the same pass.
-
-2007-12-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c: More [lsort] data handling streamlines. Extra
- mem reqs of latest patches removed, restored to previous mem profile.
- Improved -unique handling, now eliminating repeated elems immediately
- instead of marking them to avoid reinsertion at the end.
-
-2007-12-23 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c (TclCompileRegexpCmd): TCL_REG_NOSUB cannot
- * tests/regexp.test (regexp-22.2): be used because it
- * tests/regexpComp.test: [Bug 1857126] disallows backrefs.
-
-2007-12-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c: Speed patch for lsort. [Patch 1856994]
-
-2007-12-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd, Tcl_LsearchObjCmd): Avoid
- calling SelectObjFromSublist when there are no sublists.
-
-2007-12-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Preallocate a listObj of
- sufficient length for the sorted list instead of growing it. Second
- commit replaces calls to Tcl_ListObjAppenElement with direct access to
- the internal rep.
-
-2007-12-19 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5.0 TAGGED FOR RELEASE ***
-
- * changes: Updated for 8.5.0 release.
-
-2007-12-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): update switch -regexp
- * tests/switch.test-14.*: compilation to pass
- the cflags to INST_REGEXP (changed on 12-07). Added tests for switch
- -regexp compilation (need more). [Bug 1854399]
-
-2007-12-18 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.0 release.
-
-2007-12-18 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/regguts.h, generic/regc_color.c, generic/regc_nfa.c:
- Fixes for problems created when processing regular expressions that
- generate very large automata. An enormous number of thanks to Will
- Drewry <wad_at_google.com>, Tavis Ormandy <taviso_at_google.com>,
- and Tom Lane <tgl_at_sss.pgh.pa.us> from the Postgresql crowd for
- their help in tracking these problems down. [Bug 1810264]
-
-2007-12-17 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.0 release.
-
-2007-12-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclAlloc.c:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclThreadAlloc.c: Fix alignment for memory returned by
- TclStackAlloc; insure that all memory allocators align to 16-byte
- boundaries on 64 bit platforms [Bug 1851832, 1851524]
-
-2007-12-14 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIOUtil.c (FsAddMountsToGlobResult): fix the tail
- conversion of vfs mounts. [Bug 1602539]
-
- * win/README: updated notes
-
-2007-12-14 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/winFile.test: Fixed tests for win2k with long machine name
-
-2007-12-14 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/nmakehlp.c: Support compilation with MSVC9 for AMD64.
- * win/makefile.vc:
-
-2007-12-13 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/trace.n: Clarified documentation of enterstep and leavestep
- traces, including adding example. [Bug 614282, 1701540, 1755984]
-
-2007-12-12 Don Porter <dgp@users.sourceforge.net>
-
- * doc/IntObj.3: Update docs for the Tcl_GetBignumAndClearObj() ->
- Tcl_TakeBignumFromObj() revision [TIP 298]. Added docs for the
- Tcl_InitBignumFromDouble() routine. [Bug 1446971]
-
- * changes: Updated for 8.5.0 release.
-
-2007-12-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (TclReToGlob): reduce escapes in conversion
- when not necessary
-
- * generic/tclInt.decls: move TclByteArrayMatch and TclReToGlob
- * generic/tclIntDecls.h: to tclInt.h from stubs.
- * generic/tclStubInit.c: Add flags var to TclByteArrayMatch for
- * generic/tclInt.h: future extensibility
- * generic/tcl.h: define TCL_MATCH_EXACT doc for Tcl_StringCaseMatch.
- * doc/StrMatch.3: It is compatible with existing usage.
- * generic/tclExecute.c (INST_STR_MATCH): flag for TclByteArrayMatch
- * generic/tclUtil.c (TclByteArrayMatch, TclStringMatchObj):
- * generic/tclRegexp.c (Tcl_RegExpExecObj):
- * generic/tclCmdMZ.c (StringMatchCmd): Use TclStringMatchObj
- * tests/string.test (11.9.* 11.10.*): more tests
-
-2007-12-10 Joe English <jenglish@users.sourceforge.net>
-
- * doc/string.n, doc/UniCharIsAlpha.3: Fix markup errors.
- * doc/CrtCommand.3, doc/CrtMathFnc.3, doc/FileSystem.3,
- * doc/GetStdChan.3, doc/OpenFileChnl.3, doc/SetChanErr.3,
- * doc/eval.n, doc/filename.n: Consistency: Move "KEYWORDS" section
- after "SEE ALSO".
-
-2007-12-10 Daniel Steffen <das@users.sourceforge.net>
-
- * tools/genStubs.tcl: fix numerous issues handling 'macosx',
- 'aqua' or 'x11' entries interleaved
- with 'unix' entries [Bug 1834288]; add
- genStubs::export command
- [Tk FR 1716117]; cleanup formatting.
-
- * generic/tcl.decls: use new genstubs 'export' command to
- * generic/tclInt.decls: mark exported symbols not in stubs
- * generic/tclTomMath.decls: table [Tk FR 1716117]; cleanup
- formatting.
-
- * generic/tclDecls.h: regen with new genStubs.tcl.
- * generic/tclIntDecls.h: [Bug 1834288]
- * generic/tclIntPlatDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclStubInit.c:
-
-2007-12-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/io.test, tests/chanio.test (io-73.1): Make sure to invalidate
- * generic/tclIO.c (SetChannelFromAny): internal rep only after
- validating channel rep. [Bug 1847044]
-
-2007-12-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/expr.n, doc/mathop.n: Improved the documentation of the
- operators. [Bug 1823622]
-
- * generic/tclBasic.c (builtInCmds): Corrected list of hidden and
- * doc/interp.n (SAFE INTERPRETERS): exposed commands so that the
- documentation and reality now match. [Bug 1662436]
-
-2007-12-07 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclExecute.c (TclExecuteByteCode INST_REGEXP):
- * generic/tclCompCmds.c (TclCompileRegexpCmd): Pass correct RE
- compile flags at compile time, and use TCL_REG_NOSUB.
-
- * generic/tclIOCmd.c (FinalizeIOCmdTSD, Tcl_PutsObjCmd): cache
- stdout channel object for [puts $str] calls.
-
-2007-12-06 Don Porter <dgp@users.sourceforge.net>
-
- * README: Remove mention of dead comp.lang.tcl.announce
- newsgroup. [Bug 1846433]
-
- * unix/README: Mention the stub library created by `make` and warn
- about the effect of embedded paths in the installed binaries.
- Thanks to Larry Virden. [Bug 1794084]
-
- * doc/AddErrInfo.3: Documentation for the new routines in TIP 270.
- * doc/Interp.3:
- * doc/StringObj.3:
-
-2007-12-06 Don Porter <dgp@users.sourceforge.net>
-
- * doc/namespace.n: Documentation for zero-argument form of
- [namespace import] (TIP 261) [Bug 1596416]
-
-2007-12-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.h: add TclGetChannelFromObj decl
- (TclMatchIsTrivial): simplify TclMatchIsTrivial to remove ] check.
-
-2007-12-06 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
-
- * generic/tclBasic.c (Tcl_CreateInterp): Simplify the setting up of
- * generic/tclIOCmd.c (TclInitChanCmd): the [chan] ensemble. This
- * library/init.tcl: gets rid of quite a bit of
- code and makes it possible to understand the whole with less effort.
-
- * generic/tclCompCmds.c (TclCompileEnsemble): Ensure that the right
- number of tokens are copied. [Bug 1845320]
-
- * generic/tclNamesp.c (TclMakeEnsemble): Added missing release of a
- DString. [Bug 1845397]
-
-2007-12-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclIO.h: Create Tcl_Obj for Tcl channels to reduce
- * generic/tclIO.c: overhead in lookup by Tcl_GetChannel. New
- * generic/tclIOCmd.c: TclGetChannelFromObj for internal use.
- * generic/tclIO.c (WriteBytes, WriteChars): add opt check to avoid
- EOL translation when not linebuffered or using lf. [Bug 1845092]
-
-2007-12-05 Miguel Sofer <msofer@users.sf.net>
-
- * tests/stack.test: made the tests for stack overflow not care
- about which mechanism caused the error (interp's recursion limit
- or C-stack depth detector).
-
-2007-12-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure, win/tcl.m4 (LIBS_GUI): mingw needs -lole32
- -loleaut32 but not msvc for Tk's [send]. [Bug 1844749]
-
-2007-12-05 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Prevent shimmering crash
- when -exact and -integer/-real are mixed. [Bug 1844789]
-
-2007-12-03 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixChan.c (CreateSocketAddress): Add extra #ifdef-fery to
- make code compile on BSD 5. [Bug 1618235, again]
-
-2007-12-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Bump tcltest to version 2.3.0 so that
- * library/tcltest/pkgIndex.tcl: we release a stable tcltest with a
- * unix/Makefile.in: stable Tcl.
- * win/Makefile.in:
-
-2007-12-03 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/configure, win/tcl.m4 (LIBS_GUI): remove ole32.lib oleaut32.lib
-
-2007-12-03 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Adjusted the [switch]
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): command so that when
- passed two arguments, no check for options are performed. This is OK
- since in the two-arg case, detecting an option would definitely lead
- to a syntax error. [Patch 1836519]
-
-2007-11-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/makefile.vc: add ws2_32.lib to baselibs
- * win/configure, win/tcl.m4: add ws2_32.lib / -lws2_32 to build.
- * win/tclWinSock.c: remove dyn loading of winsock, assume that it is
- always available now.
-
-2007-11-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclWinSock.c (InitializeHostName): Correct error in
- buffer length tracking. After gethostname() writes into a buffer,
- convert only the written string to internal encoding, not the whole
- buffer.
-
-2007-11-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclConfig.c: Corrected failure of the [::foo::pkgconfig]
- command to clean up registered configuration data when the query
- command is deleted from the interp. [Bug 983501]
-
- * generic/tclNamesp.c (Tcl_SetEnsembleMappingDict): Added checks
- that the dict value passed in is in the format required to make the
- internals of ensembles work. [Bug 1436096]
-
- * generic/tclIO.c: Simplify test and improve accuracy of error
- message in latest changes.
-
-2007-11-28 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclIO.c: -eofchar must support no eofchar.
-
-2007-11-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: remove unneeded call in Tcl_CreateInterp, add
- comments.
-
-2007-11-27 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinSock.c: Add mising encoding conversion of the [info
- hostname] value from the system encoding to Tcl's internal encoding.
-
- * doc/chan.n: "Fix" the limitation on channel -eofchar
- * doc/fconfigure.n: values to single byte characters by
- * generic/tclIO.c: documenting it and making it fail loudly.
- * tests/chan.test: Thanks to Stuart Cassoff for contributing the
- fix. [Bug 800753]
-
-2007-11-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * unix/tclUnixInit.c:
- * unix/tclUnixThrd.c: Fix stack checking via workaround for bug in
- glibc's pthread_attr_get_np, patch from [Bug 1815573]. Many thanks to
- Sergei Golovan (aka Teo) for detecting the bug and helping diagnose
- and develop the fix.
-
-2007-11-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictAppendCmd): Fix bug in [dict
- append] compiler which caused strange stack corruption. [Bug 1837392]
-
-2007-11-23 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c: Fixed a problem with reflected channels. 'chan
- postevent' is defined to work only from within the interpreter
- containing the handler command. Sensible, we want only handler
- commands to use it. It identifies the channel by handle. The channel
- moves to a different interpreter or thread. The interpreter containing
- the handler command doesn't know the channel any longer. 'chan
- postevent' fails, not finding the channel any longer. Uhm.
-
- Fixed by creating a second per-interpreter channel table, just for
- reflected channels, where each interpreter remembers for which
- reflected channels it has the handler command. This info does not move
- with the channel itself. The table is updated by 'chan create', and
- used by 'chan postevent'.
-
- * tests/ioCmd.test: Updated the testsuite.
-
-2007-11-23 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclVar.c (Tcl_ArrayObjCmd): handle the right data for
- * tests/var.test (var-14.2): [array names $var -glob $ptn]
-
-2007-11-23 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdMZ.c (String*Cmd, TclInitStringCmd): Rebuilt [string]
- * generic/tclCompCmds.c (TclCompileString*Cmd): as an ensemble.
-
-2007-11-22 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (Dict*Cmd,TclInitDictCmd): Rebuilt the [dict]
- * generic/tclCompCmds.c (TclCompileDict*Cmd): command as an ensemble.
-
-2007-11-22 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Rewrote the [string] and
- * generic/tclDictObj.c (Tcl_DictObjCmd): [dict] implementations to be
- ready for conversion to ensembles.
-
- * tests/string.test (string-12.22): Flag shimmering bug found in
- [string range].
-
-2007-11-21 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileEnsemble): Rewrote the ensemble
- compiler to remove many of the limitations. Can now compile scripts
- that use unique prefixes of subcommands, and which have mappings of a
- command to multiple words (provided the first is a compilable command
- of course).
-
-2007-11-21 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclNamesp.c (TclMakeEnsemble): Factor out the code to set up
- a core ensemble from a table of information about subcommands, ready
- for reuse within the core.
-
- * generic/various: Start to return more useful Error codes, currently
- mainly on assorted lookup failures.
-
-2007-11-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c: Changed the underlying implementation of the
- hash table used in dictionaries to additionally keep all entries in
- the hash table in a linked list, which is only ever added to at the
- end. This makes iteration over all entries in the dictionary in
- key insertion order a trivial operation, and so cleans up a great deal
- of complexity relating to dictionary representation and stability of
- iteration order.
-
- ***POTENTIAL INCOMPATIBILITY***
- For any code that depended on the (strange) old iteration order.
-
- * generic/tclConfig.c (QueryConfigObjCmd): Correct usage of
- Tcl_WrongNumArgs.
-
-2007-11-19 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5b3 TAGGED FOR RELEASE ***
-
- * README: Bump version number to 8.5b3.
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
- * changes: Updated for 8.5b3 release.
-
-2007-11-19 Kevin Kenny <kennykb@users.sourceforge.net>
-
- * library/tzdata/Africa/Cairo:
- * library/tzdata/America/Campo_Grande:
- * library/tzdata/America/Caracas:
- * library/tzdata/America/Cuiaba:
- * library/tzdata/America/Havana:
- * library/tzdata/America/Sao_Paulo:
- * library/tzdata/Asia/Damascus:
- * library/tzdata/Asia/Gaza:
- * library/tzdata/Asia/Tehran: Olson's tzdata2007i imported.
-
-2007-11-18 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclExecute.c (TclExecuteByteCode:INST_EXIST_*): Fix read
- traces not firing on non-existent array elements. [Bug 1833522]
-
-2007-11-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdIL.c (TclInitInfoCmd): Rename the implementation
- commands for [info] to be something more "expected".
-
- * generic/tclCompCmds.c (TclCompileInfoExistsCmd): Compiler for the
- [info exists] subcommand.
- (TclCompileEnsemble): Cleaned up version of ensemble compiler that was
- in TclCompileInfoCmd, but which is now much more generally applicable.
-
- * generic/tclInt.h (ENSEMBLE_COMPILE): Added flag to allow for cleaner
- turning on and off of ensemble bytecode compilation.
-
- * generic/tclCompile.c (TclCompileScript): Add the cmdPtr to the list
- of arguments passed to command compilers.
-
-2007-11-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/regc_nfa.c: Fixed infinite loop in the regexp compiler.
- [Bug 1810038]
-
- * generic/regc_nfa.c: Corrected looping logic in fixempties() to
- avoid wasting time walking a list of dead states. [Bug 1832612]
-
-2007-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclNamesp.c (NamespaceEnsembleCmd): Must pass a non-NULL
- interp to Tcl_SetEnsemble* functions.
-
- * doc/re_syntax.n: Try to make this easier to read. It's still a very
- difficult manual page!
-
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow people to turn off the -rpath
- option to their linker if they so desire. This is a configuration only
- recommended for (some) vendors. Relates to [Patch 1231022].
-
-2007-11-15 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWin32Dll.c: Prefer UINT_PTR to DWORD_PTR when casting
- pointers to integer types for greater portability. [Bug 1831253]
-
-2007-11-15 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add new chanio.test.
- * macosx/Tcl.xcode/project.pbxproj:
-
-2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompile.c (TclCompileScript): Ensure that we get our
- count in our INST_START_CMD calls right, even when there's a failure
- to compile a command directly.
-
- * generic/tclNamesp.c (Tcl_SetEnsembleSubcommandList)
- (Tcl_SetEnsembleMappingDict): Special code to make sure that
- * generic/tclCmdIL.c (TclInitInfoCmd): [info exists] is compiled
- right while not allowing changes to the ensemble to cause havok.
-
- * generic/tclCompCmds.c (TclCompileInfoCmd): Simple compiler for the
- [info] command that only handles [info exists].
-
- * generic/tclExecute.c (TclExecuteByteCode:INST_EXIST_*): New
- instructions to allow the testing of whether a variable exists.
-
-2007-11-14 Andreas Kupries <andreask@activestate.com>
-
- * tests/chanio.test: New file. This is essentially a duplicate of
- 'io.test', with all channel commands converted to their 'chan xxx'
- notation.
- * tests/io.test: Fixed typo in test description.
-
-2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/regc*.c: Eliminate multi-char collating element code
- completely. Simplifies the code quite a bit. If people still want the
- full code, it will remain on the 8.4 branch. [Bug 1831425]
-
-2007-11-13 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c (TclCompileRegexpCmd): clean up comments, only
- free dstring on OK from TclReToGlob.
- (TclCompileSwitchCmd): simplify TclReToGlob usage.
-
-2007-11-14 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/regc*.c: #ifdef/comment out the code that deals with
- multi-character collating elements, which have never been supported.
- Cuts the memory consumption of the RE compiler. [Bug 1831425]
-
-2007-11-13 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd, TclCompileRegexpCmd):
- Extend [switch] compiler to handle regular expressions as long as
- things are not too complex. Fix [regexp] compiler so that non-trivial
- literal regexps get fed to INST_REGEXP.
-
- * doc/mathop.n: Clarify definitions of some operations.
-
-2007-11-13 Miguel Sofer <msofer@users.sf.net>
-
- * unix/tclUnixInit.c: the TCL_NO_STACK_CHECK was being incorrectly
- undefined here; this should be set (or not) in the compile options, it
- is used elsewhere and needs to be consistent.
-
-2007-11-13 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * unix/tcl.m4: Added autoconf goo to detect and make use of
- * unix/configure.in: getaddrinfo and friends.
- * unix/configure: (regenerated)
-
-2007-11-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixCompat.c (TclpGetHostByName): The six-argument form of
- getaddressbyname_r() uses the fifth argument to indicate whether the
- lookup succeeded or not on at least one platform. [Bug 1618235]
-
-2007-11-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/regcomp.c: Convert optst() from expensive no-op to a
- cheap no-op.
-
-2007-11-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixChan.c (CreateSocketAddress): Rewrote to use the
- thread-safe version of gethostbyname() by forward-porting the code
- used in 8.4, and added rudimentary support for getaddrinfo() (not
- enabled by default, as no autoconf-ery written). Part of fix for [Bug
- 1618235].
-
-2007-11-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclGet.c (Tcl_Get, Tcl_GetInt): revert use of TclGet* macros
- due to compiler warning. These cases won't save time either.
-
- * generic/tclUtil.c (TclReToGlob): add more comments, set interp
- result if specified on error.
-
-2007-11-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: New macro TclResetResult, new iPtr
- * generic/tclExecute.c: flag bit INTERP_RESULT_UNCLEAN:
- * generic/tclInt.h: shortcut for Tcl_ResetResult for the
- * generic/tclProc.c: "normal" case: TCL_OK, no return
- * generic/tclResult.c: options, no errorCode nor errorInfo,
- * generic/tclStubLib.c: return at normal level. [Patch
- * generic/tclUtil.c: 1830184]
-
- THIS PATCH WAS REVERTED: initial (mis)measurements overstated the
- perfomance wins, which turn out to be tiny. Not worth the
- complication.
-
-2007-11-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclCompCmds.c, generic/tclCompile.c, generic/tclCompile.h:
- * generic/tclExecute.c, generic/tclInt.decls, generic/tclIntDecls.h:
- * generic/tclRegexp.c, generic/tclRegexp.h: Add INST_REGEXP and fully
- * generic/tclStubInit.c, generic/tclUtil.c: compiled [regexp] for the
- * tests/regexpComp.test: [Bug 1830166] simple cases. Also added
- TclReToGlob function to convert RE to glob patterns and use these in
- the possible cases.
-
-2007-11-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclResult.c (ResetObjResult): clarify the logic.
-
- * generic/tclBasic.c: Increased usage of macros to detect
- * generic/tclBinary.c: and take advantage of objTypes. Added
- * generic/tclClock.c: macros TclGet(Int|Long)FromObj,
- * generic/tclCmdAH.c: TclGetIntForIndexM & TclListObjLength,
- * generic/tclCmdIL.c: modified TclListObjGetElements.
- * generic/tclCmdMZ.c:
- * generic/tclCompCmds.c: The TclGetInt* macros are only a
- * generic/tclCompExpr.c: shortcut on platforms where 'long' is
- * generic/tclCompile.c: 'int'; it may be worthwhile to extend
- * generic/tclDictObj.c: their functionality to other cases.
- * generic/tclExecute.c:
- * generic/tclGet.c: As this patch touches many files it
- * generic/tclIO.c: has been recorded as [Patch 1830038]
- * generic/tclIOCmd.c: in order to facilitate reviewing.
- * generic/tclIOGT.c:
- * generic/tclIndexObj.c:
- * generic/tclInt.h:
- * generic/tclInterp.c:
- * generic/tclListObj.c:
- * generic/tclLiteral.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclParse.c:
- * generic/tclProc.c:
- * generic/tclRegexp.c:
- * generic/tclResult.c:
- * generic/tclScan.c:
- * generic/tclStringObj.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
-
-2007-11-11 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixTime.c (TclpWideClicksToNanoseconds): Fix issues with
- * generic/tclInt.h: int64_t overflow.
-
- * generic/tclBasic.c: Fix stack check failure case if stack grows up
- * unix/tclUnixInit.c: Simplify non-crosscompiled case.
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2007-11-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Fast path for INST_LIST_INDEX when the index
- is not a list.
-
- * generic/tclBasic.c:
- * unix/configure.in:
- * unix/tclUnixInit.c: Detect stack grwoth direction at compile time,
- only fall to runtime detection when crosscompiling.
-
- * unix/configure: autoconf 2.61
-
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * tests/interp.test:
- * unix/tclUnixInit.c:
- * win/tclWin32Dll.c: Restore simpler behaviour for stack checking, not
- adaptive to stack size changes after a thread is launched. Consensus
- is that "nobody does that", and so it is not worth the cost. Improved
- failure comments (mistachkin).
-
-2007-11-10 Kevin Kenny <kennykb@acm.org>
-
- * win/tclWin32Dll.c: Rewrote the Windows stack checking algorithm to
- use information from VirtualQuery to determine the bound of the stack.
- This change fixes a bug where the guard page of the stack was never
- restored after an overflow. It also eliminates a nasty piece of
- assembly code for structured exception handling on mingw. It
- introduces an assumption that the stack is a single memory arena
- returned from VirtualAlloc, but the code in MSVCRT makes the same
- assumption, so it should be fairly safe.
-
-2007-11-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * unix/tclUnixInit.c:
- * unix/tclUnixPort.h:
- * win/tclWin32Dll.c: Modify the stack checking algorithm to recheck in
- case of failure. The working assumptions are now that (a) a thread's
- stack is never moved, and (b) a thread's stack can grow but not
- shrink. Port to windows - could be more efficient, but is already
- cheaper than it was.
-
-2007-11-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclResult.c (ResetObjResult): new shortcut.
-
- * generic/tclAsync.c:
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclUnixInit.c:
- * generic/tclUnixPort.h: New fields in interp (ekeko!) to cache TSD
- data that is accessed at each command invocation, access macros to
- replace Tcl_AsyncReady and TclpCheckStackSpace by much faster variants
- [Patch 1829248]
-
-2007-11-09 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclInt.decls, generic/tclIntDecls.h: Use unsigned char for
- * generic/tclExecute.c, generic/tclUtil.c: TclByteArrayMatch and
- don't allow a nocase option. [Bug 1828296]
- For INST_STR_MATCH, ignore pattern type for TclByteArrayMatch case.
-
- * generic/tclBinary.c (Tcl_GetByteArrayFromObj): check type before
- func jump (perf).
-
-2007-11-07 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclStubInit.c: Added TclByteArrayMatch
- * generic/tclInt.decls: for efficient glob
- * generic/tclIntDecls.h: matching of ByteArray
- * generic/tclUtil.c (TclByteArrayMatch): Tcl_Objs, used in
- * generic/tclExecute.c (TclExecuteByteCode): INST_STR_MATCH. [Bug
- 1827996]
-
- * generic/tclIO.c (TclGetsObjBinary): Add an efficient binary path for
- [gets].
- (DoWriteChars): Special case for 1-byte channel write.
-
-2007-11-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclEncoding.c: Version of the embedded iso8859-1 encoding
- handler that is faster (functions to do the encoding know exactly what
- they're doing instead of pulling it from a table, though the table
- itself has to be retained for use by shift encodings that depend on
- iso8859-1). [Patch 1826906], committing for dkf.
-
-2007-11-05 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclConfig.c (Tcl_RegisterConfig): Modified to not extend the
- config database if the encoding provided by the user is not found
- (venc == NULL). Scripts expecting the data will error out, however we
- neither crash nor provide bogus information. See [Bug 983509] for more
- discussion.
-
- * unix/tclUnixChan.c (TtyGetOptionProc): Accepted [Patch 1823576]
- provided by Stuart Cassof <stwo@users.sourceforge.net>. The patch adds
- the necessary utf/external conversions to the handling of the
- arguments of option -xchar which will allow the use of \0 and similar
- characters.
-
-2007-11-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclTest.c (TestSetCmd2):
- * generic/tclVar.c (TclObjLookupVarEx):
- * tests/set.test (set-5.1): Fix error branch when array name looks
- like array element (code not normally exercised).
-
-2007-11-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/tcltk-man2html.tcl (output-directive): Convert .DS/.DE pairs
- into tables since that is now all that they are used for.
-
- * doc/RegExp.3: Clarified documentation of RE flags. [Bug 1167840]
-
- * doc/refchan.n: Adjust internal name to be consistent with the file
- name for reduced user confusion. After comment by Dan Steffen.
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd, UniCharIsAscii): Remember, the
- NUL character is in ASCII too. [Bug 1808258]
-
- * doc/file.n: Clarified use of [file normalize]. [Bug 1185154]
-
-2007-10-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump version number to 8.5b2.1 to distinguish
- * library/init.tcl: CVS development snapshots from the 8.5b2
- * unix/configure.in: release.
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
-2007-10-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/expr.n, doc/mathfunc.n: Improve documentation to try to make
- clearer what is going on.
-
- * doc/interp.n: Shorten the basic descriptive text for some interp
- subcommands so Solaris nroff doesn't truncate them. [Bug 1822268]
-
-2007-10-30 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (output-widget-options): Enhance the HTML
- generator so that it can produce multi-line option descriptions.
-
-2007-10-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclUtil.c (Tcl_ConcatObj): optimise for some of the
- concatenees being empty objs. [Bug 1447328]
-
-2007-10-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclEncoding.c (TclInitEncodingSubsystem): Hard code the
- iso8859-1 encoding, as it's needed for more than just text (especially
- binary encodings...) Note that other encodings rely on the encoding
- being a table encoding (!) so we can't use more efficient encoding
- mapping functions.
-
-2007-10-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/regc_lex.c (lexescape): Close off one of the problems
- mentioned in [Bug 1810264].
-
-2007-10-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_FindCommand): insure that FQ command names
- are searched from the global namespace, ie, bypassing resolvers of the
- current namespace. [Bug 1114355]
-
- * doc/apply.n: fixed example [Bug 1811791]
- * doc/namespace.n: improved example [Bug 1788984]
- * doc/AddErrInfo.3: typo [Bug 1715087]
- * doc/CrtMathFnc.3: fixed Tcl_ListMathFuncs entry [Bug 1672219]
-
- * generic/tclCompile.h:
- * generic/tclInt.h: moved declaration of TclSetCmdNameObj from
- tclCompile.h to tclInt.h, reverting linker [Bug 1821159] caused by
- commit of 2007-10-11 (both I and gcc missed one dep).
-
- * generic/tclVar.c: try to preserve Tcl_Objs when doing variable
- lookups by name, partially addressing [Bug 1793601].
-
-2007-10-27 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl (make-man-pages, htmlize-text)
- (process-text): Make the man->HTML scraper work better.
-
-2007-10-26 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5b2 TAGGED FOR RELEASE ***
-
- * changes: Updated for 8.5b2 release.
-
- * doc/*.1: Revert doc changes that broke
- * doc/*.3: `make html` so we can get the release
- * doc/*.n: out the door.
-
- * README: Bump version number to 8.5b2.
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
-2007-10-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/man2help2.tcl, tools/man2tcl.c: Made some of the tooling code
- to do man->other formats work better with current manpage set. Long
- way still to go.
-
-2007-10-25 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclThread.c: Added TclpMasterLock/Unlock arround calls to
- ForgetSyncObject in Tcl_MutexFinalize and Tcl_ConditionFinalize to
- prevent from garbling the internal lists that track sync objects. [Bug
- 1726873]
-
-2007-10-24 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/man2html2.tcl (macro): Added support for converting the new
- macros into HTML.
-
- * doc/man.macros (QW,PQ,QR,MT): New macros that hide the ugly mess
- needed to get proper GOOBE quoting in the manual pages.
- * doc/*.n, doc/*.3, doc/*.1: Lots of changes to take advantage of the
- new macros.
-
-2007-10-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: Fix comments.
- * generic/tclExecute.c:
-
-2007-10-18 David Gravereaux <davygrvy@pobox.com>
-
- * tools/mkdepend.tcl: sort the dep list for a more humanly readable
- output.
-
-2007-10-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c (TclMergeReturnOptions): Make sure any -code
- values get pulled out of the dictionary, even if they are integer
- valued.
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): Added code to more
- optimally compile [return -level 0 $x] to "push $x". [RFE 1794073]
-
- * compat/tmpnam.c (removed): The routine tmpnam() is no longer
- * unix/Makefile.in: called by Tcl source code. Remove autogoo the
- * unix/configure.in: supplied a replacement version on systems
- * win/tcl.dsp: where the routine was not available. [RFE
- 1811848]
-
- * unix/configure: autoconf-2.59
-
- * generic/tcl.h: Remove TCL_LL_MODIFIER_SIZE. [RFE 1811837]
-
-2007-10-17 David Gravereaux <davygrvy@pobox.com>
-
- * tools/mkdepend.tcl: Improved defense from malformed object list
- infile.
-
-2007-10-17 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tools/man2html2.tcl: Convert .DS/.DE into HTML tables, not
- preformatted text.
-
-2007-10-17 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclCompExpr.c: Moved a misplaced declaration that blocked
- compilation on VC++.
- * generic/tclExecute.c: Silenced several VC++ compiler warnings about
- converting 'long' to 'unsigned short'.
-
-2007-10-16 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: removed old dependency cruft that is no longer
- needed.
-
-2007-10-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOCmd.c: Revise [open] so that it interprets leading
- zero strings passed as the "permissions" argument as octal numbers,
- even if Tcl itself no longer parses integers in that way.
-
- * unix/tclUnixFCmd.c: Revise the "-permissions" [file attribute] so
- that it interprets leading zero strings as octal numbers, even if Tcl
- itself no longer parses integers in that way.
-
- * generic/tclCompExpr.c: Corrections to code that produces
- * generic/tclUtil.c: extended "bad octal" error messages.
-
- * tests/cmdAH.test: Test revisions so that tests pass whether or
- * tests/cmdIL.test: not Tcl parses leading zero strings as octal.
- * tests/compExpr-old.test:
- * tests/compExpr.test:
- * tests/compile.test:
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/incr.test:
- * tests/io.test:
- * tests/lindex.test:
- * tests/link.test:
- * tests/mathop.test:
- * tests/parseExpr.test:
- * tests/set.test:
- * tests/string.test:
- * tests/stringComp.test:
-
-2007-10-15 David Gravereaux <davygrvy@pobox.com>
-
- * tools/mkdepend.tcl: Produces usable output. Include path problem
- * win/makefile.vc: fixed. Never fight city hall when it comes to
- levels of quoting issues.
-
-2007-10-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c (Tcl_ParseBraces): fix for possible read after
- the end of buffer. [Bug 1813528] (Joe Mistachkin)
-
-2007-10-14 David Gravereaux <davygrvy@pobox.com>
-
- * tools/mkdepend.tcl (new): Initial stab at generating automatic
- * win/makefile.vc: dependencies.
-
-2007-10-12 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Mine all version information from headers.
- * win/rules.vc: Sync tcl and tk and bring extension versions
- * win/nmakehlp.c: closer together. Try and avoid using tclsh to do
- substitutions as we may cross compile.
- * win/coffbase.txt: Added offsets for snack dlls.
-
-2007-10-11 David Gravereaux <davygrvy@pobox.com>
-
- * win/makefile.vc: Fixed my bad spelling mistakes from years back.
- Dedependency, duh! Rather funny.
-
-2007-10-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c: Correct [string is (wide)integer] failure
- * tests/string.test: to report correct failindex values for
- non-decimal integer strings. [Bug 1805887]
-
- * compat/strtoll.c (removed): The routines strtoll() and strtoull()
- * compat/strtoull.c (removed): are no longer called by the Tcl source
- * generic/tcl.h: code. (Their functionality has been replaced
- * unix/Makefile.in: by TclParseNumber().) Remove outdated comments
- * unix/configure.in: and mountains of configury autogoo that
- * unix/tclUnixPort.h: allegedly support the mythical systems where
- * win/Makefile.in: these routines might not have been available.
- * win/makefile.bc:
- * win/makefile.vc:
- * win/tclWinPort.h:
-
- * unix/configure: autoconf-2.59
-
-2007-10-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclObj.c: remove superfluous #include of tclCompile.h
-
-2007-10-08 George Peter Staplin <georgeps@xmission.com>
-
- * doc/Hash.3: Correct the valid usage of the flags member for the
- Tcl_HashKeyType. It should be 0 or more of the flags mentioned.
-
-2007-10-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tcl.h (Tcl_DecrRefCount): Update change from 2006-05-29 to
- make macro more warning-robust in unbraced if code.
-
-2007-10-02 Don Porter <dgp@users.sourceforge.net>
-
- [core-stabilizer-branch]
-
- * README: Bump version number to 8.5.0
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
-2007-10-02 Andreas Kupries <andreask@activestate.com>
-
- * library/tclIndex: Added 'tcl::tm::path' to the tclIndex. This fixes
- [Bug 1806422] reported by Don Porter.
-
-2007-09-25 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclProc.c (Tcl_DisassembleObjCmd): Define a command,
- ::tcl::unsupported::disassemble, which can disassemble procedures,
- lambdas and general scripts.
- * generic/tclCompile.c (TclDisassembleByteCodeObj): Split apart the
- code to print disassemblies of bytecode so that there is reusable code
- that spits it out in a Tcl_Obj and then that code is used when doing
- tracing.
-
-2007-09-20 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5b1 TAGGED FOR RELEASE ***
-
- * changes: updates for 8.5b1 release.
-
-2007-09-19 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bump version number to 8.5b1
- * generic/tcl.h: Merge from core-stabilizer-branch.
- * library/init.tcl: Stabilizing toward 8.5b1 release now done on
- * tools/tcl.wse.in: the HEAD. core-stabilizer-branch is now
- * unix/configure.in: suspended.
- * unix/tcl.spec:
- * win/configure.in:
-
-2007-09-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclStubLib.: Replaced isdigit with internal implementation.
-
-2007-09-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs() so
- * win/makefile.vc: that we don't need the C library linked in to
- libtclStub.
-
-2007-09-17 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Add crt flags for tclStubLib now it uses C-library
- functions.
-
-2007-09-17 Joe English <jenglish@users.sourceforge.net>
-
- * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable' to build
- shared libraries on current NetBSDs. [Bug 1749251]
- * unix/configure: regenerated (autoconf-2.59).
-
-2007-09-17 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Update `make dist` so that tclDTrace.d is
- included in the source code distribution.
-
- * generic/tcl.h: Revised Tcl_InitStubs() to restore Tcl 8.4
- * generic/tclPkg.c: source compatibility with callers of
- * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1). [Bug
- 1578344]
-
-2007-09-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd)
- (TraceCommandObjCmd, TraceVariableObjCmd): Generate literal values
- * generic/tclNamesp.c (NamespaceCodeCmd): more efficiently using
- * generic/tclFCmd.c (CopyRenameOneFile): TclNewLiteralStringObj
- * generic/tclEvent.c (TclSetBgErrorHandler): macro.
-
-2007-09-15 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: replace all direct references to compiler by ${CC} to
- enable CC overriding at configure & make time; run
- check for visibility "hidden" with all compilers;
- quoting fixes from TEA tcl.m4.
- (SunOS-5.1x): replace direct use of '/usr/ccs/bin/ld' in SHLIB_LD by
- 'cc' compiler driver.
- * unix/configure: autoconf-2.59
-
-2007-09-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclBasic.c (Tcl_CreateObjCommand): Only invalidate along the
- namespace path once; that is enough. [Bug 1519940]
-
-2007-09-14 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclDTrace.d (new file): Add DTrace provider for Tcl; allows
- * generic/tclCompile.h: tracing of proc and command entry &
- * generic/tclBasic.c: return, bytecode execution, object
- * generic/tclExecute.c: allocation and more; with
- * generic/tclInt.h: essentially zero cost when tracing
- * generic/tclObj.c: is inactive; enable with
- * generic/tclProc.c: --enable-dtrace configure arg
- * unix/Makefile.in: (disabled by default, will only
- * unix/configure.in: enable if DTrace is present). [Patch
- 1793984]
-
- * macosx/GNUmakefile: Enable DTrace support.
- * macosx/Tcl-Common.xcconfig:
- * macosx/Tcl.xcodeproj/project.pbxproj:
-
- * generic/tclCmdIL.c: Factor out core of InfoFrameCmd() into
- internal TclInfoFrame() for use by DTrace
- probes.
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2007-09-12 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Perform missing updates of the tcltest Tcl
- * win/Makefile.in: Module installed filename that should have
- been part of the bump to tcltest 2.3b1. Thanks Larry Virden.
-
-2007-09-12 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc, win/rules.vc, win/nmakehlp.c: Use nmakehlp to
- substitute values for tclConfig.sh (helps cross-compiling).
-
-2007-09-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: Accept underscores and colons in
- * library/tcltest/pkgIndex.tcl: constraint names. Properly handle
- constraint expressions that return non-numeric boolean results like
- "false". Bump to tcltest 2.3b1. [Bug 1772989; RFE 1071322]
- * tests/info.test: Disable fragile tests.
-
- * doc/package.n: Restored the functioning of [package require
- * generic/tclPkg.c: -exact] to be compatible with Tcl 8.4. [Bug
- * tests/pkg.test: 1578344]
-
-2007-09-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictCmd-update):
- * generic/tclCompile.c (tclInstructionTable):
- * generic/tclExecute.c (INST_DICT_UPDATE_END): fix stack management in
- compiled [dict update]. [Bug 1786481]
-
- ***POTENTIAL INCOMPATIBILITY***
- Scripts that were precompiled on earlier versions of 8.5 and use [dict
- update] will crash. Workaround: recompile.
-
-2007-09-11 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c: Corrected an off-by-one error in the setting
- of MaxBaseWide for certain powers. [Bug 1767293 - problem reported in
- comments when bug was reopened]
-
-2007-09-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclLink.c (Tcl_UpdateLinkedVar): guard against var being
- unlinked. [Bug 1740631] (maros)
-
-2007-09-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: fix tclInstructionTable entry for
- dictUpdateEnd
-
- * generic/tclExecute.c: remove unneeded setting of 'cleanup' variable
- before jumping to checkForCatch.
-
-2007-09-10 Don Porter <dgp@users.sourceforge.net>
-
- * doc/package.n: Restored the document parallel syntax of the
- * generic/tclPkg.c: [package present] and [package require]
- * tests/pkg.test: commands. [Bug 1723675]
-
-2007-09-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Removed the "nsName" Tcl_ObjType from the
- * generic/tclNamesp.c: registered set. Revised the management of the
- * generic/tclObj.c: intrep of that Tcl_ObjType. Revised the
- * tests/obj.test: TclGetNamespaceFromObj() routine to return
- TCL_ERROR and write a consistent error message when a namespace is not
- found. [Bug 1588842. Patch 1686862]
-
- ***POTENTIAL INCOMPATIBILITY***
- For callers of Tcl_GetObjType() on the name "nsName".
-
- * generic/tclExecute.c: Update TclGetNamespaceFromObj() callers.
- * generic/tclProc.c:
-
- * tests/apply.test: Updated tests to expect new consistent
- * tests/namespace-old.test: error message when a namespace is not
- * tests/namespace.test: found.
- * tests/upvar.test:
-
- * generic/tclCompCmds.c: Use the new INST_REVERSE instruction
- * tests/mathop.test: to correct the compiled versions of math
- operator commands. [Bug 1724437]
-
- * generic/tclCompile.c: New bytecode instruction INST_REVERSE to
- * generic/tclCompile.h: reverse the order of N items at the top of
- * generic/tclExecute.c: stack.
-
- * generic/tclCompCmds.c (TclCompilePowOpCmd): Make a separate
- routine to compile ** to account for its different associativity.
-
-2007-09-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710] fixed
- correctly, reverted fix of 2007-05-01.
-
-2007-09-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictUpdateCmd, DictWithCmd): Plug a hole that
- * generic/tclExecute.c (TEBC,INST_DICT_UPDATE_END): allowed a careful
- * tests/dict.test (dict-21.16,21.17,22.11): attacker to craft a dict
- containing a recursive link to itself, violating one of Tcl's
- fundamental datatype assumptions and causing a stack crash when the
- dict was converted to a string. [Bug 1786481]
-
-2007-09-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEvent.c ([::tcl::Bgerror]): Corrections to Tcl's
- * tests/event.test: default [interp bgerror] handler so that when
- it falls back to a hidden [bgerror] in a safe interp, it gets the
- right error context data. [Bug 1790274]
-
-2007-09-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (TclInitCompiledLocals): the refCount of resolved
- variables was being managed without checking if they were Var or
- VarInHash: itcl [Bug 1790184]
-
-2007-09-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c (Tcl_GetReturnOptions): Take care that a
- * tests/init.test: non-TCL_ERROR code doesn't cause existing
- -errorinfo, -errorcode, and -errorline entries to be omitted.
- * generic/tclEvent.c: With -errorInfo no longer lost, generate more
- complete ::errorInfo when calling [bgerror] after a non-TCL_ERROR
- background exception.
-
-2007-09-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInterp.c (Tcl_Init): Removed constraint on ability
- to define a custom [tclInit] before calling Tcl_Init(). Until now the
- custom command had to be a proc. Now it can be any command.
-
- * generic/tclInt.decls: New internal routine TclBackgroundException()
- * generic/tclEvent.c: that for the first time permits non-TCL_ERROR
- exceptions to trigger [interp bgerror] handling. Closes a gap in TIP
- 221. When falling back to [bgerror] (which is designed only to handle
- TCL_ERROR), convert exceptions into errors complaining about the
- exception.
-
- * generic/tclInterp.c: Convert Tcl_BackgroundError() callers to call
- * generic/tclIO.c: TclBackgroundException().
- * generic/tclIOCmd.c:
- * generic/tclTimer.c:
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2007-09-06 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcode/project.pbxproj: discontinue unmaintained support
- * macosx/Tcl.xcode/default.pbxuser: for Xcode 1.5; replace by Xcode2
- project for use on Tiger (with Tcl.xcodeproj to be used on Leopard).
-
- * macosx/Tcl.xcodeproj/project.pbxproj: updates for Xcode 2.5 and 3.0.
- * macosx/Tcl.xcodeproj/default.pbxuser:
- * macosx/Tcl.xcode/project.pbxproj:
- * macosx/Tcl.xcode/default.pbxuser:
- * macosx/Tcl-Common.xcconfig:
-
- * macosx/README: document project changes.
-
-2007-09-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Removed support for the unmaintained
- * generic/tclExecute.c: -DTCL_GENERIC_ONLY configuration. [Bug
- * unix/Makefile.in: 1264623]
-
-2007-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: It's unreliable to count on the release
- manager to remember to `make genstubs` before `make dist`. Let the
- Makefile remember the dependency for us.
-
- * unix/Makefile.in: Corrections to `make dist` dependencies to be
- sure that macosx/configure gets generated whenever it does not exist.
-
-2007-09-03 Kevin B, Kenny <kennykb@acm.org>
-
- * library/tzdata/Africa/Cairo:
- * library/tzdata/America/Grand_Turk:
- * library/tzdata/America/Port-au-Prince:
- * library/tzdata/America/Indiana/Petersburg:
- * library/tzdata/America/Indiana/Tell_City:
- * library/tzdata/America/Indiana/Vincennes:
- * library/tzdata/Antarctica/McMurdo:
- * library/tzdata/Australia/Adelaide:
- * library/tzdata/Australia/Broken_Hill:
- * library/tzdata/Australia/Currie:
- * library/tzdata/Australia/Hobart:
- * library/tzdata/Australia/Lord_Howe:
- * library/tzdata/Australia/Melbourne:
- * library/tzdata/Australia/Sydney:
- * library/tzdata/Pacific/Auckland:
- * library/tzdata/Pacific/Chatham: Olson's tzdata2007g.
-
- * generic/tclListObj.c (TclLindexFlat):
- * tests/lindex.test (lindex-17.[01]): Added code to detect the error
- when a script does [lindex {} end foo]; an overaggressive optimisation
- caused this call to return an empty object rather than an error.
-
-2007-09-03 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclObj.c (TclInitObjSubsystem): restore registration of the
- "wideInt" Tcl_ObjType for compatibility with 8.4 extensions that
- access the tclWideIntType Tcl_ObjType; add setFromAnyProc for
- tclWideIntType.
-
-2007-09-02 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/lsearch.n: Added note that order of results with the -all option
- is that of the input list. It always was, but this makes it crystal.
-
-2007-08-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Added fflush() calls following all callers of
- * generic/tclExecute.c: TclPrintByteCodeObj() so that tcl_traceCompile
- output is less likely to get mangled when writes to stdout interleave
- with other code.
-
-2007-08-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Use a table lookup in ParseLexeme() to
- determine lexemes with single-byte representations.
-
- * generic/tclBasic.c: Used unions to better clarify overloading of
- * generic/tclCompExpr.c: the fields of the OpCmdInfo and
- * generic/tclCompile.h: TclOpCmdClientData structs.
-
-2007-08-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Call TclCompileSyntaxError() when
- expression syntax errors are found when compiling expressions. With
- this in place, convert TclCompileExpr to return void, since there's no
- longer any need to report TCL_ERROR.
- * generic/tclCompile.c: Update callers.
- * generic/tclExecute.c:
-
- * generic/tclCompCmds.c: New routine TclCompileSyntaxError()
- * generic/tclCompile.h: to directly compile bytecodes that report a
- * generic/tclCompile.c: syntax error, rather than (ab)use a call to
- TclCompileReturnCmd. Also, undo the most recent commit that papered
- over some issues with that (ab)use. New routine produces a new opcode
- INST_SYNTAX, which is a minor variation of INST_RETURN_IMM. Also a bit
- of constification.
-
- * generic/tclCompile.c: Move the deallocation of local LiteralTable
- * generic/tclCompExpr.c: entries into TclFreeCompileEnv().
- * generic/tclExecute.c: Update callers.
-
- * generic/tclCompExpr.c: Force numeric and boolean literals in
- expressions to register with their intreps intact, even if that means
- overwriting existing intreps in already registered literals.
-
-2007-08-25 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c (TclExecuteByteCode): Added code to handle
- * tests/expr.test (expr-23.48-53) integer exponentiation
- that results in 32- and 64-bit integer results, avoiding calls to wide
- integer exponentiation routines in this common case. [Bug 1767293]
-
- * library/clock.tcl (ParseClockScanFormat): Modified code to allow
- * tests/clock.test (clock-60.*): case-insensitive matching
- of time zone and month names. [Bug 1781282]
-
-2007-08-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Register literals found in expressions
- * tests/compExpr.test: to restore literal sharing. Preserve numeric
- intreps when literals are created for the first time. Correct memleak
- in ExecConstantExprTree() and add test for the leak.
-
-2007-08-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: replaced copy loop that tripped some compilers
- with memmove. [Bug 1780870]
-
-2007-08-23 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl ([auto_load_index]): Delete stray "]" that created
- an expr syntax error (masked by a [catch]).
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): Added crash protection
- to handle callers other than TclCompileScript() failing to meet the
- initialization assumptions of the TIP 280 code in CompileWord().
-
- * generic/tclCompExpr.c: Suppress the attempt to convert to
- numeric when precompiling a constant expression indicates an error.
-
-2007-08-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC): disable the new shortcut to frequent
- INSTs for debug builds. REVERTED (collision with alternative fix)
-
-2007-08-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c: Corrected the logic of dropping the last
- * tests/main.test: newline from an interactively typed command.
- [Bug 1775878]
-
-2007-08-21 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/thread.test: thread-4.4: clear ::errorInfo in the thread as a
- message is left here from init.tcl on windows due to no tcl_pkgPath.
-
-2007-08-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_SUB): fix usage of the new macro for
- overflow detection in sums, adapt to subtraction. Lengthy comment
- added.
-
-2007-08-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (Overflowing, TclIncrObj, TclExecuteByteCode):
- Encapsulate Miguel's last change in a more mnemonic macro.
-
-2007-08-19 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: changed the check for overflow in sums,
- reducing objsize, number of branches and cache misses (according to
- cachegrind). Non-overflow for s=a+b:
- previous
- ((a >= 0 || b >= 0 || s < 0) && (s >= 0 || b < 0 || a < 0))
- now
- (((a^s) >= 0) || ((a^b) < 0))
- This expresses: "a and s have the same sign or else a and b have
- different sign".
-
-2007-08-19 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/interp.n (RESOURCE LIMITS): Added text to better explain why
- time limits are described using absolute times. [Bug 1752148]
-
-2007-08-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: improved localVarNameType caching to leverage
- the new availability of Tcl_Obj in variable names, avoiding string
- comparisons to verify that the cached value is usable.
-
- * generic/tclExecute.c: check the two most frequent instructions
- before the switch. Reduces both runtime and obj size a tiny bit.
-
-2007-08-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Added a "constant" field to the OpNode
- struct (again "free" due to alignment requirements) to mark those
- subexpressions that are completely known at compile time. Enhanced
- CompileExprTree() and its callers to precompute these constant
- subexpressions at compile time. This resolves the issue raised in [Bug
- 1564517].
-
-2007-08-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclIOUtil.c (TclGetOpenModeEx): Only set the O_APPEND flag
- * tests/ioUtil.test (ioUtil-4.1): on a channel for the 'a'
- mode and not for 'a+'. [Bug 1773127]
-
-2007-08-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_INVOKE*): peephole opt, do not get the
- interp's result if it will be pushed/popped.
-
-2007-08-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Use fully qualified variable names for
- * tests/thread.test: ::errorInfo and ::errorCode so that string
- * tests/trace.test: reported to variable traces are fully
- qualified in agreement with Tcl 8.4 operations.
-
-2007-08-14 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclLoadDyld.c: use dlfcn API on Mac OS X 10.4 and later; fix
- issues with loading from memory on intel and 64bit; add debug messages
-
- * tests/load.test: add test load-10.1 for loading from vfs.
-
- * unix/dltest/pkga.c: whitespace & comment cleanup, remove
- * unix/dltest/pkgb.c: unused pkgf.c.
- * unix/dltest/pkgc.c:
- * unix/dltest/pkge.c:
- * unix/dltest/pkgf.c (removed):
- * unix/dltest/pkgua.c:
- * macosx/Tcl.xcodeproj/project.pbxproj:
-
-2007-08-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Provide DECACHE/CACHE protection to the
- * tests/trace.test: Tcl_LogCommandInfo() call. [Bug 1773040]
-
-2007-08-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdMZ.c (Tcl_SplitObjCmd): use TclNewStringObj macro
- instead of calling the function.
-
- * generic/tcl_Obj.c (TclAllocateFreeObjects): remove unneeded memset
- to 0 of all allocated objects.
-
-2007-08-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h: remove redundant ops in TclNewStringObj macro.
-
-2007-08-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h: fix the TclSetVarNamespaceVar macro, was causing a
- leak.
-
-2007-08-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Revise CompileExprTree() to use the
- OpNode mark field scheme of tree traversal. This eliminates the need
- to use magic values in the left and right fields for that purpose.
- Also stop abusing the left field within ParseExpr() to store the
- number of arguments in a parsed function call. CompileExprTree() now
- determines that for itself at compile time. Then reorder code to
- eliminate duplication.
-
-2007-08-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (TclCreateProc): better comments on the required
- varflag values when loading precompiled procs.
-
- * generic/tclExecute.c (INST_STORE_ARRAY):
- * tests/trace.test (trace-2.6): whole array write traces on compiled
- local variables were not firing. [Bug 1770591]
-
-2007-08-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclProc.c (InitLocalCache): reference firstLocalPtr via
- procPtr. codePtr->procPtr == NULL exposed by tbcload.
-
-2007-08-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrected failure to compile/link in the
- -DNO_WIDE_TYPE configuration.
-
- * generic/tclExecute.c: Corrected improper use of bignum arguments to
- * tests/expr.test: *SHIFT operations. [Bug 1770224]
-
-2007-08-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h: remove comments refering to VAR_SCALAR, as that
- flag bit does not exist any longer.
- * generic/tclProc.c (InitCompiledLocals): removed optimisation for
- non-resolved case, as the function is never called in that case.
- Renamed the function to InitResolvedLocals to calrify the point.
-
- * generic/tclInt.decls: Exporting via stubs to help xotcl adapt to
- * generic/tclInt.h: VarReform.
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
-2007-08-07 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclEnv.c: improve environ handling on Mac OS X (adapted
- * unix/tclUnixPort.h: from Apple changes in Darwin tcl-64).
-
- * unix/Makefile.in: add support for compile flags specific to
- object files linked directly into executables.
-
- * unix/configure.in (Darwin): only use -seg1addr flag when prebinding;
- use -mdynamic-no-pic flag for object files linked directly into exes;
- support overriding TCL_PACKAGE_PATH/TCL_MODULE_PATH in environment.
-
- * unix/configure: autoconf-2.59
-
-2007-08-06 Don Porter <dgp@users.sourceforge.net>
-
- * tests/parseExpr.test: Update source file name of expr parser code.
-
- * generic/tclCompExpr.c: Added a "mark" field to the OpNode
- struct, which is used to guide tree traversal. This field costs
- nothing since alignement requirements used the memory already.
- Rewrote ConvertTreeToTokens() to use the new field, which permitted
- consolidation of utility routines CopyTokens() and
- GenerateTokensForLiteral().
-
-2007-08-06 Kevin B. Kenny <kennykb@users.sf.net>
-
- * generic/tclGetDate.y: Added a cast to the definition of YYFREE to
- silence compiler warnings.
- * generic/tclDate.c: Regenerated
- * win/tclWinTest.c: Added a cast to GetSecurityDescriptorDacl call
- to silence compiler warnings.
-
-2007-08-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.decls: Exporting via stubs to help itcl adapt to
- * generic/tclInt.h: VarReform. Added localCache initialization
- * generic/tclIntDecls.h: to TclInitCompiledLocals (which only exists
- * generic/tclProc.c: for itcl).
- * generic/tclStubInit.c:
- * generic/tclVar.c:
-
-2007-08-01 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * library/word.tcl: Rewrote for greater efficiency. [Bug 1764318]
-
-2007-08-01 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclInt.h: Added a TclOffset macro ala Tk_Offset to
- * generic/tclVar.c: abstract out 'offsetof' which may not be
- * generic/tclExceute.c: defined (eg: msvc6).
-
-2007-08-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclCleanupVar): fix [Bug 1765225], thx Larry
- Virden.
-
-2007-07-31 Miguel Sofer <msofer@users.sf.net>
-
- * doc/Hash.3:
- * generic/tclHash.c:
- * generic/tclObj.c:
- * generic/tclThreadStorage.c: (changes part of the patch below)
- Stop Tcl_CreateHashVar from resetting hPtr->clientData to NULL after
- calling the allocEntryProc for a custom table.
-
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclCmdIL.c:
- * generic/tclCompCmds.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclHash.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclLiteral.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * generic/tclThreadStorage.c:
- * generic/tclTrace.c:
- * generic/tclVar.c: VarReform [Patch 1750051]
-
- *** POTENTIAL INCOMPATIBILITY *** (tclInt.h and tclCompile.h)
- Extensions that access internals defined in tclInt.h and/or
- tclCompile.h may lose both binary and source compatibility. The
- relevant changes are:
- 1. 'struct Var' is completely changed, all acceses to its internals
- (either direct or via the TclSetVar* and TclIsVar* macros) will
- malfunction. Var flag values and semantics changed too.
- 2. 'struct Bytecode' has an additional field that has to be
- initialised to NULL
- 3. 'struct Namespace' is larger, as the varTable is now one pointer
- larger than a Tcl_HashTable. Direct access to its fields will
- malfunction.
- 4. 'struct CallFrame' grew one more field (the second such growth with
- respect to Tcl8.4).
- 5. API change for the functions TclFindCompiledLocal, TclDeleteVars
- and many internal functions in tclVar.c
-
- Additionally, direct access to variable hash tables via the standard
- Tcl_Hash* interface is to be considered as deprecated. It still works
- in the present version, but will be broken by further specialisation
- of these hash tables. This concerns especially the table of array
- elements in an array, as well as the varTable field in the Namespace
- struct.
-
-2007-07-31 Miguel Sofer <msofer@users.sf.net>
-
- * unix/configure.in: allow use of 'inline' in Tcl sources. [Patch
- * win/configure.in: 1754128]
- * win/makefile.vc: Regen with autoconf 2.61
-
-2007-07-31 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/tclUnixInit.c (TclpSetVariables): Use the thread-safe getpwuid
- replacement to fill the tcl_platform(user) field as it is not subject
- to spoofing. [Bug 681877]
-
- * unix/tclUnixCompat.c: Simplify the #ifdef logic.
-
- * unix/tclUnixChan.c (FileWatchProc): Fix test failures.
-
-2007-07-30 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/tclUnixChan.c (SET_BITS, CLEAR_BITS): Added macros to make this
- file clearer.
-
-2007-07-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TEOvI, GetCommandSource):
- * generic/tclExecute.c (TEBC, TclGetSrcInfoForCmd):
- * generic/tclInt.h:
- * generic/tclTrace.c (TclCheck(Interp|Execution)Traces):
- Removed the need for TEBC to inspect the command before calling TEOvI,
- leveraging the TIP 280 infrastructure. Moved the generation of a
- correct nul-terminated command string away from the trace code, back
- into TEOvI/GetCommandSource.
-
-2007-07-20 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/platform.tcl: Fixed bug in 'platform::patterns'
- * library/platform/pkgIndex.tcl: where identifiers not matching
- * unix/Makefile.in: the special linux and solaris forms would not
- * win/Makefile.in: get 'tcl' as an acceptable platform added to
- * doc/platform.n: the result. Bumped package to version 1.0.3 and
- * doc/platform_shell.n: updated documentation and Makefiles. Also
- fixed bad version info in the documentation of platform::shell.
-
-2007-07-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c: In contexts where interp and parsePtr->interp
- might be different, be sure to use the latter for error reporting.
- Also pulled the interp argument back out of ParseTokens() since we
- already had a parsePtr->interp to work with.
-
-2007-07-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Removed unused arguments and variables
-
-2007-07-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c (ParseExpr): While adding comments to
- explain the operations of ParseExpr(), made significant revisions to
- the code so it would be easier to explain, and in the process made the
- code simpler and clearer as well.
-
-2007-07-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: More commentary.
- * tests/parseExpr.test: Several tests of syntax error messages
- to check that when expression substrings are truncated they leave
- visible the context relevant to the reported error.
-
-2007-07-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Factored out, corrected, and commented
- common code for reporting syntax errors in LEAF elements.
-
-2007-07-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileWhileCmd):
- * generic/tclCompile.c (TclCompileScript):
- Corrected faulty avoidance of INST_START_CMD when the first opcode in
- a script is within a loop (as produced by 'while 1'), so that the
- corresponding command is properly counted. [Bug 1752146]
-
-2007-07-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Added a "parseOnly" flag argument to
- ParseExpr() to indicate whether the caller is Tcl_ParseExpr(), with an
- end goal of filling a Tcl_Parse with Tcl_Tokens representing the
- parsed expression, or TclCompileExpr() with the goal of compiling and
- executing the expression. In the latter case, more aggressive
- conversion of QUOTED and BRACED lexeme to literals is done. In the
- former case, all such conversion is avoided, since Tcl_Token
- production would revert it anyway. This enables simplifications to the
- GenerateTokensForLiteral() routine as well.
-
-2007-07-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Added a field for operator precedence
- to be stored directly in the parse tree. There's no memory cost to
- this addition, since that memory would have been lost to alignment
- issues anyway. Also, converted precedence definitions and lookup
- tables to use symbolic constants instead of raw number for improved
- readability, and continued extending/improving/correcting comments.
- Removed some unused counter variables. Renamed some variables for
- clarity and replaced some cryptic logic with more readable macros.
-
-2007-07-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Revision so that the END lexeme never
- gets inserted into the parse tree. Later tree traversal never reaches
- it since its location in the tree is not variable. Starting and
- stopping with the START lexeme (node 0) is sufficient. Also finished
- lexeme code commentary.
-
- * generic/tclCompExpr.c: Added missing creation and return of
- the Tcl_Parse fields that indicate error conditions. [Bug 1749987]
-
-2007-07-05 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl (unknown): Corrected inconsistent error message
- in interactive [unknown] when empty command is invoked. [Bug 1743676]
-
-2007-07-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (SetNsNameFromAny):
- * generic/tclObj.c (SetCmdNameFromAny): Avoid unnecessary
- ckfree/ckalloc when the old structs can be reused.
-
-2007-07-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c: Fix case where a FQ cmd or ns was being cached
- * generic/tclObj.c: in a different interp, tkcon. [Bug 1747512]
-
-2007-07-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Revised #define values so that there
- is now more expansion room to define more BINARY operators.
-
-2007-07-02 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclHash.c (CompareStringKeys): Always use the strcmp()
- version; the operation is functionally equivalent, the speed is
- identical (up to measurement limitations), and yet the code is
- simpler. [FRQ 951168]
-
-2007-07-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Removed TCL_PRESERVE_BINARY_COMPATIBILITY and
- * generic/tclHash.c: any code enabled when it is set to 0. We will
- * generic/tclStubInit.c: always want to preserve binary compat
- of the structs that appear in the interface through the 8.* series of
- releases, so it's pointless to drag around this never-enabled
- alternative.
-
- * generic/tclIO.c: Removed dead code.
- * unix/tclUnixChan.c:
-
- * generic/tclCompExpr.c: Removed dead code, old implementations
- * generic/tclEvent.c: of expr parsing and compiling, including the
- * generic/tclInt.h: routine TclFinalizeCompilation().
-
-2007-06-30 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Plug a memory leak caused by a
- missing Tcl_DecrRefCount on an error path. [Bug 1717186]
-
-2007-06-30 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclThread.c: Prevent RemeberSyncObj() from growing the sync
- object lists by reusing already free'd slots, if possible. See
- discussion on Bug 1726873 for more information.
-
-2007-06-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/DictObj.3 (Tcl_DictObjDone): Improved documentation of this
- function to make it clearer how to use it. [Bug 1710795]
-
-2007-06-29 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclAlloc.c: on Darwin, ensure memory allocated by
- * generic/tclThreadAlloc.c: the custom TclpAlloc()s is aligned to
- 16 byte boundaries (as is the case with the Darwin system malloc).
-
- * generic/tclGetDate.y: use ckalloc/ckfree instead of malloc/free.
- * generic/tclDate.c: bison 1.875e
-
- * generic/tclBasic.c (TclEvalEx): fix warnings.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: better support for renamed tcl
- * macosx/Tcl.xcodeproj/default.pbxuser: source dir; add 10.5 SDK build
- * macosx/Tcl-Common.xcconfig: config; remove tclMathOp.c.
-
- * macosx/README: document Tcl.xcodeproj changes.
-
-2007-06-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Removed dead code, including the
- * generic/tclExecute.c: entire file tclMathOp.c.
- * generic/tclInt.h:
- * generic/tclMathOp.c (removed):
- * generic/tclTestObj.c:
- * win/tclWinFile.c:
-
- * unix/Makefile.in: Updated to reflect deletion of tclMathOp.c.
- * win/Makefile.in:
- * win/makefile.bc:
- * win/makefile.vc:
-
-2007-06-28 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclBasic.c: Silence constness warnings for TclStackFree
- * generic/tclCompCmds.c: when building with msvc.
- * generic/tclFCmd.c:
- * generic/tclIOCmd.c:
- * generic/tclTrace.c:
-
-2007-06-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (UnsetVarStruct): fix possible segfault.
-
-2007-06-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c: Corrected broken trace reversal logic in
- * generic/tclTest.c: TclCheckInterpTraces that led to infinite loop
- * tests/trace.test: when multiple Tcl_CreateTrace traces were set
- and one of them did not fire due to level restrictions. [Bug 1743931]
-
-2007-06-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclEvalEx): Moved some arrays from the C
- stack to the Tcl stack.
-
-2007-06-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (UnsetVarStruct): more streamlining.
-
-2007-06-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Safety checks to avoid crashes in the
- TclStack* routines when called with an incompletely initialized
- interp. [Bug 1743302]
-
-2007-06-25 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (UnsetVarStruct): fixing incomplete change, more
- streamlining.
-
-2007-06-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclDeleteCompiledLocalVars): removed inlining that
- ended up not really optimising (limited benchmarks). Now calling
- UnsetVarStruct (streamlined old code is #ifdef'ed out, in case better
- benchmarks do show a difference).
-
- * generic/tclVar.c (UnsetVarStruct): fixed a leak introduced in last
- commit.
-
-2007-06-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (UnsetVarStruct, TclDeleteVars): made the logic
- slightly clearer, eliminated some duplicated code.
-
- *** POTENTIAL INCOMPATIBILITY *** (tclInt.h and Var struct users)
- The core never builds VAR_LINK variable to have traces. Such a
- "monster", should one exist, will now have its unset traces called
- *before* it is unlinked.
-
-2007-06-23 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c (AtForkChild): don't call CoreFoundation
- APIs after fork() on systems where that would lead to an abort().
-
-2007-06-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Revised TclStackRealloc() signature to better
- * generic/tclInt.h: parallel (and fall back on) Tcl_Realloc.
-
- * generic/tclNamesp.c (TclResetShadowesCmdRefs): Replaced
- ckrealloc based allocations with TclStackRealloc allocations.
-
- * generic/tclCmdIL.c: More conversions to use TclStackAlloc.
- * generic/tclScan.c:
-
-2007-06-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Move most instances of the Tcl_Parse struct
- * generic/tclCompExpr.c: off the C stack and onto the Tcl stack. This
- * generic/tclCompile.c: is a rather large struct (> 3kB).
- * generic/tclParse.c:
-
-2007-06-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TEOvI): Made sure that leave traces
- * generic/tclExecute.c (INST_INVOKE): that were created during
- * tests/trace.test (trace-36.2): execution of an originally
- untraced command do not fire [Bug 1740962], partial fix.
-
-2007-06-21 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tcl.h, generic/tclCompile.h, generic/tclCompile.c: Remove
- references in comments to obsolete {expand} notation. [Bug 1740859]
-
-2007-06-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c: streamline namespace vars deletion: only compute
- the variable's full name if the variable is traced.
-
-2007-06-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.decls: Revised the interfaces of the routines
- * generic/tclExecute.c: TclStackAlloc and TclStackFree to make them
- easier for callers to use (or more precisely, harder to misuse).
- TclStackFree now takes a (void *) argument which is the pointer
- intended to be freed. TclStackFree will panic if that's not actually
- the memory the call will free. TSA/TSF also now tolerate receiving
- (interp == NULL), in which case they simply fall back to be calls to
- Tcl_Alloc/Tcl_Free.
-
- * generic/tclIntDecls.h: make genstubs
-
- * generic/tclBasic.c: Updated callers
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCompCmds.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclFCmd.c:
- * generic/tclFileName.c:
- * generic/tclIOCmd.c:
- * generic/tclIndexObj.c:
- * generic/tclInterp.c:
- * generic/tclNamesp.c:
- * generic/tclProc.c:
- * generic/tclTrace.c:
- * unix/tclUnixPipe.c:
-
-2007-06-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/tcltk-man2html.tcl: revamp of html doc output to use CSS,
- standardized headers, subheaders, dictionary sorting of names.
-
-2007-06-18 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/tcltk-man2html.tcl: clean up copyright merging and output.
- clean up coding constructs.
-
-2007-06-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL.c (InfoFrameCmd):
- * generic/tclCmdMZ.c (Tcl_SwitchObjCmd):
- * generic/tclCompile.c (TclInitCompileEnv):
- * generic/tclProc.c (Tcl_ProcObjCmd, SetLambdaFromAny): Moved the
- CmdFrame off the C stack and onto the Tcl stack.
-
- * generic/tclExecute.c (TEBC): Moved the CmdFrame off the C stack and
- onto the Tcl stack, between the catch and the execution stacks
-
-2007-06-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclEvalEx,TclEvalObjEx): Moved the CmdFrame off
- the C stack and onto the Tcl stack.
-
-2007-06-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (TclObjInterpProcCore): Minor fixes to make
- * generic/tclExecute.c (TclExecuteByteCode): compilation debugging
- builds work again. [Bug 1738542]
-
-2007-06-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (TclObjInterpProcCore): Use switch instead of a
- chain of if's for a modest performance gain and a little more clarity.
-
-2007-06-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c: Simplified [variable] compiler and executor.
- * generic/tclExecute.c: Missed updates to "there is always a valid
- frame".
-
- * generic/tclCompile.c: reverted TclEvalObjvInternal and INST_INVOKE
- * generic/tclExecute.c: to essentially what they were previous to the
- * generic/tclBasic.c: commit of 2007-04-03 [Patch 1693802] and the
- subsequent optimisations, as they break the new trace tests described
- below.
-
- * generic/trace.test: added tests 36 to 38 for dynamic trace creation
- and addition. These tests expose a change in dynamics due to a recent
- round of optimisations. The "correct" behaviour is not described in
- docs nor TIP 62.
-
-2007-06-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.decls: Modif to the internals of TclObjInterpProc
- * generic/tclInt.h: to reduce stack consumption and improve task
- * generic/tclIntDecls.h: separation. Changes the interface of
- * generic/tclProc.c: TclObjInterpProcCore (patching TclOO
- simultaneously).
-
- * generic/tclProc.c (TclObjInterpProcCore): simplified obj management
- in wrongNumArgs calls.
-
-2007-06-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: SetByteCodeFromAny() can no longer return any
- * generic/tclExecute.c: code other than TCL_OK, so remove code that
- * generic/tclProc.c: formerly handled exceptional codes.
-
-2007-06-13 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TclCompEvalObj): missed update to "there is
- always a valid frame".
-
- * generic/tclProc.c (TclObjInterpProcCore): call TEBC directly instead
- of going through TclCompEvalObj - no need to check the compilation's
- freshness, this has already been done. This improves speed and should
- also provide some relief to [Bug 1066755].
-
-2007-06-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclBasic.c (Tcl_CreateInterp): Turn the [info] command into
- * generic/tclCmdIL.c (TclInitInfoCmd): an ensemble, making it easier
- for third-party code to plug into.
-
- * generic/tclIndexObj.c (Tcl_WrongNumArgs):
- * generic/tclNamesp.c, generic/tclInt.h (tclEnsembleCmdType): Make
- Tcl_WrongNumArgs do replacement correctly with ensembles and other
- sorts of complex replacement strategies.
-
-2007-06-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: comments added to explain iPtr->numLevels
- management.
-
- * generic/tclNamesp.c: tweaks to Tcl_GetCommandFromObj and
- * generic/tclObj.c: TclGetNamespaceFromObj; modified the usage of
- structs ResolvedCmdName and ResolvedNsname so that the field refNsPtr
- is NULL for fully qualified names.
-
-2007-06-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Further TEOvI split, creating a new
- * generic/tclCompile.h: TclEvalObjvKnownCommand() function to handle
- * generic/tclExecute.c: commands that are already known and are not
- traced. INST_INVOKE now calls into this function instead of inlining
- parts of TEOvI. Same perf, better isolation.
-
- ***POTENTIAL INCOMPAT*** There is a subtle issue with the timing of
- execution traces that is changed here - first change appeared in my
- commit of 2007-04-03 [Patch 1693802], which caused some divergence
- between compiled and non-compiled code.
- ***THIS CHANGE IS UNDER REVIEW***
-
-2007-06-10 Jeff Hobbs <jeffh@ActiveState.com>
-
- * README: updated links. [Bug 1715081]
-
- * generic/tclExecute.c (TclExecuteByteCode): restore support for
- INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 bytecodes to support 8.4-
- precompiled sources (math functions). [Bug 1720895]
-
-2007-06-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclvar.c: new macros TclGetCurrentNamespace() and
- TclGetGlobalNamespace(); Tcl_GetCommandFromObj and
- TclGetNamespaceFromObj rewritten to make the logic clearer; slightly
- faster too.
-
-2007-06-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_INVOKE): isolated two vars to the small
- block where they are actually used.
-
- * generic/tclObj.c (Tcl_GetCommandFromObj): rewritten to make the
- logic clearer; slightly faster too.
-
- * generic/tclBasic.c: Split TEOv in two, by separating a processor
- for non-TCL_OK returns. Also split TEOvI in a full version that
- handles non-existing and traced commands, and a separate shorter
- version for the regular case.
-
- * generic/tclBasic.c: Moved the generation of command strings for
- * generic/tclTrace.c: traces: previously in Tcl_EvalObjv(), now in
- TclCheck[Interp|Execution]Traces(). Also insured that the strings are
- properly NUL terminated at the correct length. [Bug 1693986]
-
- ***POTENTIAL INCOMPATIBILITY in internal API***
- The functions TclCheckInterpTraces() and TclCheckExecutionTraces() (in
- internal stubs) used to be noops if the command string was NULL, this
- is not true anymore: if the command string is NULL, they generate an
- appropriate string from (objc,objv) and use it to call the traces. The
- caller might as well not call them with a NULL string if he was
- expecting a noop.
-
- * generic/tclBasic.c: Extend usage of TclLimitReady() and
- * generic/tclExecute.c: (new) TclLimitExceeded() macros.
- * generic/tclInt.h:
- * generic/tclInterp.c:
-
- * generic/tclInt.h: New TclCleanupCommandMacro for core usage.
- * generic/tclBasic.c:
- * generic/tclExecute.c:
- * generic/tclObj.c:
-
-2007-06-09 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add new Tclsh-Info.plist.in.
-
-2007-06-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Changed [string first] and
- * doc/string.n: [string last] so that they have clearer descriptions
- for those people who know the adage about needles and haystacks. This
- follows suggestions on comp.lang.tcl...
-
-2007-06-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c: fix for uninit read. [Bug 1732414]
-
-2007-06-06 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add settings for Fix&Continue.
-
- * unix/configure.in (Darwin): add plist for tclsh; link the
- * unix/Makefile.in (Darwin): Tcl and tclsh plists into
- * macosx/Tclsh-Info.plist.in (new): their binaries in all cases.
- * macosx/Tcl-Common.xcconfig:
-
- * unix/tcl.m4 (Darwin): fix CF checks in fat 32&64bit builds.
- * unix/configure: autoconf-2.59
-
-2007-06-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Added interp flag value ERR_LEGACY_COPY to
- * generic/tclInt.h: control the timing with which the global
- * generic/tclNamesp.c: variables ::errorCode and ::errorInfo get
- * generic/tclProc.c: updated after an error. This keeps more
- * generic/tclResult.c: precise compatibility with Tcl 8.4.
- * tests/result.test (result-6.2): [Bug 1649062]
-
-2007-06-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.h:
- * generic/tclExecute.c: Tcl-stack reform, [Patch 1701202]
-
-2007-06-03 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: add datarootdir to silence autoconf-2.6x warning.
-
-2007-05-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Removed code that dealt with
- * generic/tclCompile.c: TCL_TOKEN_EXPAND_WORD tokens representing
- * generic/tclCompile.h: expanded literal words. These sections were
- mostly in place to enable [info frame] to discover line information in
- expanded literals. Since the parser now generates a token for each
- post-expansion word referring to the right location in the original
- script string, [info frame] gets all the data it needs.
-
- * generic/tclInt.h: Revised the parser so that it never produces
- * generic/tclParse.c: TCL_TOKEN_EXPAND_WORD tokens when parsing an
- * tests/parse.test: expanded literal word; that is, something like
- {*}{x y z}. Instead, generate the series of TCL_TOKEN_SIMPLE_WORD
- tokens to represent the words that expansion of the literal string
- produces. [RFE 1725186]
-
-2007-05-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixThrd.c (Tcl_JoinThread): fix for 64-bit handling of
- pthread_join exit return code storage. [Bug 1712723]
-
-2007-05-22 Don Porter <dgp@users.sourceforge.net>
-
- [core-stabilizer-branch]
-
- * unix/configure: autoconf-2.59 (FC6 fork)
- * win/configure:
-
- * README: Bump version number to 8.5b1
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
-2007-05-18 Don Porter <dgp@users.sourceforge.net>
-
- * unix/configure: autoconf-2.59 (FC6 fork)
- * win/configure:
-
- * README: Bump version number to 8.5a7
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * generic/tclParse.c: Disable and remove the ALLOW_EXPAND sections
- * tests/info.test: that continued to support the deprecated
- * tests/mathop.test: {expand} syntax. Updated the few remaining
- users of that syntax in the test suite.
-
-2007-05-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TclLimitReady): Created a macro version of
- Tcl_LimitReady just for TEBC, to reduce the amount of times that the
- bytecode engine calls out to external functions on the critical path.
- * generic/tclInterp.c (Tcl_LimitReady): Added note to remind anyone
- doing maintenance that there is a macro version to update.
-
-2007-05-17 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.decls: workaround 'make checkstubs' failures from
- tclStubLib.c MODULE_SCOPE revert. [Bug 1716117]
-
-2007-05-16 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclStubLib.c: Change Tcl_InitStubs(), tclStubsPtr, and the
- auxilliary stubs table pointers back to public visibility.
-
- These symbols need to be exported so that stub-enabled extensions may
- be statically linked into an extended tclsh or Big Wish with a
- dynamically-linked libtcl. [Bug 1716117]
-
-2007-05-15 Don Porter <dgp@users.sourceforge.net>
-
- * win/configure: autoconf-2.59 (FC6 fork)
-
- * library/reg/pkgIndex.tcl: Bump to registry 1.2.1 to account for
- * win/configure.in: [Bug 1682211] fix.
- * win/makefile.bc:
- * win/tclWinReg.c:
-
-2007-05-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclInt.h: Removed TclEvalObjEx and TclGetSrcInfoForPc from
- tclInt.h now they are in the internal stubs table.
-
-2007-05-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: TclFinalizeThreadAlloc() is always defined, so
- make sure it is also always declared (with MODULE_SCOPE).
-
-2007-05-09 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: fix warning when building threaded with -DPURIFY.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add 'DebugUnthreaded' &
- * macosx/Tcl.xcodeproj/default.pbxuser: 'DebugLeaks' configs and env
- var settings needed to run the 'leaks' tool.
-
-2007-05-07 Don Porter <dgp@users.sourceforge.net>
-
- [Tcl Bug 1706140]
-
- * generic/tclLink.c (LinkTraceProc): Update Tcl_VarTraceProcs so
- * generic/tclNamesp.c (Error*Read): they call Tcl_InterpDeleted()
- * generic/tclTrace.c (Trace*Proc): for themselves, and do not
- * generic/tclUtil.c (TclPrecTraceProc): rely on (frequently buggy)
- setting of the TCL_INTERP_DESTROYED flag by the trace core.
-
- * generic/tclVar.c: Update callers of TclCallVarTraces to not pass
- in the TCL_INTERP_DESTROYED flag. Also apply filters so that public
- routines only pass documented flag values down to lower level routines
-
- * generic/tclTrace.c (TclCallVarTraces): The setting of the
- TCL_INTERP_DESTROYED flag is now done entirely within the
- TclCallVarTraces routine, the only place it can be done right.
-
-2007-05-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h (ExtraFrameInfo): Create a new mechanism for
- * generic/tclCmdIL.c (InfoFrameCmd): conveying what information needs
- to be added to the results of [info frame] to replace the hack that
- was there before.
- * generic/tclProc.c (Tcl_ApplyObjCmd): Use the new mechanism for the
- [apply] command, the only part of Tcl itself that needs it (so far).
-
- * generic/tclInt.decls (TclEvalObjEx, TclGetSrcInfoForPc): Expose
- these two functions through the internal stubs table, necessary for
- extensions that need to integrate deeply with TIP#280.
-
-2007-05-05 Donal K. Fellows <dkf@users.sf.net>
-
- * win/tclWinFile.c (TclpGetUserHome): Squelch type-pun warnings in
- * win/tclWinInit.c (TclpSetVariables): Win-specific code not found
- * win/tclWinReg.c (AppendSystemError): during earlier work on Unix.
-
-2007-05-04 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclIO.c (TclFinalizeIOSubsystem): Added an initializer to
- silence a spurious gcc warning about use of an uninitialized
- variable.
- * tests/encoding.test: Modified so that encoding tests happen in a
- private namespace, to avoid polluting the global one. This problem was
- discovered when running the test suite '-singleproc 1 -skip exec.test'
- because the 'path' variable in encoding.test conflicted with the one
- in io.test.
- * tests/io.test: Made more of the working variables private to the
- namespace.
-
-2007-05-02 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclTest.c (SimpleMatchInDirectory): Corrected a refcount
- imbalance that affected the filesystem-[147]* tests in the test suite.
- Thanks to Don Porter for the patch. [Bug 1710707]
- * generic/tclPathObj.c (Tcl_FSJoinPath, Tcl_FSGetNormalizedPath):
- Corrected several memory leaks that caused refcount imbalances
- resulting in memory leaks on Windows. Thanks to Joe Mistachkin for the
- patch.
-
-2007-05-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclPtrSetVar): fixed leak whenever newvaluePtr had
- refCount 0 and was used for appending (but not lappending). Thanks to
- mistachkin and kbk. [Bug 1710710]
-
-2007-05-01 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclIO.c (DeleteChannelTable): Made changes so that
- DeleteChannelTable tries to close all open channels, not just the
- first. [Bug 1710285]
- * generic/tclThread.c (TclFinalizeSynchronization): Make sure that TSD
- blocks get freed on non-threaded builds. [Bug 1710825]
- * tests/utf.test (utf-25.1--utf-25.4): Modified tests to clean up
- after the 'testobj' extension to avoid spurious reports of memory
- leaks.
-
-2007-05-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (STR_MAP): When [string map] has a pure dict map,
- a missing Tcl_DictObjDone() call led to a memleak. [Bug 1710709]
-
-2007-04-30 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: add 'tclsh' dependency to install targets that
- rely on tclsh, fixes parallel 'make install' from empty build dir.
-
-2007-04-30 Andreas Kupries <andreask@gactivestate.com>
-
- * generic/tclIO.c (FixLevelCode): Corrected reference count
- mismanagement of newlevel, newcode. Changed to allocate the Tcl_Obj's
- as late as possible, and only when actually needed. [Bug 1705778, leak
- K29]
-
-2007-04-30 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclProc.c (Tcl_ProcObjCmd, SetLambdaFromAny): Corrected
- reference count mismanagement on the name of the source file in the
- TIP 280 code. [Bug 1705778, leak K02 among other manifestations]
-
-2007-04-25 Donal K. Fellows <dkf@users.sf.net>
-
- *** 8.5a6 TAGGED FOR RELEASE ***
-
- * generic/tclProc.c (TclObjInterpProcCore): Only allocate objects for
- error message generation when associated with argument names that are
- really used. [Bug 1705778, leak K15]
-
-2007-04-25 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclIOUtil.c (Tcl_FSChdir): Changed the memory management so
- that the path returned from Tcl_FSGetNativePath is not duplicated
- before being stored as the current directory, to avoid a memory leak.
- [Bug 1705778, leak K01 among other manifestations]
-
-2007-04-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c (ParseExpr): Revised to be sure that an
- error return doesn't prevent all literals getting placed on the
- litList to be returned to the caller for freeing. Corrects some
- memleaks. [Bug 1705778, leak K23]
-
-2007-04-25 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in (dist): add macosx/*.xcconfig files to src dist;
- copy license.terms to dist macosx dir; fix autoheader bits.
-
-2007-04-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclListObj.c: reverting [Patch 738900] (committed on
- 2007-04-20). Causes some Tk test breakage of unknown importance, but
- the impact of the patch itself is likely to be so small that it does
- not warrant investigation at this time.
-
-2007-04-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictKeysCmd): Rewrote so that the lock on the
- internal representation of a dict is only set when necessary. [Bug
- 1705778, leak K04]
- (DictFilterCmd): Added code to drop the lock in the trivial match
- case. [Bug 1705778, leak K05]
-
-2007-04-24 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclBinary.c: Addressed several code paths where the error
- return from the 'binary format' command leaked the result buffer.
- * generic/tclListObj.c (TclLsetFlat): Fixed a bug where the new list
- under construction was leaked in the error case. [Bug 1705778, leaks
- K13 and K14]
-
-2007-04-24 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in (dist): add platform library package to src dist
-
-2007-04-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c (ParseExpr): Memory leak in error case; the
- literal Tcl_Obj was not getting freed. [Bug 1705778, leak #1 (new)]
-
- * generic/tclNamesp.c (Tcl_DeleteNamespace): Corrected flaw in the
- flag marking scheme to be sure that global namespaces are freed when
- their interp is deleted. [Bug 1705778]
-
-2007-04-24 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c (TclExecuteByteCode): Plugged six memory leaks
- in bignum arithmetic.
- * generic/tclIOCmd.c (Tcl_ReadObjCmd): Plugged a leak of the buffer
- object if the physical read returned an error and the bypass area had
- no message.
- * generic/tclIORChan.c (TclChanCreateObjCmd): Plugged a leak of the
- return value from the "initialize" method of a channel handler.
- (All of the above under [Bug 1705778])
-
-2007-04-23 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclCkalloc.c: fix warnings from gcc build configured with
- * generic/tclCompile.c: --enable-64bit --enable-symbols=all.
- * generic/tclExecute.c:
-
- * unix/tclUnixFCmd.c: add workaround for crashing bug in fts_open()
- * unix/tclUnixInit.c: without FTS_NOSTAT on 64bit Darwin 8 or earlier.
-
- * unix/tclLoadDyld.c (TclpLoadMemory): fix (void*) arithmetic.
-
- * macosx/Tcl-Common.xcconfig: enable more warnings.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add 'DebugMemCompile' build
- configuration that calls configure with --enable-symbols=all; override
- configure check for __attribute__((__visibility__("hidden"))) in Debug
- configuration to restore availability of ZeroLink.
-
- * macosx/tclMacOSXNotify.c: fix warnings.
-
- * macosx/tclMacOSXFCmd.c: const fixes.
-
- * macosx/Tcl-Common.xcconfig: fix whitespace.
- * macosx/Tcl-Debug.xcconfig:
- * macosx/Tcl-Release.xcconfig:
- * macosx/README:
-
- * macosx/GNUmakefile: fix/add copyright and license refs.
- * macosx/tclMacOSXBundle.c:
- * macosx/Tcl-Info.plist.in:
- * macosx/Tcl.xcode/project.pbxproj:
- * macosx/Tcl.xcodeproj/project.pbxproj:
-
- * unix/configure.in: install license.terms into Tcl.framework.
- * unix/configure: autoconf-2.59
-
-2007-04-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclVar.c (UnsetVarStruct): Make sure the
- TCL_INTERP_DESTROYED flags gets passed to unset trace routines so they
- can respond appropriately. [Bug 1705778, leak #9]
-
-2007-04-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclFreeCompileEnv): Tip 280's new field
- extCmdMapPtr was not being freed. [Bug 1705778, leak #1]
-
-2007-04-23 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclCompCmds.c (TclCompileUpvarCmd): Plugged a memory leak in
- 'upvar' when compiling (a) upvar outside a proc, (b) upvar with a
- syntax error, or (c) upvar where the frame index is not known at
- compile time.
- * generic/tclCompExpr.c (ParseExpr): Plugged a memory leak when
- parsing expressions that contain syntax errors.
- * generic/tclEnv.c (ReplaceString): Clear memory correctly when
- growing the cache to avoid reads of uninitialised data.
- * generic/tclIORChan.c (TclChanCreateObjCmd, FreeReflectedChannel):
- Plugged two memory leaks.
- * generic/tclStrToD.c (AccumulateDecimalDigit): Fixed a mistake where
- we'd run beyond the end of the 'pow10_wide' array if a number begins
- with a string of more than 'maxpow10_wide' zeroes.
- * generic/tclTest.c (Testregexpobjcmd): Removed an invalid access
- beyond the end of 'objv' in 'testregexp -about'.
- All of these issues reported under [Bug 1705778] - detected with the
- existing test suite, no new regression tests required.
-
-2007-04-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclDeleteNamespaceVars): fixed access to freed
- memory detected by valgrind: Tcl_GetCurrentNamespace was being
- called after freeing root CallFrame (on interp deletion).
-
-2007-04-20 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclListObj.c (SetListFromAny): avoid discarding internal
- reps of objects converted to singleton lists. [Patch 738900]
-
-2007-04-20 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Corrected a silly error (transposed 'uppercase' and
- 'lowercase' in clock.n. [Bug 1656002]
- Clarified that [clock scan] does not recognize a locale's alternative
- calendar.
- Deleted an entirely superfluous (and also incorrect) remark about the
- effect of Daylight Saving Time on relative times in [clock scan]. [Bug
- 1582951]
- * library/clock.tcl: Corrected an error in skipping over the %Ey field
- on input.
- * library/msgs/ja.msg:
- * tools/loadICU.tcl: Corrected several localisation faults in the
- Japanese locale (most notably, incorrect dates for the Emperors'
- eras). Many thanks to SourceForge user 'nyademo' for pointing this out
- and developing a fix. [Bug 1637471]
- * generic/tclPathObj.c: Corrected a 'const'ness fault that caused
- bitter complaints from MSVC.
- * tests/clock.test (clock-40.1, clock-58.1, clock-59.1): Corrected a
- test case that depended on ":localtime" being able to handle dates
- prior to the Posix epoch. [Bug 1618445] Added a test case for the
- dates of the Japanese emperors. [Bug 1637471] Added a regression test
- for military time zone input conversion. [Bug 1586828]
- * generic/tclGetDate.y (MilitaryTable): Fixed an ancient bug where the
- military NZA time zones had the signs reversed. [Bug 1586828]
- * generic/tclDate.c: Regenerated.
- * doc/Notifier.3: Documented Tcl_SetNotifier and Tcl_ServiceModeHook.
- Quite against my better judgment. [Bug 414933]
- * generic/tclBasic.c, generic/tclCkalloc.c, generic/tclClock.c:
- * generic/tclCmdIL.c, generic/tclCmdMZ.c, generic/tclFCmd.c:
- * generic/tclFileName.c, generic/tclInterp.c, generic/tclIO.c:
- * generic/tclIOUtil.c, generic/tclNamesp.c, generic/tclObj.c:
- * generic/tclPathObj.c, generic/tclPipe.c, generic/tclPkg.c:
- * generic/tclResult.c, generic/tclTest.c, generic/tclTestObj.c:
- * generic/tclVar.c, unix/tclUnixChan.c, unix/tclUnixTest.c:
- * win/tclWinLoad.c, win/tclWinSerial.c: Replaced commas in varargs
- with string concatenation where possible. [Patch 1515234]
- * library/tzdata/America/Tegucigalpa:
- * library/tzdata/Asia/Damascus: Olson's tzdata 2007e.
-
-2007-04-19 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/regcomp.c, generic/regc_cvec.c, generic/regc_lex.c,
- * generic/regc_locale.c: Improve the const-correctness of the RE
- compiler.
-
-2007-04-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_LSHIFT): fixed a mistake introduced in
- version 1.266 ('=' became '=='), which effectively turned the block
- that handles native shifts into dead code. This explains why the
- testsuite did not pick this mistake. Rewrote to make the intention
- clear.
-
- * generic/tclInt.h (TclDecrRefCount): change the order of the
- branches, use empty 'if ; else' to handle use in unbraced outer
- if/else conditions (as already done in tcl.h)
-
- * generic/tclExecute.c: slight changes in Tcl_Obj management.
-
-2007-04-17 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Fixed the naming of
- ::tcl::clock::ReadZoneinfoFile because (yoicks!) it was in the global
- namespace.
- * doc/clock.n: Clarified the cases in which legacy time zone is
- recognized. [Bug 1656002]
-
-2007-04-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: fixed checkInterp logic [Bug 1702212]
-
-2007-04-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * various (including generic/tclTest.c): Complete the purge of K&R
- function definitions from manually-written code.
-
-2007-04-15 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclCompCmds.c: added a cast to silence a compiler error on
- VC2005.
- * library/clock.tcl: Restored unique-prefix matching of keywords on
- the [clock] command. [Bug 1690041]
- * tests/clock.test: Added rudimentary test cases for unique-prefix
- matching of keywords.
-
-2007-04-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: removed some code at INST_EXPAND_SKTOP that
- duplicates functionality already present at checkForCatch.
-
-2007-04-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: new macros OBJ_AT_TOS, OBJ_UNDER_TOS,
- OBJ_AT_DEPTH(n) and CURR_DEPTH that remove all direct references to
- tosPtr from TEBC (after initialisation and the code at the label
- cleanupV_pushObjResultPtr).
-
-2007-04-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompCmds.c: moved all exceptDepth management to the
- macros - the decreasing half was managed by hand.
-
-2007-04-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclInt.h (TclNewLiteralStringObj): New macro to make
- allocating literal string objects (i.e. objects whose value is a
- constant string) easier and more efficient, by allowing the omission
- of the length argument. Based on [Patch 1529526] (afredd)
- * generic/*.c: Make use of this (in many files).
-
-2007-04-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile (tclInstructionTable): Fixed bugs in description
- of dict instructions.
-
-2007-04-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile (tclInstructionTable): Fixed bug in description
- of INST_START_COMMAND.
-
- * generic/tclExecute.c (TEBC): Small code reduction.
-
-2007-04-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (TEBC):
- * generic/tclNamespace.c (NsEnsembleImplementationCmd):
- * generic/tclProc.c (InitCompiledLocals, ObjInterpProcEx)
- (TclObjInterpProcCore, ProcCompileProc): Code reordering to reduce
- branching and improve branch prediction (assume that forward branches
- are typically not taken).
-
-2007-04-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: INST_INVOKE optimisation. [Patch 1693802]
-
-2007-04-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c: Revised ErrorCodeRead and ErrorInfoRead trace
- routines so they guarantee the ::errorCode and ::errorInfo variable
- always appear to exist. [Bug 1693252]
-
-2007-04-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.decls: Moved TclGetNamespaceFromObj() to the
- * generic/tclInt.h: internal stubs table; regen.
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
-2007-04-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Added bytecode compilers for the variable
- * generic/tclCompCmds.c: linking commands: 'global', 'variable',
- * generic/tclCompile.h: 'upvar', 'namespace upvar' [Patch 1688593]
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * generic/tclVar.c:
-
-2007-04-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Replace arrays on the C stack and ckalloc
- * generic/tclExecute.c: calls with TclStackAlloc calls to use memory
- * generic/tclFCmd.c: on Tcl's evaluation stack.
- * generic/tclFileName.c:
- * generic/tclIOCmd.c:
- * generic/tclIndexObj.c:
- * generic/tclInterp.c:
- * generic/tclNamesp.c:
- * generic/tclTrace.c:
- * unix/tclUnixPipe.c:
-
-2007-04-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompile.c (TclCompileScript, TclPrintInstruction):
- * generic/tclExecute.c (TclExecuteByteCode): Changed the definition of
- INST_START_CMD so that it knows how many commands start at the current
- location. This makes the interpreter command counter correct without
- requiring a large number of instructions to be issued. (See my change
- from 2007-01-19 for what triggered this.)
-
-2007-03-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c:
- * generic/tclCompExpr.c:
- * generic/tclCompCmds.c: Replace arrays on the C stack and
- ckalloc calls with TclStackAlloc calls to use memory on Tcl's
- evaluation stack.
-
- * generic/tclCmdMZ.c: Revised [string to* $s $first $last]
- implementation to reduce number of allocs/copies.
-
- * tests/string.test: More [string reverse] tests.
-
-2007-03-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: optimise the lookup of elements of indexed
- arrays.
-
-2007-03-29 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (Tcl_ApplyObjCmd):
- * tests/apply.test (9.3): Fixed Tcl_Obj leak on error return; an
- unneeded ref to lambdaPtr was being set and not released on an error
- return path.
-
-2007-03-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (STR_REVERSE): Implement the actual [string
- reverse] command in terms of the new TclStringObjReverse() routine.
-
- * generic/tclInt.h (TclStringObjReverse): New internal routine
- * generic/tclStringObj.c (TclStringObjReverse): that implements the
- [string reverse] operation, making use of knowledge/surgery of the
- String intrep to minimize the number of allocs and copies needed to do
- the job.
-
-2007-03-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdMZ.c (STR_MAP): Replace ckalloc calls with
- TclStackAlloc calls.
-
-2007-03-24 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * win/tclWinThrd.c: Thread exit handler marks the current thread as
- uninitialized. This allows exit handlers that are registered later to
- reinitialize this subsystem in case they need to use some sync
- primitives (cond variables) from this file again.
-
-2007-03-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (DeleteInterpProc): pop the root frame pointer
- before deleting the global namespace [Bug 1658572]
-
-2007-03-23 Kevin B. Kenny <kennykb@acm.org>
-
- * win/Makefile.in: Added code to keep a Cygwin path name from leaking
- into LIBRARY_DIR when doing 'make test' or 'make runtest'.
-
-2007-03-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Replaced arrays on the
- C stack and ckalloc calls with TclStackAlloc calls to use memory on
- Tcl's evaluation stack.
-
- * generic/tclExecute.c: Revised GrowEvaluationStack to take an
- argument specifying the growth required by the caller, so that a
- single reallocation / copy is the most that will ever be needed even
- when required growth is large.
-
-2007-03-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: More ckalloc -> ckrealloc conversions.
- * generic/tclLiteral.c:
- * generic/tclNamesp.c:
- * generic/tclParse.c:
- * generic/tclPreserve.c:
- * generic/tclStringObj.c:
- * generic/tclUtil.c:
-
-2007-03-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEnv.c: Some more ckalloc -> ckrealloc replacements.
- * generic/tclLink.c:
-
-2007-03-20 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclDate.c: Rebuilt, despite Donal Fellows's comment when
- committing it that no rebuild was required.
- * generic/tclGetDate.y: According to Donal Fellows, "Introduce modern
- formatting standards; no need for rebuild of tclDate.c."
-
- * library/tzdata/America/Cambridge_Bay:
- * library/tzdata/America/Havana:
- * library/tzdata/America/Inuvik:
- * library/tzdata/America/Iqaluit:
- * library/tzdata/America/Pangnirtung:
- * library/tzdata/America/Rankin_Inlet:
- * library/tzdata/America/Resolute:
- * library/tzdata/America/Yellowknife:
- * library/tzdata/Asia/Choibalsan:
- * library/tzdata/Asia/Dili:
- * library/tzdata/Asia/Hovd:
- * library/tzdata/Asia/Jakarta:
- * library/tzdata/Asia/Jayapura:
- * library/tzdata/Asia/Makassar:
- * library/tzdata/Asia/Pontianak:
- * library/tzdata/Asia/Ulaanbaatar:
- * library/tzdata/Europe/Istanbul: Upgraded to Olson's tzdata2007d.
-
- * generic/tclListObj.c (TclLsetList, TclLsetFlat):
- * tests/lset.test: Changes to deal with shared internal representation
- for lists passed to the [lset] command. Thanks to Don Porter for
- fixing this issue. [Bug 1677512]
-
-2007-03-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Revise the various expansion routines for
- CompileEnv fields to use ckrealloc() where appropriate.
-
- * generic/tclBinary.c (Tcl_SetByteArrayLength): Replaced ckalloc() /
- memcpy() sequence with ckrealloc() call.
-
- * generic/tclBasic.c (Tcl_CreateMathFunc): Replaced some calls to
- * generic/tclEvent.c (Tcl_CreateThread): Tcl_Alloc() with calls
- * generic/tclObj.c (UpdateStringOfBignum): to ckalloc(), which
- * unix/tclUnixTime.c (SetTZIfNecessary): better supports memory
- * win/tclAppInit.c (setargv): debugging.
-
-2007-03-19 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/regsub.n: Corrected example so that it doesn't recommend
- potentially unsafe practice. Many thanks to Konstantin Kushnir
- <chpock@gmail.com> for reporting this.
-
-2007-03-17 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinReg.c (GetKeyNames): Size the buffer for enumerating key
- names correctly, so that Unicode names exceeding 127 chars can be
- retrieved without crashing. [Bug 1682211]
- * tests/registry.test (registry-4.9): Added test case for the above
- bug.
-
-2007-03-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIOUtil.c (Tcl_Stat): Reimplement workaround to avoid gcc
- warning by using local variables. When the macro argument is of type
- long long instead of long, the incorrect warning is not generated.
-
-2007-03-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * win/Makefile.in: Fully qualify LIBRARY_DIR so that `make test` does
- not depend on working dir.
-
-2007-03-15 Mo DeJong <mdejong@users.sourceforge.net>
-
- * tests/parse.test: Add two backslash newline parse tests.
-
-2007-03-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (INST_FOREACH_STEP4): Make private copy of
- * tests/foreach.test (foreach-10.1): value list to be assigned to
- variables so that shimmering of that list doesn't lead to invalid
- pointers. [Bug 1671087]
-
- * generic/tclEvent.c (HandleBgErrors): Make efficient private copy
- * tests/event.test (event-5.3): of the command prefix for the interp's
- background error handling command to avoid panics due to pointers to
- memory invalid after shimmering. [Bug 1670155]
-
- * generic/tclNamesp.c (NsEnsembleImplementationCmd): Make efficient
- * tests/namespace.test (namespace-42.8): private copy of the
- command prefix as we invoke the command appropriate to a particular
- subcommand of a particular ensemble to avoid panic due to shimmering
- of the List intrep. [Bug 1670091]
-
- * generic/tclVar.c (TclArraySet): Make efficient private copy of
- * tests/var.test (var-17.1): the "list" argument to [array set] to
- avoid crash due to shimmering invalidating pointers. [Bug 1669489]
-
-2007-03-12 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Fix problems with declaration
- positioning and memory leaks. [Bug 1679072]
-
-2007-03-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (Tcl_LreverseObjCmd): Ensure that a list is
- correctly reversed even if its internal representation is shared
- without the object itself being shared. [Bug 1675044]
-
-2007-03-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIL (Tcl_LsortObjCmd): changed fix to [Bug 1675116] to
- use the cheaper TclListObjCopy() instead of Tcl_DuplicateObj().
-
-2007-03-09 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/shell.tcl: Made more robust if an older platform
- * library/platform/pkgIndex.tcl: package is present in the inspected
- * unix/Makefile.in: shell. Package forget it to prevent errors. Bumped
- * win/Makefile.in: package version to 1.1.3, and updated the Makefiles
- installing it as Tcl Module.
-
-2007-03-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Handle tricky case with loss
- * tests/cmdIL.test (cmdIL-1.29): of list rep during sorting due
- to shimmering. [Bug 1675116]
-
-2007-03-09 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (ReadZoneinfoFile): Added Y2038 compliance to the
- code for version-2 'zoneinfo' files.
- * tests/clock.test (clock-56.3): Added a test case for Y2038 and
- 'zoneinfo'. Modified test initialisation to use the
- 'loadTestedCommands' function of tcltest to bring in the correct path
- for the registry library.
-
-2007-03-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclListObj.c (TclLsetList): Rewrite so that the routine
- itself does not do any direct intrep surgery. Better isolates those
- things into the implementation of the "list" Tcl_ObjType.
-
-2007-03-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclListObj.c (TclLindexList, TclLindexFlat): Moved these
- functions to tclListObj.c from tclCmdIL.c to mirror the way that the
- equivalent functions for [lset]'s guts are arranged.
-
-2007-03-08 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Further tweaks to the Windows time zone table
- (restoring missing Mexican time zones). Added rudimentary handling of
- version-2 'zoneinfo' files. Update US DST rules so that zones such as
- 'EST5EDT' get the correct transition dates.
- * tests/clock.test: Added rudimentary test cases for 'zoneinfo'
- parsing. Adjusted several tests that depended on obsolete US DST
- transition rules.
-
-2007-03-07 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c: add spinlock debugging and sanity checks.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: ensure gcc version used by
- * macosx/Tcl.xcodeproj/default.pbxuser: Xcode and configure/make are
- * macosx/Tcl-Common.xcconfig: consistent and independent of
- gcc_select default and CC env var; fixes for Xcode 3.0.
-
- * unix/tcl.m4 (Darwin): s/CFLAGS/CPPFLAGS/ in macosx-version-min check
- * unix/configure: autoconf-2.59
-
-2007-03-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdIL.c (TclLindex*): Rewrites to make efficient
- private copies of the list and indexlist arguments, so we can operate
- on the list elements directly with no fear of shimmering effects.
- Replaces defensive coding schemes that are otherwise required. End
- result is that TclLindexList is entirely a wrapper around
- TclLindexFlat, which is now the core engine of all [lindex]
- operations.
-
- * generic/tclObj.c (Tcl_AppendAllObjTypes): Converted to simpler
- list validity test.
-
-2007-03-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclRegexp.c (TclRegAbout): Generate information about a
- regexp as a Tcl_Obj instead of as a string, which is more efficient.
-
-2007-03-07 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl: Adjusted Windows time zone table to handle new US
- DST rules by locale rather than as Posix time zone spec.
- * tests/clock.test (clock-39.6, clock-49.2, testclock::registry):
- Adjusted tests to simulate new US rules.
- * library/tzdata/America/Indiana/Winamac:
- * library/tzdata/Europe/Istanbul:
- * library/tzdata/Pacific/Easter:
- Olson's tzdata2007c.
-
-2007-03-05 Andreas Kupries <andreask@activestate.com>
-
- * library/platform/shell.tcl (::platform::shell::RUN): In the case of
- * library/platform/pkgIndex.tcl: a failure put the captured stderr
- * unix/Makefile.in: into the error message to aid in debugging. Bumped
- * win/Makefile.in: package version to 1.1.2, and updated the makefiles
- installing it as Tcl Module.
-
-2007-03-03 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclLink.c (LinkedVar): Added macro to conceal at least some
- of the pointer hackery.
-
-2007-03-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdIL.c (Tcl_LreverseObjCmd): Added missing
- TclInvalidateStringRep() call when we directly manipulate the intrep
- of an unshared "list" Tcl_Obj. [Bug 1672585]
-
- * generic/tclCmdIL.c (Tcl_JoinObjCmd): Revised [join] implementation
- to append Tcl_Obj's instead of strings. [RFE 1669420]
-
- * generic/tclCmdIL.c (Info*Cmd): Code simplifications and
- optimizations.
-
-2007-03-02 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCompile.c (TclPrintInstruction): Added a scheme to allow
- * generic/tclCompile.h (AuxDataPrintProc): aux-data to be printed
- * generic/tclCompCmds.c (Print*Info): out for debugging. For
- this to work, immediate operands referring to aux-data must be
- identified as such in the instruction descriptor table using
- OPERAND_AUX4 (all are always 4 bytes).
-
- * generic/tclExecute.c (TclExecuteByteCode): Rewrote the compiled
- * generic/tclCompCmds.c (TclCompileDictCmd): [dict update] so that it
- * generic/tclCompile.h (DictUpdateInfo): stores critical
- * tests/dict.test (dict-21.{14,15}): non-varying data in an
- aux-data value instead of a (shimmerable) literal. [Bug 1671001]
-
-2007-03-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdIL.c (Tcl_LinsertObjCmd): Code simplifications
- and optimizations.
-
- * generic/tclCmdIL.c (Tcl_LreplaceObjCmd): Code simplifications
- and optimizations.
-
- * generic/tclCmdIL.c (Tcl_LrangeObjCmd): Rewrite in the same
- spirit; avoid shimmer effects rather than react to them.
-
- * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Stop throwing away
- * tests/foreach.test (foreach-1.14): useful error information when
- loop variable sets fail.
-
- * generic/tclCmdIL.c (Tcl_LassignObjCmd): Rewrite to make an
- efficient private copy of the list argument, so we can operate on the
- list elements directly with no fear of shimmering effects. Replaces
- defensive coding schemes that are otherwise required.
-
- * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Rewrite to make
- efficient private copies of the variable and value lists, so we can
- operate on them without any special shimmer defense coding schemes.
-
-2007-03-01 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileForeachCmd): Prevent an unexpected
- * tests/foreach.test (foreach-9.1): infinite loop when the
- variable list is empty and the foreach is compiled. [Bug 1671138]
-
-2007-02-26 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (FreeReflectedChannel): Added the missing
- refcount release between NewRC and FreeRC for the channel handle
- object, spotted by Don Porter. [Bug 1667990]
-
-2007-02-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Removed surplus
- copying of the objv array that used to be a workaround for [Bug
- 404865]. That bug is long fixed.
-
-2007-02-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Use new interface in Tcl_EvalObjEx so that the
- recounting logic of the List internal rep need not be repeated there.
- Better encapsulation of internal details.
-
- * generic/tclInt.h: New internal routine TclListObjCopy() used
- * generic/tclListObj.c: to efficiently do the equivalent of [lrange
- $list 0 end]. After some experience with this, might be a good
- candidate for exposure as a public interface. It's useful for callers
- of Tcl_ListObjGetElements() who want to control the ongoing validity
- of the returned objv pointer.
-
-2007-02-22 Andreas Kupries <andreask@activestate.com>
-
- * tests/pkg.test: Added tests for the case of an alpha package
- satisfying a require for the regular package, demonstrating a corner
- case specified in TIP#280. More notes in the comments to the test.
-
-2007-02-20 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Added "const" specifiers in TclSockGetPort
- * generic/tclIntDecls.h: regenerated
- * generic/*.c:
- * unix/tclUnixChan.c
- * unix/tclUnixPipe.c
- * win/tclWinPipe.c
- * win/tclWinSock.c: Added many "const" specifiers in implementation.
-
-2007-02-20 Don Porter <dgp@users.sourceforge.net>
-
- * doc/tcltest.n: Typo fix. [Bug 1663539]
-
-2007-02-20 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclFileName.c: Handle extended paths on Windows NT and
- * generic/tclPathObj.c: above. These have a \\?\ prefix. [Bug
- * win/tclWinFile.c: 1479814]
- * tests/winFCmd.test: Tests for extended path handling.
-
-2007-02-19 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tcl.m4: use SHLIB_SUFFIX=".so" on HP-UX ia64 arch.
- * unix/configure: autoconf-2.59
-
- * generic/tclIOUtil.c (Tcl_FSEvalFileEx): safe incr of objPtr ref.
-
-2007-02-18 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n, doc/clock.n, doc/eval.n, doc/exit.n, doc/expr.n:
- * doc/interp.n, doc/open.n, doc/platform_shell.n, doc/pwd.n:
- * doc/refchan.n, doc/regsub.n, doc/scan.n, doc/tclvars.n, doc/tm.n:
- * doc/unload.n: Apply [Bug 1610310] to fix typos. Thanks to Larry
- Virden for spotting them.
-
- * doc/interp.n: Partial fix of [Bug 1662436]; rest requires some
- policy decisions on what should and shouldn't be safe commands from
- the "new in 8.5" set.
-
-2007-02-13 Kevin B. Kenny <kennykb@acm.org>
-
- * tools/fix_tommath_h.tcl: Further tweaking for the x86-64. The change
- is to make 'mp_digit' be an 'unsigned int' on that platform; since
- we're using only 32 bits of it, there's no reason to make it a 64-bit
- 'unsigned long.'
- * generic/tclTomMath.h: Regenerated.
-
-2007-02-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/re_syntax.n: Corrected description of 'print' class [Bug
- 1614687] and enhanced description of 'graph' class.
-
-2007-02-12 Kevin B. Kenny <kennykb@acm.org>
-
- * tools/fix_tommath_h.tcl: Added code to patch out a check for
- __x86_64__ that caused Tommath to use __attributes(TI)__ for the
- mp_word type. Tetra-int's simply fail on too many gcc-glibc-OS
- combinations to be ready for shipment today, even if they work for
- some of us. This change allows reversion of das's change of 2006-08-18
- that accomplised the same thing on Darwin. [Bugs 1601380, 1603737,
- 1609936, 1656265]
- * generic/tclTomMath.h: Regenerated.
- * library/tzdata/Africa/Asmara:
- * library/tzdata/Africa/Asmera:
- * library/tzdata/America/Nassau:
- * library/tzdata/Atlantic/Faeroe:
- * library/tzdata/Atlantic/Faroe:
- * library/tzdata/Australia/Eucla:
- * library/tzdata/Pacific/Easter: Rebuilt from Olson's tzdata2007b.
-
-2007-02-09 Joe Mistachkin <joe@mistachkin.com>
-
- * win/nmakehlp.c: Properly cleanup after nmakehlp, including the
- * win/makefile.vc: vcX0.pch file.
-
-2007-02-08 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/tclUnixInit.c (TclpCheckStackSpace): do stack size checks with
- unsigned size_t to correctly validate stackSize in the 2^31+ range.
- [Bug 1654104]
-
-2007-02-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c: Corrected broken logic in Tcl_DeleteNamespace
- * tests/namespace.test: introduced in Patch 1577278 that caused
- [namespace delete ::] to be effective only at level #0. New test
- namespace-7.7 should prevent similar error in the future [Bug 1655305]
-
-2007-02-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c: Corrected broken implementation of the
- * tests/namespace.test: TclMatchIsTrivial optimization on [namespace
- children $namespace $pattern].
-
-2007-02-04 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: use gcc4's __attribute__((__visibility__("hidden"))) if
- available to define MODULE_SCOPE effective on all platforms.
- * unix/configure.in: add caching to -pipe and zoneinfo checks.
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2007-02-03 Joe Mistachkin <joe@mistachkin.com>
-
- * win/rules.vc: Fix platform specific file copy macros for downlevel
- Windows.
-
-2007-01-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c: Added optimization case to TclTransferResult to
- cover common case where there's big savings over the fully general
- path. Thanks to Peter MacDonald. [Bug 1626518]
-
- * generic/tclLink.c: Broken linked float logic corrected. Thanks to
- Andy Goth. [Bug 1602538]
-
- * doc/fcopy.n: Typo fix. [Bug 1630627]
-
-2007-01-28 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: extract build settings that
- * macosx/Tcl.xcodeproj/default.pbxuser: were common to multiple
- * macosx/Tcl-Common.xcconfig (new file): configurations into external
- * macosx/Tcl-Debug.xcconfig (new file): xcconfig files; add extra
- * macosx/Tcl-Release.xcconfig (new file): configurations for building
- with SDKs and 64bit; convert legacy jam-based 'Tcl' target to native
- target with single script phase; correct syntax of build setting
- references to use $() throughout.
-
- * macosx/README: document new Tcl.xcodeproj configurations; other
- minor updates/corrections.
-
- * generic/tcl.h: update location of version numbers in macosx files.
-
- * macosx/Tcl.xcode/project.pbxproj: restore 'tcltest' target to
- * macosx/Tcl.xcode/default.pbxuser: working order by replicating
- applicable changes to Tcl.xcodeproj since 2006-07-20.
-
-2007-01-25 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: integrate CPPFLAGS into CFLAGS as late as possible and
- move (rather than duplicate) -isysroot flags from CFLAGS to CPPFLAGS
- to avoid errors about multiple -isysroot flags from some older gcc
- builds.
-
- * unix/configure: autoconf-2.59
-
-2007-01-22 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * compat/memcmp.c (memcmp): Reworked so that arithmetic is never
- performed upon void pointers, since that is illegal. [Bug 1631017]
-
-2007-01-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompile.c (TclCompileScript): Reduce the frequency with
- which we issue INST_START_CMD, making bytecode both more compact and
- somewhat faster. The optimized case is where we would otherwise be
- issuing a sequence of those instructions; in those cases, it is only
- ever the first one encountered that could possibly trigger.
-
-2007-01-19 Joe Mistachkin <joe@mistachkin.com>
-
- * tools/man2tcl.c: Include stdlib.h for exit() and improve comment
- detection.
- * win/nmakehlp.c: Update usage.
- * win/makefile.vc: Properly build man2tcl.c for MSVC8.
-
-2007-01-19 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXFCmd.c (TclMacOSXSetFileAttribute): on some versions
- of Mac OS X, truncate() fails on resource forks, in that case use
- open() with O_TRUNC instead.
-
- * macosx/tclMacOSXNotify.c: accommodate changes to prototypes of
- OSSpinLock(Un)Lock API.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: ensure HOME and USER env vars
- * macosx/Tcl.xcodeproj/default.pbxuser: are defined when running
- testsuite from Xcode.
-
- * tests/env.test: add extra system env vars that need to be preserved
- on some Mac OS X versions for testsuite to work.
-
- * unix/Makefile.in: Move libtommath defines into configure.in to
- * unix/configure.in: avoid replicating them across multiple
- * macosx/Tcl.xcodeproj/project.pbxproj: buildsystems.
-
- * unix/tcl.m4: ensure CPPFLAGS env var is used when set. [Bug 1586861]
- (Darwin): add -isysroot and -mmacosx-version-min flags to CPPFLAGS
- when present in CFLAGS to avoid discrepancies between what headers
- configure sees during preprocessing tests and compiling tests.
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2007-01-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompile.c (TclCompileScript): Make sure that when parsing
- an expanded literal fails, a correct bytecode sequence is still
- issued. [Bug 1638414]. Also make sure that the start of the expansion
- bytecode sequence falls inside the span of bytecodes for a command.
- * tests/compile.test (compile-16.24): Added test for [Bug 1638414]
-
-2007-01-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIO.c: Added macros to make usage of ChannelBuffers
- clearer.
-
-2007-01-11 Joe English <jenglish@users.sourceforge.net>
-
- * win/tcl.m4(CFLAGS_WARNING): Remove "-Wconversion". This was removed
- from unix/tcl.m4 2004-07-16 but not from here.
- * win/configure: Regenerated.
-
-2007-01-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Fixes to work better on Win98. Read version numbers
- * win/nmakehlp.c: from package index file to avoid keeping numbers in
- * win/rules.vc: the makefile where they may become de-synchronized.
-
-2007-01-10 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/regcomp.c (compile, freev): Define a strategy for
- * generic/regexec.c (exec): managing the internal
- * generic/regguts.h (AllocVars, FreeVars): vars of the RE engine to
- * generic/regcustom.h (AllocVars, FreeVars): reduce C stack usage.
- This will make Tcl as a whole much less likely to run out of stack
- space...
-
-2007-01-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileLindexCmd):
- * tests/lindex.test (lindex-9.2): Fix silly bug that ended up
- sometimes compiling list arguments in the wrong order. [Bug 1631364]
-
-2007-01-03 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclDate.c: Regenerated to recover a lost fix from patthoyts.
- [Bug 1618523]
-
-2006-12-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclIO.c (Tcl_GetsObj): Avoid checking for for the LF in a
- possible CRLF sequence when EOF has already been found.
-
-2006-12-26 Mo DeJong <mdejong@users.sourceforge.net>
-
- * generic/tclEncoding.c (EscapeFromUtfProc): Clear the
- TCL_ENCODING_END flag when end bytes are written. This fix keep this
- method from writing escape bytes for an encoding like iso2022-jp
- multiple times when the escape byte overlap with the end of the IO
- buffer.
- * tests/io.test: Add test for escape byte overlap issue.
-
-2006-12-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * unix/tclUnixThrd.c (Tcl_GetAllocMutex, TclpNewAllocMutex): Add
- intermediate variables to shut up unwanted warnings. [Bug 1618838]
-
-2006-12-19 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixThrd.c (TclpInetNtoa): fix for 64 bit.
-
- * unix/tcl.m4 (Darwin): --enable-64bit: verify linking with 64bit
- -arch flag succeeds before enabling 64bit build.
- * unix/configure: autoconf-2.59
-
-2006-12-17 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/macOSXLoad.test (new file): add testing of .bundle loading and
- * tests/load.test: unloading on Darwin (in addition
- * tests/unload.test: to existing tests of .dylib
- loading).
- * macosx/Tcl.xcodeproj/project.pbxproj: add building of dltest
- binaries so that testsuite run from Xcode can use them; fix testsuite
- run script
- * unix/configure.in: add support for building dltest binaries as
- * unix/dltest/Makefile.in: .bundle (in addition to .dylib) on Darwin.
- * unix/Makefile.in: add stub lib dependency to dltest target.
- * unix/configure: autoconf-2.59
-
- * tests/append.test: fix cleanup failure when all tests are skipped.
-
- * tests/chan.test (chan-16.9): cleanup chan event handler to avoid
- causing error in event.test when running testsuite with -singleproc 1.
-
- * tests/info.test: add !singleTestInterp constraint to tests that fail
- when running testsuite with -singleproc 1. [Bug 1605269]
-
-2006-12-14 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/string.n: Fix example. [Bug 1615277]
-
-2006-12-12 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Now that the new internal structs are
- in use to support operator commands, might as well make them the
- default for [expr] as well and avoid passing every parsed expression
- through the inefficient Tcl_Token array format. This addresses most
- issues in [RFE 1517602]. Assuming no performance disasters result from
- this, much dead code supporting the other implementation might now be
- removed.
-
- * generic/tclBasic.c: Final step routing all direct evaluation forms
- * generic/tclCompExpr.c: of the operator commands through TEBC,
- * generic/tclCompile.h: dropping all the routines in tclMathOp.c.
- * generic/tclMathOp.c: Still needs Engineering Manual attention.
-
-2006-12-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Another step with all sorting operator
- * generic/tclCompExpr.c: commands now routing through TEBC via
- * generic/tclCompile.h: TclSortingOpCmd().
-
-2006-12-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Another step down the path of re-using
- * generic/tclCompExpr.c: TclExecuteByteCode to implement the TIP 174
- * generic/tclCompile.h: commands instead of using a mass of code
- * generic/tclMathOp.c: duplication. Now all operator commands that
- * tests/mathop.test: demand exactly one operation are implemented
- via TclSingleOpCmd and a call to TEBC.
-
- * generic/tclCompExpr.c: Revised implementation of TclInvertOpCmd to
- * generic/tclMathOp.c: perform a bytecode compile / execute sequence.
- This demonstrates a path toward avoiding mountains of code duplication
- in tclMathOp.c and tclExecute.c.
-
- * generic/tclCompile.h: Change TclExecuteByteCode() from static to
- * generic/tclExecute.c: MODULE_SCOPE so all files including
- tclCompile.h may call it.
-
- * generic/tclMathOp.c: More revisions to make tests pass.
- * tests/mathop.test:
-
-2006-12-08 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclNamesp.c (TclTeardownNamespace): Ensure that dying
- namespaces unstitch themselves from their referents. [Bug 1571056]
- (NsEnsembleImplementationCmd): Silence GCC warning.
-
- * tests/mathop.test: Full tests for & | and ^ operators
-
-2006-12-08 Daniel Steffen <das@users.sourceforge.net>
-
- * library/tcltest/tcltest.tcl: use [info frame] for "-verbose line".
-
-2006-12-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c: Additional commits correct most
- * generic/tclExecute.c: failing tests illustrating bugs
- * generic/tclMathOp.c: uncovered in [Patch 1578137].
-
- * generic/tclBasic.c: Biggest source of TIP 174 failures was that
- the commands were not [namespace export]ed from the ::tcl::mathop
- namespace. More bits from [Patch 1578137] correct that.
-
- * tests/mathop.test: Commmitted several new tests from Peter Spjuth
- found in [Patch 1578137]. Many failures now demonstrate issues to fix
- in the TIP 174 implementation.
-
-2006-12-07 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/mathop.test: Added tests for ! ~ eq operators.
- * generic/tclMathOp.c (TclInvertOpCmd): Add in check for non-integral
- numeric values.
- * generic/tclCompCmds.c (CompileCompareOpCmd): Factor out the code
- generation for the chained comparison operators.
-
-2006-12-07 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/exec.test: Fixed line endings (caused win32 problems).
-
-2006-12-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompCmds.c: Revised and consolidated into utility
- * tests/mathop.test: routines some of routines that compile
- the new TIP 174 commands. This corrects some known bugs. More to come.
-
-2006-12-06 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/expr.test (expr-47.12): Improved error reporting in hopes of
- having more information to pursue [Bug 1609936].
-
-2006-12-05 Andreas Kupries <andreask@activestate.com>
-
- TIP#291 IMPLEMENTATION
-
- * generic/tclBasic.c: Define tcl_platform element for pointerSize.
- * doc/tclvars.n:
-
- * win/Makefile.in: Added installation instructions for the platform
- * win/makefile.vc: package. Added the platform package.
- * win/makefile.bc:
- * unix/Makefile.in:
-
- * tests/platform.test:
- * tests/safe.test:
-
- * library/platform/platform.tcl:
- * library/platform/shell.tcl:
- * library/platform/pkgIndex.tcl:
-
- * doc/platform.n:
- * doc/platform_shell.n:
-
-2006-12-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPkg.c: When no requirements are supplied to a
- * tests/pkg.test: [package require $pkg] and [package unknown]
- is invoked to find a satisfying package, pass the requirement argument
- "0-" (which means all versions are acceptable). This permits a
- registered [package unknown] command to call [package vsatisfies
- $testVersion {*}$args] without any special handling of the empty $args
- case. This fixes/avoids a bug in [::tcl::tm::UnknownHandler] that was
- causing old TM versions to be provided in preference to newer TM
- versions. Thanks to Julian Noble for discovering the issue.
-
-2006-12-04 Donal K. Fellows <dkf@users.sf.net>
-
- TIP#267 IMPLEMENTATION
-
- * generic/tclIOCmd.c (Tcl_ExecObjCmd): Added -ignorestderr option,
- * tests/exec.test, doc/exec.n: loosely from [Patch 1476191]
-
-2006-12-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Added implementation for the
- CompileExprTree() routine that can produce expression bytecode
- directly from internal structures with no need to pass through the
- Tcl_Token array representation. Still disabled by default. #undef
- USE_EXPR_TOKENS to try it out.
-
-2006-12-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Added expr parsing routines that
- produce a different set of internal structures representing the parsed
- expression, as well as routines that go on to convert those structures
- into the traditional Tcl_Token array format. Use of these routines is
- currently disabled. #undef PARSE_DIRECT_EXPR_TOKENS to enable them.
- These routines will only become really useful when more routines that
- compile directly from the new internal structures are completed.
-
-2006-12-02 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/file.n: Clarification of [file pathtype] docs. [Bug 1606454]
-
-2006-12-01 Kevin B. Kenny <kennykb@acm.org>
-
- * libtommath/bn_mp_add.c: Corrected the effects of a
- * libtommath/bn_mp_div.c: bollixed 'cvs merge' operation
- * libtommath/bncore.c: that inadvertently committed some
- * libtommath/tommath_class.h: half-developed code.
-
- TIP#299 IMPLEMENTATION
-
- * doc/mathfunc.n: Added isqrt() function to docs
- * generic/tclBasic.c: Added isqrt() math function (ExprIsqrtFunc)
- * tests/expr.test (expr-47.*): Added tests for isqrt()
- * tests/info.test (info-20.2): Added isqrt() to expected math funcs.
-
-2006-12-01 Don Porter <dgp@users.sourceforge.net>
-
- * tests/chan.test: Correct timing sensitivity in new test. [Bug
- 1606860]
-
- TIP#287 IMPLEMENTATION
-
- * doc/chan.n: New subcommand [chan pending].
- * generic/tclBasic.c: Thanks to Michael Cleverly for proposal
- * generic/tclInt.h: and implementation.
- * generic/tclIOCmd.c:
- * library/init.tcl:
- * tests/chan.test:
- * tests/ioCmd.test:
-
- TIP#298 IMPLEMENTATION
-
- * generic/tcl.decls: Tcl_GetBignumAndClearObj -> Tcl_TakeBignumFromObj
- * generic/tclObj.c:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclExecute.c: Update callers.
- * generic/tclMathOp.c:
-
-2006-11-30 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata: Olson's tzdata2006p.
- * libtommath/bn_mp_sqrt.c: Fixed a bug where the initial approximation
- to the square root could be on the wrong side, causing failure of
- convergence.
-
-2006-11-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (Tcl_AppendObjToErrorInfo): Added
- Tcl_DecrRefCount() on the objPtr argument to plug memory leaks. This
- makes the routine a consumer, which makes it easiest to use.
-
-2006-11-28 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c: TIP #280 implementation.
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclCompCmds.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclIOUtil.c:
- * generic/tclInt.h:
- * generic/tclInterp.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * tests/compile.test:
- * tests/info.test:
- * tests/platform.test:
- * tests/safe.test:
-
-2006-11-27 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclUnixChan.c (TclUnixWaitForFile):
- * tests/event.test (event-14.*): Corrected a bug where
- TclUnixWaitForFile would present select() with the wrong mask on an
- LP64 machine if a fd number exceeds 32. Thanks to Jean-Luc Fontaine
- for reporting and diagnosing. [Bug 1602208]
-
-2006-11-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (TclIncrObj): Correct failure to detect
- floating-point increment values. Thanks to William Coleda [Bug
- 1602991]
-
-2006-11-26 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/mathop.test, doc/mathop.n: More bits and pieces of the TIP#174
- implementation. Note that the test suite is not yet complete.
-
-2006-11-26 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4 (Linux): --enable-64bit support. [Patch 1597389]
- * unix/configure: autoconf-2.59 [Bug 1230558]
-
-2006-11-25 Donal K. Fellows <dkf@users.sf.net>
-
- TIP#174 IMPLEMENTATION
-
- * generic/tclMathOp.c (new file): Completed the implementation of the
- interpreted versions of all the tcl::mathop commands. Moved to a new
- file to make tclCompCmds.c more focused in purpose.
-
-2006-11-23 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (Tcl*OpCmd, TclCompile*OpCmd):
- * generic/tclBasic.c (Tcl_CreateInterp): Partial implementation of
- TIP#174; the commands are compiled, but (mostly) not interpreted yet.
-
-2006-11-22 Donal K. Fellows <dkf@users.sf.net>
-
- TIP#269 IMPLEMENTATION
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Implementation of the [string
- * tests/string.test (string-25.*): is list] command, based on
- * doc/string.n: work by Joe Mistachkin, with
- enhancements by Donal Fellows for better failindex behaviour.
-
-2006-11-22 Don Porter <dgp@users.sourceforge.net>
-
- * tools/genWinImage.tcl (removed): Removed two files used in
- * win/README.binary (removed): production of binary distributions
- for Windows, a task we no longer perform. [Bug 1476980]
- * generic/tcl.h: Remove mention of win/README.binary in comment
-
- * generic/tcl.h: Moved TCL_REG_BOSONLY #define from tcl.h to
- * generic/tclInt.h: tclInt.h. Only know user is Expect, which
- already #include's tclInt.h. No need to continue greater exposure.
- [Bug 926500]
-
-2006-11-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (Tcl_CreateInterp, TclHideUnsafeCommands):
- * library/init.tcl: Refactored the [chan] command's guts so that it
- does not use aliases to global commands, making the code more robust.
-
-2006-11-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (INST_EXPON): Corrected crash on
- [expr 2**(1<<63)]. Was operating on cleared bignum Tcl_Obj.
-
-2006-11-16 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/apply.n, doc/chan.n: Added examples.
-
-2006-11-15 Don Porter <dgp@users.sourceforge.net>
-
- TIP#270 IMPLEMENTATION
-
- * generic/tcl.decls: New public routines Tcl_ObjPrintf,
- * generic/tclStringObj.c: Tcl_AppendObjToErrorInfo, Tcl_Format,
- * generic/tclInt.h: Tcl_AppendLimitedToObj,
- Tcl_AppendFormatToObj and Tcl_AppendPrintfToObj. Former internal
- versions removed.
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclBasic.c: Updated callers.
- * generic/tclCkalloc.c:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclCompExpr.c:
- * generic/tclCompile.c:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * generic/tclIORChan.c:
- * generic/tclIOUtil.c:
- * generic/tclMain.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclPkg.c:
- * generic/tclProc.c:
- * generic/tclStrToD.c:
- * generic/tclTimer.c:
- * generic/tclUtil.c:
- * unix/tclUnixFCmd.c:
-
- * tools/genStubs.tcl: Updated script to no longer produce the
- _ANSI_ARGS_ wrapper in generated declarations. Also revised to accept
- variadic prototypes with more than one fixed argument. (This is
- possible since TCL_VARARGS and its limitations are no longer in use).
- * generic/tcl.h: Some reordering so that macro definitions do
- not interfere with the now _ANSI_ARGS_-less stub declarations.
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclTomMathDecls.h:
-
-2006-11-15 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/ChnlStack.3, doc/CrtObjCmd.3, doc/GetIndex.3, doc/OpenTcp.3:
- * doc/chan.n, doc/fconfigure.n, doc/fcopy.n, doc/foreach.n:
- * doc/history.n, doc/http.n, doc/library.n, doc/lindex.n:
- * doc/lrepeat.n, doc/lreverse.n, doc/pkgMkIndex.n, doc/re_syntax.n:
- Convert \fP to \fR so that man-page scrapers have an easier time.
-
-2006-11-14 Don Porter <dgp@users.sourceforge.net>
-
- TIP#261 IMPLEMENTATION
-
- * generic/tclNamesp.c: [namespace import] with 0 arguments
- introspects the list of imported commands.
-
-2006-11-13 Kevin B. Kenny <kennykb@users.sourceforge.net>
-
- * generic/tclThreadStorage.c (Tcl_InitThreadStorage):
- (Tcl_FinalizeThreadStorage): Silence a compiler warning about
- presenting a volatile pointer to 'memset'.
-
-2006-11-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIO.c: When [gets] on a binary channel needs to use
- the "iso8859-1" encoding, save a copy of that encoding per-thread to
- avoid repeated freeing and re-loading of it from the file system. This
- replaces the cached copy of this encoding that the platform
- initialization code used to keep in pre-8.5 releases.
-
-2006-11-13 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Fix gcc warnings about 'cast to/from
- * generic/tclEncoding.c: pointer from/to integer of different
- * generic/tclEvent.c: size' on 64-bit platforms by casting
- * generic/tclExecute.c: to intermediate types
- * generic/tclHash.c: intptr_t/uintptr_t via new PTR2INT(),
- * generic/tclIO.c: INT2PTR(), PTR2UINT() and UINT2PTR()
- * generic/tclInt.h: macros. [Patch 1592791]
- * generic/tclProc.c:
- * generic/tclTest.c:
- * generic/tclThreadStorage.c:
- * generic/tclTimer.c:
- * generic/tclUtil.c:
- * unix/configure.in:
- * unix/tclUnixChan.c:
- * unix/tclUnixPipe.c:
- * unix/tclUnixPort.h:
- * unix/tclUnixTest.c:
- * unix/tclUnixThrd.c:
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2006-11-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h, generic/tclInt.decls: Transfer TclPtrMakeUpvar and
- TclObjLookupVar to the internal stubs table.
-
-2006-11-10 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/fCmd.test (fCmd-6.26): fix failure when env(HOME) path
- contains symlinks.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: remove tclParseExpr.c; when
- running testsuite from inside Xcdoe, skip stack-3.1 (it only fails
- under those circumstances).
-
- * unix/tcl.m4 (Darwin): suppress linker arch warnings when building
- universal for both 32 & 64 bit and no 64bit CoreFoundation is
- available; sync with tk tcl.m4 change.
- * unix/configure.in: whitespace.
- * unix/configure: autoconf-2.59
-
-2006-11-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c (removed): Moved all the code of
- * generic/tclCompExpr.c: tclParseExpr.c into tclCompExpr.c.
- * unix/Makefile.in: This sets the stage for expr compiling to work
- * win/Makefile.in: directly with the full parse tree structures,
- * win/makefile.bc: and not have to pass through the information
- * win/makefile.vc: lossy format of an array of Tcl_Tokens.
- * win/tcl.dsp:
-
-2006-11-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- TIP#272 IMPLEMENTATION
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Implementation of the
- * tests/string.test, tests/stringComp.test: [string reverse] command
- * doc/string.n: from TIP#272.
-
- * generic/tclCmdIL.c (Tcl_LreverseObjCmd): Implementation of the
- * generic/tclBasic.c, generic/tclInt.h: [lreverse] command from
- * tests/cmdIL.test (cmdIL-7.*): TIP#272.
- * doc/lreverse.n:
-
-2006-11-08 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIO.c, generic/tclPkg.c: Style & clarity rewrites.
-
-2006-11-07 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixFCmd.c (CopyFile): Added code to fall back to a
- hardwired default block size should the filesystem report a bogus
- value. [Bug 1586470]
-
-2006-11-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Changed Tcl_ObjPrintf() response to an
- invalid format specifier string. No longer panics; now produces an
- error message as output.
-
- TIP#274 IMPLEMENTATION
-
- * generic/tclParseExpr.c: Exponentiation operator is now right
- * tests/expr.test: associative. [Patch 1556802]
-
-2006-11-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TEOVI): fix por possible leak of a Command in
- the presence of execution traces that delete it.
-
- * generic/tclBasic.c (TEOVI):
- * tests/trace.test (trace-21.11): fix for [Bug 1590232], execution
- traces may cause a second command resolution in the wrong namespace.
-
-2006-11-03 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/event.test (event-11.5): Rewrote tests to stop Tcl from
- * tests/io.test (multiple tests): opening sockets that are
- * tests/ioCmd.test (iocmd-15.1,16,17): reachable from outside hosts
- * tests/iogt.test (__echo_srv__.tcl): where not necessary. This is
- * tests/socket.test (multiple tests): noticably annoying on some
- * tests/unixInit.test (unixInit-1.2): systems (e.g., Windows).
-
-2006-11-02 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: check autoconf/autoheader exit
- status and stop build if they fail.
-
-2006-11-02 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/ParseCmd.3, doc/Tcl.n, doc/eval.n, doc/exec.n:
- * doc/fconfigure.n, doc/interp.n, doc/unknown.n:
- * library/auto.tcl, library/init.tcl, library/package.tcl:
- * library/safe.tcl, library/tm.tcl, library/msgcat/msgcat.tcl:
- * tests/all.tcl, tests/basic.test, tests/cmdInfo.test:
- * tests/compile.test, tests/encoding.test, tests/execute.test:
- * tests/fCmd.test, tests/http.test, tests/init.test:
- * tests/interp.test, tests/io.test, tests/ioUtil.test:
- * tests/iogt.test, tests/namespace-old.test, tests/namespace.test:
- * tests/parse.test, tests/pkg.test, tests/pkgMkIndex.test:
- * tests/proc.test, tests/reg.test, tests/trace.test:
- * tests/upvar.test, tests/winConsole.test, tests/winFCmd.test:
- * tools/tclZIC.tcl:
- * generic/tclParse.c (Tcl_ParseCommand): Replace {expand} with {*}
- officially (TIP #293). Leave -DALLOW_EXPAND=0|1 option to keep
- {expand} syntax for transition users. [Bug 1589629]
-
-2006-11-02 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclBasic.c, generic/tclInterp.c, generic/tclProc.c: Silence
- warnings from gcc over signed/unsigned and TclStackAlloc().
- * generic/tclCmdMZ.c: Update to more compact and clearer coding style.
-
-2006-11-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCmdAH.c: Further revisions to produce the routines
- * generic/tclInt.h: TclFormat() and TclAppendFormatToObj() that
- * generic/tclNamesp.c: accept (objc, objv) arguments rather than
- * generic/tclStringObj.c: any varargs stuff.
-
- * generic/tclBasic.c: Further revised TclAppendPrintToObj() and
- * generic/tclCkalloc.c: TclObjPrintf() routines to panic when unable
- * generic/tclCmdAH.c: to complete their formatting operations,
- * generic/tclCmdIL.c: rather than report an error message. This
- * generic/tclCmdMZ.c: means an interp argument for error message
- * generic/tclDictObj.c: recording is no longer needed, further
- * generic/tclExecute.c: simplifying the interface for callers.
- * generic/tclIORChan.c:
- * generic/tclIOUtil.c:
- * generic/tclInt.h:
- * generic/tclMain.c:
- * generic/tclNamesp.c:
- * generic/tclParseExpr.c:
- * generic/tclPkg.c:
- * generic/tclProc.c:
- * generic/tclStringObj.c:
- * generic/tclTimer.c:
- * generic/tclUtil.c:
- * unix/tclUnixFCmd.c:
-
-2006-11-02 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/winPipe.test (winpipe-4.[2345]): Made robust when run in
- directory with spaces in its name.
-
- * generic/tclCmdAH.c: Clean up uses of cast NULLs.
-
- * generic/tclInterp.c (AliasObjCmd): Added more explanatory comments.
-
- * generic/tclBasic.c (TclEvalObjvInternal): Rewrote so that comments
- are relevant and informative once more. Also made the unknown handler
- processing use the Tcl execution stack for working space, and not the
- general heap.
-
-2006-11-01 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixPort.h: ensure MODULE_SCOPE is defined before use, so
- that tclPort.h can once again be included without tclInt.h.
-
- * generic/tclEnv.c (Darwin): mark _environ symbol as unexported even
- when MODULE_SCOPE != __private_extern__.
-
-2006-10-31 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Refactored and renamed the routines
- * generic/tclCkalloc.c: TclObjPrintf, TclFormatObj, and
- * generic/tclCmdAH.c: TclFormatToErrorInfo to a new set of routines
- * generic/tclCmdIL.c: TclAppendPrintfToObj, TclAppendFormatToObj,
- * generic/tclCmdMZ.c: TclObjPrintf, and TclObjFormat, with the
- * generic/tclDictObj.c: intent of making the latter list, plus
- * generic/tclExecute.c: TclAppendLimitedToObj and
- * generic/tclIORChan.c: TclAppendObjToErrorInfo, public via a revised
- * generic/tclIOUtil.c: TIP 270.
- * generic/tclInt.h:
- * generic/tclMain.c:
- * generic/tclNamesp.c:
- * generic/tclParseExpr.c:
- * generic/tclPkg.c:
- * generic/tclProc.c:
- * generic/tclStringObj.c:
- * generic/tclTimer.c:
- * generic/tclUtil.c:
- * unix/tclUnixFCmd.c:
-
-2006-10-31 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c, generic/tcl.h, generic/tclInterp.c:
- * generic/tclNamesp.c: removing the flag bit TCL_EVAL_NOREWRITE, the
- last remnant of the callObjc/v fiasco. It is not needed, as it is now
- always set and checked or'ed with TCL_EVAL_INVOKE.
-
-2006-10-31 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/rules.vc: Fix for [Bug 1582769] - options conflict with VC2003.
-
-2006-10-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c, generic/tclNamesp.c, generic/tclProc.c:
- * generic/tclInt.h: Removed the callObjc and callObjv fields from the
- Interp structure. They did not function correctly and made other parts
- of the core amazingly complex, resulting in a substantive change to
- [info level] behaviour. [Bug 1587618]
- * library/clock.tcl: Removed use of [info level 0] for calculating the
- command name as used by the user and replace with a literal. What's
- there now is sucky, but at least appears to be right to most users.
- * tests/namespace.test (namespace-42.7,namespace-47.1): Reverted
- changes to these tests.
- * tests/info.test (info-9.11,info-9.12): Added knownBug constraint
- since these tests require a different behaviour of [info level] than
- is possible because of other dependencies.
-
-2006-10-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/tcltk-man2html.tcl (option-toc): handle any kind of options
- defined toc section (needed for ttk docs)
-
-2006-10-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (TEOVI): insured that the interp's callObjc/v
- fields are restored after traces run, as they be spoiled. This was
- causing a segfault in tcllib's profiler tests.
-
-2006-10-30 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (INST_MOD): Corrected improper testing of the
- * tests/expr.test: sign of bignums when applying Tcl's
- division rules. Thanks to Peter Spjuth. [Bug 1585704]
-
-2006-10-29 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (EnsembleImplementationCmd):
- * tests/namespace.test (47.7-8): reverted a wrong "optimisation" that
- completely broke snit; added two tests.
-
-2006-10-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (ObjInterpProcEx, TclObjInterpProcCore): Split the
- core of procedures to make it easier to build procedure-like code
- without going through horrible contortions. This is the last critical
- component to make advanced OO systems workable as simple loadable
- extensions. TOIPC is now in the internal stub table.
- (MakeProcError, MakeLambdaError): Refactored ProcessProcResultCode to
- be simpler, some of which goes to TclObjInterpProcCore, and the rest
- of which is now in these far simpler routines which just do errorInfo
- stack generation for different types of procedure-like entity.
- * tests/apply.test (apply-5.1): Updated to expect the more informative
- form of message.
-
-2006-10-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclVar.c (HasLocalVars): New macro to make various bits and
- pieces cleaner.
-
- * generic/tclNamesp.c (TclSetNsPath): Expose SetNsPath() through
- internal stubs table with semi-external name.
-
- * generic/tclInt.h (CallFrame): Add a field for handling context data
- for extensions (like object systems) that should be tied to a call
- frame (and not a command or interpreter).
-
- * generic/tclBasic.c (TclRenameCommand): Change to take CONST args;
- they were only ever used in a constant way anyway, so this appears to
- be a spot that was missed during TIP#27 work.
-
-2006-10-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (SetLambdaFromAny): minor change, eliminate
- redundant call to Tcl_GetString (thanks aku).
-
- * generic/tclInterp.c (ApplyObjCmd):
- * generic/tclNamesp.c (EnsembleImplementationCmd): replaced ckalloc
- (heap) with TclStackAlloc (execution stack).
-
-2006-10-24 Miguel Sofer <msofer@users.sf.net>
-
- * tests/info.test (info-9.11-12): tests for [Bug 1577492]
- * tests/apply.test (apply-4.3-5): tests for [Bug 1574835]
-
- * generic/tclProc.c (ObjInterpProcEx): disable itcl hacks for calls
- from ApplyObjCmd (islambda==1), as they mess apply's error messages
- [Bug 1583266]
-
-2006-10-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (ApplyObjCmd): fix wrong#args for apply by using
- the ensemble rewrite engine. [Bug 1574835]
- * generic/tclInterp.c (AliasObjCmd): previous commit missed usage of
- TCL_EVAL_NOREWRITE for aliases.
-
- * generic/tclBasic.c (TclEvalObjvInternal): removed redundant check
- for ensembles. [Bug 1577628]
-
- * library/clock.tcl (format, scan): corrected wrong # args messages to
- * tests/clock.test (3.1, 34.1): make use of the new rewrite
- capabilities of [info level]
-
- * generic/tcl.h: Lets TEOV update the iPtr->callObj[cv] new
- * generic/tclBasic.c: fields, except when the flag bit
- * generic/tclInt.h: TCL_EVAL_NOREWRITE is present. These values
- * generic/tclNamesp.c: are used by Tcl_PushCallFrame to initialise
- * generic/tclProc.c: the frame's obj[cv] fields, and allows
- * tests/namespace.test: [info level] to know and use ensemble
- rewrites. [Bug 1577492]
-
- ***POTENTIAL INCOMPATIBILITY***
- The return value from [info level 0] on interp alias calls is changed:
- previously returned the target command (including curried values), now
- returns the source - what was actually called.
-
-2006-10-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tcl.h: Modified the Tcl call stack so there is
- * generic/tclBasic.c: always a valid CallFrame, even at level 0
- * generic/tclCmdIL.c: [Patch 1577278]. Most of the changes
- * generic/tclInt.h: involve removing tests for a NULL
- * generic/tclNamesp.c: iPtr->(var)framePtr. There is now a
- * generic/tclObj.c: CallFrame pushed at interp creation with a
- * generic/tclProc.c: pointer to it stored in iPtr->rootFramePtr.
- * generic/tclTrace.c: A second unused field in Interp is
- * generic/tclVar.c: hijacked to enable further functionality,
- currently unused (but with several FRQs depending on it).
-
- ***POTENTIAL INCOMPATIBILITY***
- Any user that includes tclInt.h and needs to determine if it is
- running at level 0 should change (iPtr->varFramePtr == NULL) to
- (iPtr->varFramePtr == iPtr->rootFramePtr).
-
-2006-10-23 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bump version number to 8.5a6
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2006-10-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tcl.h, generic/tclHash.c: Tcl_FindHashEntry now calls
- Tcl_CreateHashEntry with a newPtr set to NULL: this would have caused
- a segfault previously and eliminates duplicated code. A macro has been
- added to tcl.h (only used when TCL_PRESERVE_BINARY_COMPATABALITY is
- not set - i.e., not by default).
-
-2006-10-20 Reinhard Max <max@tclers.tk>
-
- * unix/configure.in: Added autodetection for OS-supplied timezone
- * unix/Makefile.in: files and configure switches to override the
- * unix/configure: detected default.
-
-2006-10-20 Daniel Steffen <das@users.sourceforge.net>
-
- *** 8.5a5 TAGGED FOR RELEASE ***
-
- * tools/tcltk-man2html.tcl: add support for alpha & beta versions to
- useversion glob pattern. [Bug 1579941]
-
-2006-10-18 Don Porter <dgp@users.sourceforge.net>
-
- * changes: 8.5a5 release date set
-
- * doc/Encoding.3: Missing doc updates (mostly Table of
- * doc/Ensemble.3: Contents) exposed by `make checkdoc`
- * doc/FileSystem.3:
- * doc/GetTime.3:
- * doc/PkgRequire.3:
-
-2006-10-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInterp.c (ApplyObjCmd): fixed bad error in 2006-10-12
- commit: interp released too early. Spotted by mistachkin.
-
-2006-10-16 Miguel Sofer <msofer@users.sf.net>
-
- * tclProc.c (SetLambdaFromAny):
- * tests/apply.test (9.1-9.2): plugged intrep leak [Bug 1578454],
- found by mjanssen.
-
-2006-10-16 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c: Moved TIP#219 cleanup to DeleteInterpProc.
-
-2006-10-16 Daniel Steffen <das@users.sourceforge.net>
-
- * changes: updates for 8.5a5 release.
-
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): Darwin: fix for main
- thread, where pthread_get_stacksize_np() returns incorrect info.
-
- * macosx/GNUmakefile: don't redo prebinding of non-prebound binaires.
-
-2006-10-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPkg.c (ExactRequirement): Plugged memory leak. Also
- changed Tcl_Alloc()/Tcl_Free() calls to ckalloc()/ckfree() for easier
- memory debugging in the future. [Bug 1568373]
-
- * library/tcltest/tcltest.tcl: Revise tcltest bump to 2.3a1.
- * library/tcltest/pkgIndex.tcl: This permits more features to be
- * unix/Makefile.in: added to tcltest before we reach version 2.3.0
- * win/Makefile.in: best timed to match the release of Tcl 8.5.0.
- * win/makefile.vc: This also serves as a demo of TIP 268 features
-
-2006-10-13 Colin McCormack <coldstore@users.sf.net>
-
- * win/tclWinFile.c: corrected erroneous attempt to protect against
- NULL return from Tcl_FSGetNormalizedPath per [Bug 1548263] causing
- [Bug 1575837].
- * win/tclWinFile.c: alfredd supplied patch to fix [Bug 1575837]
-
-2006-10-13 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): on Darwin, use
- * unix/tcl.m4: pthread_get_stacksize_np() API to get thread stack size
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2006-10-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInterp.c (ApplyObjCmd):
- * tests/interp.test (interp-14.5-10): made [interp alias] use the
- ensemble rewrite machinery to produce better error messages [Bug
- 1576006]
-
-2006-10-12 David Gravereaux <davygrvy@pobox.com>
-
- * win/nmakehlp.c: Replaced all wnsprintf() calls with snprintf().
- wnsprintf was not in my shwlapi header file (VC++6)
-
-2006-10-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPkg.c (Tcl_PackageRequireEx): Corrected crash when
- argument version=NULL passed in.
-
-2006-10-10 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.5a5 release.
-
- * generic/tclNamespace.c (TclTeardownNamespace): After the
- commandPathSourceList of a namespace is cleared, set the
- commandPathSourceList to NULL so we don't try to walk the list a
- second time, possibly after it is freed. [Bug 1566526]
- * tests/namespace.test (namespace-51.16): Added test.
-
-2006-10-09 Miguel Sofer <msofer@users.sf.net>
-
- * doc/UpVar.3: brough the docs in accordance to the code. Ever since
- 8.0, Tcl_UpVar(2)? accepts TCL_NAMESPACE_ONLY as a flag value, and
- var-3.4 tests for proper behaviour. The docs only allowed 0 and
- TCL_GLOBAL_ONLY. [Bug 1574099]
-
-2006-10-09 Miguel Sofer <msofer@users.sf.net>
-
- * tests/*.test: updated all tests to refer explicitly to the global
- variables ::errorInfo, ::errorCode, ::env and ::tcl_platform: many
- were relying on the alternative lookup in the global namespace, that
- feature is tested specifically in namespace and variable tests.
-
- The modified testfiles are: apply.test, basic.test, case.test,
- cmdIL.test, cmdMZ.test, compExpr-old.test, error.test, eval.test,
- event.test, expr.test, fileSystem.test, for.test, http.test, if.test,
- incr-old.test, incr.test, interp.test, io.test, ioCmd.test, load.test,
- misc.test, namespace.test, parse.test, parseOld.test, pkg.test,
- proc-old.test, set.test, switch.test, tcltest.test, thread.test,
- var.test, while-old.test, while.test.
-
-2006-10-06 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/rules.vc: [Bug 1571954] avoid /RTCc flag with MSVC8
-
-2006-10-06 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * doc/binary.n: TIP #275: Support unsigned values in binary
- * generic/tclBinary.c: command. Tests and documentation updated.
- * tests/binary.test:
-
-2006-10-05 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl: Fixed bug in TIP #189 implementation, now allowing
- '_' in module names.
-
-2006-10-05 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/http.tcl (http::geturl): only do geturl url rfc 3986
- validity checking if $::http::strict is true (default true for 8.5).
- [Bug 1560506]
-
- * generic/tcl.h: note limitation on changing Tcl_UniChar size
- * generic/tclEncoding.c (UtfToUnicodeProc, UnicodeToUtfProc):
- * tests/encoding.test (encoding-16.1): fix alignment issues in
- unicode <> utf conversion procs. [Bug 1122671]
-
-2006-10-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (Tcl_LappendObjCmd):
- * tests/append.test(4.21-22): fix for longstanding [Bug 1570718],
- lappending nothing to non-list. Reported by lvirden
-
-2006-10-04 Kevin B. Kenny <kennykb@acm.org>
-
- * tzdata/: Olson's tzdata2006m.
-
-2006-10-01 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/clock.test (clock-49.2): Removed a locale dependency that
- caused a spurious failure in the German locale. [Bug 1567956]
-
-2006-10-01 Miguel Sofer <msofer@users.sf.net>
-
- * doc/Eval.3 (TclEvalObjv): added note on refCount management for the
- elements of objv. [Bug 730244]
-
-2006-10-01 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinFile.c: Handle possible missing define.
-
- * win/tclWinFile.c (TclpUtime): [Bug 1420432] file mtime fails for
- * tests/cmdAH.test: directories on windows
-
- * tests/winFile.test: Handle Msys environment a little differently in
- getuser function. [Bug 1567956]
-
-2006-09-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclUtil.c (Tcl_SplitList): optimisation, [Patch 1344747] by
- dgp.
-
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclObj.c:
- * generic/tclStubInit.c: added an internal function TclObjBeingDeleted
- to provide info as to the reason for the loss of an internal rep. [FR
- 1512138]
-
- * generic/tclCompile.c:
- * generic/tclHistory.c:
- * generic/tclInt.h:
- * generic/tclProc.c: made Tcl_RecordAndEvalObj not call "history" if
- it has been redefined to an empty proc, in order to reduce the noise
- when debugging [FR 1190441]. Moved TclCompileNoOp from tclProc.c to
- tclCompile.c
-
-2006-09-28 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclPkg.c (CompareVersions): Bugfix. Check string lengths
- * tests/pkg.test: before comparison. The shorter string is the smaller
- number. Added testcases as well. Interestingly all existing test cases
- for vcompare compared numbers of the same length with each other. [Bug
- 1563836]
-
-2006-09-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclIO.c (Tcl_GetsObj): added two test'n'panic guards for
- possible NULL derefs, [Bug 1566382] and coverity #33.
-
-2006-09-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrected error in INST_LSHIFT in the
- * tests/expr.test: calculation done to determine whether a shift
- in the (long int) type is possible. The calculation had literal value
- "1" where it needed a value "1L" to compute the correct result. Error
- detected via testing with the math::bigfloat package [Bug 1567222]
-
- * generic/tclPkg.c (CompareVersion): Flatten strcmp() results to
- {-1, 0, 1} to match expectations of CompareVersion() callers.
-
-2006-09-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/regc_color.c (singleton):
- * generic/regc_cvec.c (addmcce):
- * generic/regcomp.c (compile, dovec): the static function addmcce does
- nothing when called with two NULL pointers; the only call is by
- compile with two NULL pointers (regcomp.c #includes regc_cvec.c).
- Large parts (all?) the code for mcce (multi character collating
- element) that we do not use is ifdef'ed out with the macro
- REGEXP_MCCE_ENABLE.
- This silences coverity bugs 7, 16, 80
-
- * generic/regc_color.c (uncolorchain):
- * generic/regc_nfa.c (freearc): changed tests and asserts to
- equivalent formulation, designed to avoid an explicit comparison to
- NULL and satisfy coverity that 6 and 9 are not bugs.
-
-2006-09-27 Andreas Kupries <andreask@activestate.com>
-
- * tests/pkg.test: Added test for version comparison at the 32bit
- boundary. [Bug 1563836]
-
- * generic/tclPkg.c: Rewrote CompareVersion to perform string
- comparison instead of numeric. This breaks through the 32bit limit on
- version numbers. See code for details (handling of leading zeros,
- signs, etc.). un-CONSTed some arguments of CompareVersions,
- RequirementSatisfied, and AllRequirementsSatisfied. The new compare
- modifies the string (temporary string terminators). All callers use
- heap-allocated ver-intreps, so we are good with that. [Bug 1563836]
-
-2006-09-27 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclFileName.c (TclGlob): added a panic for a call with
- TCL_GLOBMODE_TAILS and pathPrefix==NULL. This would cause a segfault,
- as found by coverity #26.
-
-2006-09-26 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/Encoding.3: Added covariant 'const' qualifier for the
- * generic/tcl.decls: Tcl_EncodingType argument to
- * generic/tclEncoding.c: Tcl_CreateEncoding. [Further TIP#27 work.]
- * generic/tclDecls.h: Reran 'make genstubs'.
-
-2006-09-26 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Additional compiler flags and amd64 support.
- * win/nmakehlp.c:
- * win/rules.vc:
-
-2006-09-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: As 2006-09-22 commit from Donal K. Fellows
- demonstrates, "#define NULL 0" is just wrong, and as a quotable chat
- figure observed, "If NULL isn't defined, we're not using a C compiler"
- Improper fallback definition of NULL removed.
-
-2006-09-25 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tcl.h: More fixing which struct stat to refer to.
- * generic/tclGetDate.y: Some casts from time_t to int required.
- * generic/tclTimer.c: Tcl_Time structure members are longs.
- * win/makefile.vc: Support for varying compiler options
- * win/rules.vc: and build to platform-specific subdirs.
-
-2006-09-25 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (Tcl_StackChannel): Fixed [Bug 1564642], aka
- coverity #51. Extended loop condition, added checking for NULL to
- prevent seg.fault.
-
-2006-09-25 Andreas Kupries <andreask@activestate.com>
-
- * doc/package.n: Fixed nits reported by Daniel Steffen in the TIP#268
- changes.
-
-2006-09-25 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclNotify.c (Tcl_DeleteEvents): Simplified the code in hopes
- of making the invariants clearer and proving to Coverity that the
- event queue memory is managed correctly.
-
-2006-09-25 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNotify.c (Tcl_DeleteEvents): Make it clear what happens
- when the event queue is mismanaged. [Bug 1564677], coverity bug #10.
-
-2006-09-24 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c (Tcl_ParseCommand): also return an error if
- start==NULL and numBytes<0. This is coverity's bug #20
-
- * generic/tclStringObj.c (STRING_SIZE): fix allocation for 0-length
- strings. This is coverity's bugs #54-5
-
-2006-09-22 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclInt.h: Moved TIP#268's field 'packagePrefer' to the end
- of the structure, for better backward compatibility.
-
-2006-09-22 Andreas Kupries <andreask@activestate.com>
-
- TIP#268 IMPLEMENTATION
-
- * generic/tclDecls.h: Regenerated from tcl.decls.
- * generic/tclStubInit.c:
-
- * doc/PkgRequire.3: Documentation of extended API, extended testsuite.
- * doc/package.n:
- * tests/pkg.test:
-
- * generic/tcl.decls: Implementation.
- * generic/tclBasic.c:
- * generic/tclConfig.c:
- * generic/tclInt.h:
- * generic/tclPkg.c:
- * generic/tclTest.c:
- * generic/tclTomMathInterface.c:
- * library/init.tcl:
- * library/package.tcl:
- * library/tm.tcl:
-
-2006-09-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclThreadTest.c (TclCreateThread): Use NULL instead of 0 as
- end-of-strings marker to Tcl_AppendResult; the difference matters on
- 64-bit machines. [Bug 1562528]
-
-2006-09-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclUtil.c: Dropped ParseInteger() routine. TclParseNumber
- covers the task just fine.
-
-2006-09-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclEvent.c (Tcl_VwaitObjCmd): Rewrite so that an exceeded
- limit trapped in a vwait cannot cause a dangerous dangling trace.
-
-2006-09-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (INST_EXPON): Native type overflow detection
- * tests/expr.test: was completely broken. Falling back on use of
- bignums for all non-trivial ** calculations until
- native-type-constrained special cases can be done carefully and
- correctly. [Bug 1561260]
-
-2006-09-15 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/http.tcl: Change " " -> "+" url encoding mapping
- * library/http/pkgIndex.tcl: to " " -> "%20" as per RFC 3986.
- * tests/http.test (http-5.1): bump http to 2.5.3
- * unix/Makefile.in:
- * win/Makefile.in:
-
-2006-09-12 Andreas Kupries <andreask@activestate.com>
-
- * unix/configure.in (HAVE_MTSAFE_GETHOST*): Modified to recognize
- HP-UX 11.00 and beyond as having mt-safe implementations of the
- gethost functions.
- * unix/configure: Regenerated, using autoconf 2.59
-
- * unix/tclUnixCompat.c (PadBuffer): Fixed bug in calculation of the
- increment needed to align the pointer, and added documentation
- explaining why the macro is implemented as it is.
-
-2006-09-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/rules.vc: Updated to install http, tcltest and msgcat as
- * win/makefile.vc: Tcl Modules (as per Makefile.in).
- * win/makefile.vc: Added tommath_(super)class headers.
-
-2006-09-11 Andreas Kupries <andreask@activestate.com>
-
- * unix/Makefile.in (install-libraries): Fixed typo tcltest 2.3.9 ->
- 2.3.0.
-
-2006-09-11 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixCompat.c: make compatLock static and only declare it
- when it will actually be used; #ifdef parts of TSD that are not always
- needed; adjust #ifdefs to cover all possible cases; fix whitespace.
-
-2006-09-11 Andreas Kupries <andreask@activestate.com>
-
- * tests/msgcat.test: Bumped version in auxiliary files as well.
- * doc/msgcat.n:
-
-2006-09-11 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/Makefile.in: Bumped msgcat version to 1.4.2 to be
- * win/Makefile.in: consistent with dgp's commits of 2006-09-10.
-
-2006-09-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/msgcat/msgcat.tcl: Removed some unneeded [uplevel]s.
-
-2006-09-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrected INST_EXPON flaw that treated
- * tests/expr.test: $x**1 as $x**3. [Bug 1555371]
-
- * doc/tcltest.n: Bump to version tcltest 2.3.0 to
- * library/tcltest/pkgIndex.tcl: account for new "-verbose line"
- * library/tcltest/tcltest.tcl: feature.
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.bc:
- * win/makefile.vc:
-
- * library/msgcat/msgcat.tcl: Bump to version msgcat 1.4.2 to
- * library/msgcat/pkgIndex.tcl: account for modifications.
-
-2006-09-10 Daniel Steffen <das@users.sourceforge.net>
-
- * library/msgcat/msgcat.tcl (msgcat::Init): on Darwin, add fallback of
- * tests/msgcat.test: default msgcat locale to
- * unix/tclUnixInit.c (TclpSetVariables): current CFLocale
- identifier if available (via private ::tcl::mac::locale global, set at
- interp init when on Mac OS X 10.3 or later with CoreFoundation).
-
- * library/tcltest/tcltest.tcl: add 'line' verbose level: prints source
- * doc/tcltest.n: file line information of failing tests.
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add new tclUnixCompat.c file;
- revise tests target to use new tcltest 'line' verbose level.
-
- * unix/configure.in: add descriptions to new AC_DEFINEs for MT-safe.
- * unix/tcl.m4: add caching to new SC_TCL_* macros for MT-safe wrappers
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2006-09-08 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixCompat.c: Added fallback to gethostbyname() and
- gethostbyaddr() if the implementation is known to be MT-safe
- (currently for Darwin 6 or later only).
-
- * unix/configure.in: Assume gethostbyname() and gethostbyaddr() are
- MT-safe starting with Darwin 6 (Mac OSX 10.2).
-
- * unix/configure: Regenerated with autoconf V2.59
-
-2006-09-08 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixCompat.c: Fixed conditions for CopyArray/CopyString, and
- CopyHostent. Also fixed bad var names in TclpGetHostByName.
-
-2006-09-07 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixCompat.c: Added fallback to MT-unsafe library calls if
- TCL_THREADS is not defined.
- Fixed alignment of arrays copied by CopyArray() to be on the
- sizeof(char *) boundary.
-
-2006-09-07 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixChan.c: Rewritten MT-safe wrappers to return ptrs to
- * unix/tclUnixCompat.c: TSD storage making them all look like their
- * unix/tclUnixFCmd.c: MT-unsafe pendants API-wise.
- * unix/tclUnixPort.h:
- * unix/tclUnixSock.c:
-
-2006-09-06 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * unix/tclUnixChan.c: Added TCL_THREADS ifdef'ed usage of MT-safe
- * unix/tclUnixFCmd.c: calls like: getpwuid, getpwnam, getgrgid,
- * unix/tclUnixSock.c: getgrnam, gethostbyname and gethostbyaddr.
- * unix/tclUnixPort.h: See [Bug 999544]
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/tcl.m4:
- * unix/configure: Regenerated.
-
- * unix/tclUnixCompat.c: New file containing MT-safe implementation of
- some library calls.
-
-2006-09-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Removed much complexity that is no
- longer needed.
-
- * tests/main.text (Tcl_Main-4.4): Test corrected to not be
- timing sensitive to the Bug 1481986 fix. [Bug 1550858]
-
-2006-09-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/package.n: correct package example
-
-2006-08-31 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Corrected flawed logic for disabling
- the INST_TRY_CVT_TO_NUMERIC instruction at the end of an expression
- when function arguments contain operators. [Bug 1541274]
-
- * tests/expr-old.test: The remaining failing tests reported in
- * tests/expr.test: [Bug 1381715] are all new in Tcl 8.5, so
- there's really no issue of compatibility with Tcl 8.4 result to deal
- with. Fixed by updating tests to expect 8.5 results.
-
-2006-08-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Dropped the old expr parser.
-
-2006-08-30 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclBasic.c (Tcl_CreateInterp): init iPtr->threadId
-
- * win/tclWinChan.c [Bug 819667] Improve logic for identifying COM
- ports.
-
- * generic/tclIOGT.c (ExecuteCallback):
- * generic/tclPkg.c (Tcl_PkgRequireEx): replace Tcl_GlobalEval(Obj)
- with more efficient Tcl_Eval(Obj)Ex
-
- * unix/Makefile.in (valgrindshell): add valgrindshell target and
- update default VALGRINDARGS. User can override, or add to it with
- VALGRIND_OPTS env var.
-
- * generic/tclFileName.c (DoGlob): match incrs with decrs.
-
-2006-08-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Use the "parent" field of orphan
- ExprNodes to store the closure of left pointers. This lets us avoid
- repeated re-scanning leftward for the left boundary of subexpressions,
- which in worst case led to near O(N^2) runtime.
-
-2006-08-29 Joe Mistachkin <joe@mistachkin.com>
-
- * unix/tclUnixInit.c: Fixed the issue (typo) that was causing
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): stack.test to fail on
- FreeBSD (and possibly other Unix platforms).
-
-2006-08-29 Colin McCormack <coldstore@users.sourceforge.net>
-
- * generic/tclIOUtil.c: Added test for NULL return from
- * generic/tclPathObj.c: Tcl_FSGetNormalizedPath which was causing
- * unix/tclUnixFile.c: segv's per [Bug 1548263]
- * win/tclWinFCmd.c:
- * win/tclWinFile.c:
-
-2006-08-28 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Havana: Regenerated from Olson's
- * library/tzdata/America/Tegucigalpa: tzdata2006k.
- * library/tzdata/Asia/Gaza:
-
-2006-08-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c: Revised ObjPrintfVA to take care to
- * generic/tclParseExpr.c: copy only whole characters when doing
- %s formatting. This relieves callers of TclObjPrintf() and
- TclFormatToErrorInfo() from needing to fix arguments to character
- boundaries. Tcl_ParseExpr() simplified by taking advantage. [Bug
- 1547786]
-
- * generic/tclStringObj.c: Corrected TclFormatObj's failure to
- count up the number of arguments required by examining the format
- string. [Bug 1547681]
-
-2006-08-27 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclClock.c (ClockClicksObjCmd): Fix nested macro breakage
- with TCL_MEM_DEBUG enabled. [Bug 1547662]
-
-2006-08-26 Miguel Sofer <msofer@users.sf.net>
-
- * doc/namespace.n:
- * generic/tclNamesp.c:
- * tests/upvar.test: bugfix, docs clarification and new tests for
- [namespace upvar] as follow up to [Bug 1546833], reported by Will
- Duquette.
-
-2006-08-24 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata: Regenerated, including several new files, from
- Olson's tzdata2006j.
- * library/clock.tcl:
- * tests/clock.test: Removed an early testing hack that allowed loading
- 'registry' from the build tree rather than an installed one. This is a
- workaround for [Bug 15232730], which remains open because it's a
- symptom of a deeper underlying problem.
-
-2006-08-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Minimal collection of new tests
- * tests/parseExpr.test: testing the error messages of the new
- expr parser. Several bug fixes and code simplifications that appeared
- during that effort.
-
-2006-08-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c: Revisions to complete the thread finalization
- of the cwdPathPtr. [Bug 1536142]
-
- * generic/tclParseExpr.c: Revised mistaken call to
- TclCheckBadOctal(), so both [expr 08] and [expr 08z] have same
- additional info in error message.
-
- * tests/compExpr-old.test: Update existing tests to not fail with
- * tests/compExpr.test: the new expr parser.
- * tests/compile.test:
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/for.test:
- * tests/if.test:
- * tests/parseExpr.test:
- * tests/while.test:
-
-2006-08-21 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * win/Makefile.in (gdb): Make this target work so that debugging an
- msys build is possible.
-
-2006-08-21 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c (Tcl_WaitForEvent): if the run loop is
- already running (e.g. if Tcl_WaitForEvent was called recursively),
- re-run it in a custom run loop mode containing only the source for the
- notifier thread, otherwise wakeups from other sources added to the
- common run loop modes might get lost.
-
- * unix/tclUnixNotfy.c (Tcl_WaitForEvent): on 64-bit Darwin,
- pthread_cond_timedwait() appears to have a bug that causes it to wait
- forever when passed an absolute time which has already been exceeded
- by the system time; as a workaround, when given a very brief timeout,
- just do a poll on that platform. [Bug 1457797]
-
- * generic/tclClock.c (ClockClicksObjCmd): add support for Darwin
- * generic/tclCmdMZ.c (Tcl_TimeObjCmd): nanosecond resolution timer
- * generic/tclInt.h: to [clock clicks] and [time]
- * unix/configure.in (Darwin): when TCL_WIDE_CLICKS defined
- * unix/tclUnixTime.c (TclpGetWideClicks, TclpWideClicksToNanoseconds):
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * unix/tclUnixPort.h (Darwin): override potentially faulty configure
- detection of termios availability in all cases, since termios is known
- to be present on all Mac OS X releases since 10.0. [Bug 497147]
-
-2006-08-18 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4 (Darwin): add support for --enable-64bit on x86_64, for
- universal builds including x86_64, for 64-bit CoreFoundation on
- Leopard and for use of -mmacosx-version-min instead of
- MACOSX_DEPLOYMENT_TARGET
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * generic/tcl.h: add fixes for building on Leopard and
- * unix/tclUnixPort.h: support for 64-bit CoreFoundation on Leopard
- * macosx/tclMacOSXFCmd.c:
-
- * unix/tclUnixPort.h: on Darwin x86_64, disable use of vfork as it
- causes execve to fail intermittently. (rdar://4685553)
-
- * generic/tclTomMath.h: on Darwin 64-bit, for now disable use of
- 128-bit arithmetic through __attribute__ ((mode(TI))), as it leads to
- link errors due to missing fallbacks. (rdar://4685527)
-
- * macosx/Tcl.xcodeproj/project.pbxproj: add x86_64 to universal build,
- switch native release targets to use DWARF with dSYM, Xcode 3.0
- changes
- * macosx/README: updates for x86_64 and Xcode 2.4.
-
- * macosx/Tcl.xcodeproj/default.pbxuser: add test suite target that
- * macosx/Tcl.xcodeproj/project.pbxproj: runs the tcl test suite at
- build time and shows clickable test suite errors in the GUI build
- window.
-
- * tests/macOSXFCmd.test: fix use of deprecated resource fork paths.
-
- * unix/tclUnixInit.c (TclpInitLibraryPath): move code that is only
- needed when TCL_LIBRARY is defined to run only in that case.
-
- * generic/tclLink.c (LinkTraceProc): fix 64-bit signed-with-unsigned
- comparison warning from gcc4 -Wextra.
-
- * unix/tclUnixChan.c (TclUnixWaitForFile): with timeout < 0, if
- select() returns early (e.g. due to a signal), call it again instead
- of returning a timeout result. Fixes intermittent event-13.8 failures.
-
-2006-08-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.c: Revised the new set of expression
- * generic/tclParseExpr.c: parse error messages.
-
-2006-08-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Replace PrecedenceOf() function with
- prec[] static array.
-
-2006-08-14 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * library/clock.tcl (::tcl::clock::add): Added missing braces to
- clockval validation code. Pointed out on comp.lang.tcl.
-
-2006-08-11 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclNamesp.c: Improvements in buffer management to make
- namespace creation faster. Plus selected other minor improvements to
- code quality. [Patch 1352382]
-
-2006-08-10 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- Misc patches to make code more efficient. [Bug 1530474] (afredd)
- * generic/*.c, macosx/tclMacOSXNotify.c, unix/tclUnixNotfy.c,
- * win/tclWinThrd.c: Tidy up invocations of Tcl_Panic() to promote
- string constant sharing and consistent style.
- * generic/tclBasic.c (Tcl_CreateInterp): More efficient handling of
- * generic/tclClock.c (TclClockInit): registration of commands not
- in global namespace.
- * generic/tclVar.c (Tcl_UnsetObjCmd): Remove unreachable clause.
-
-2006-08-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEncoding.c: Replace buffer copy in for loop with
- call to memcpy(). Thanks to afredd. [Patch 1530262]
-
-2006-08-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclCmdIL.c (Tcl_LassignObjCmd): Make the wrong#args message
- a bit more consistent with those used elsewhere. [Bug 1534628]
-
- * generic/tclDictObj.c (DictForCmd): Stop crash when attempting to
- iterate over an invalid dictionary. [Bug 1531184]
-
- * doc/ParseCmd.3, doc/expr.n, doc/set.n, doc/subst.n, doc/switch.n:
- * doc/tclvars.n: Ensure that uses of [expr] in documentation examples
- are also good style (with braces) unless otherwise necessary. [Bug
- 1526581]
-
-2006-08-03 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixPipe.c (TclpCreateProcess): for USE_VFORK: ensure
- standard channels are initialized before vfork() so that the child
- doesn't potentially corrupt global state in the parent's address space
-
- * tests/compExpr-old.test: add 'oldExprParser' constraint to all tests
- * tests/compExpr.test: that depend on the exact format of the
- * tests/compile.test: error messages of the pre-2006-07-05
- * tests/expr-old.test: expression parser. The constraint is on by
- * tests/expr.test: default (i.e those tests still fail), but
- * tests/for.test: can be turned off by passing '-constraints
- * tests/if.test: newExprParser' to tcltest, which will skip
- * tests/parseExpr.test: the 196 failing tests in the testsuite that
- * tests/while.test: are caused by the new expression parser
- error messages.
-
-2006-07-31 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (ConvertLocalToUTCUsingC): Corrected a regression
- that caused dates before 1969 to be one day off in the :localtime time
- zone if TZ is not set. [Bug 1531530]
-
-2006-07-30 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (GetJulianDayFromEraYearMonthDay): Corrected
- several errors in converting dates before the Common Era [Bug 1426279]
- * library/clock.tcl: Corrected syntax errors in generated code for %EC
- %Ey, and %W format groups [Bug 1505383]. Corrected a bug in cache
- management for format strings containing [glob] metacharacters [Bug
- 1494664]. Corrected several errors in formatting/scanning of years
- prior to the Common Era, and added the missing %EE format group to
- indicate the era.
- * tools/makeTestCases.tcl: Added code to make sure that %U and %V
- format groups are included in the tests. (The code depends on %U and
- %V formatting working correctly when 'makeTestCases.tcl' is run,
- rather than making a completely independent check.) Added tests for
- [glob] metacharacters in strings. Added tests for years prior to the
- Common Era.
- * tests/clock.test: Rebuilt with new test cases for all the above.
-
-2006-07-30 Joe English <jenglish@users.sourceforge.net>
-
- * doc/AppInit.3: Fix typo [Bug 1496886]
-
-2006-07-26 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrected flawed overflow detection in
- * tests/expr.test: INST_EXPON that caused [expr 2**64] to return
- 0 instead of the same value as [expr 1<<64].
-
-2006-07-24 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinSock.c: Correct uninitialized Tcl_DString. Thanks to
- afredd. [Bug 1518166]
-
-2006-07-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c:
- * tests/execute.test (execute-9.1): dgp's fix for [Bug 1522803].
-
-2006-07-20 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c (Tcl_InitNotifier, Tcl_WaitForEvent):
- create notifier thread lazily upon first call to Tcl_WaitForEvent()
- rather than in Tcl_InitNotifier(). Allows calling exeve() in processes
- where the event loop has not yet been run (Darwin's execve() fails in
- processes with more than one thread), in particular allows embedders
- to call fork() followed by execve(), previously the pthread_atfork()
- child handler's call to Tcl_InitNotifier() would immediately recreate
- the notifier thread in the child after a fork.
-
- * macosx/tclMacOSXFCmd.c (TclMacOSXCopyFileAttributes): add support
- * macosx/tclMacOSXNotify.c (Tcl_InitNotifier): for weakly
- * unix/tclUnixInit.c (Tcl_GetEncodingNameFromEnvironment): importing
- symbols not available on OSX 10.2 or 10.3, enables binaires built on
- later OSX versions to run on earlier ones.
- * macosx/Tcl.xcodeproj/project.pbxproj: enable weak-linking; turn on
- extra warnings.
- * macosx/README: document how to enable weak-linking; cleanup.
- * unix/tclUnixPort.h: add support for weak-linking; conditionalize
- AvailabilityMacros.h inclusion; only disable realpath on 10.2 or
- earlier when threads are enabled.
- * unix/tclLoadDyld.c (TclpLoadMemoryGetBuffer): change runtime Darwin
- * unix/tclUnixInit.c (TclpInitPlatform): release check to use
- global initialized
- once
- * unix/tclUnixFCmd.c (DoRenameFile, TclpObjNormalizePath): add runtime
- Darwin release check to determine if realpath is threadsafe.
- * unix/configure.in: add check on Darwin for compiler support of weak
- * unix/tcl.m4: import and for AvailabilityMacros.h header; move
- Darwin specific checks & defines that are only relevant to the tcl
- build out of tcl.m4; restrict framework option to Darwin; clean up
- quoting and help messages.
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
- * generic/regc_locale.c (cclass):
- * generic/tclExecute.c (TclExecuteByteCode):
- * generic/tclIOCmd.c (Tcl_ExecObjCmd):
- * generic/tclListObj.c (NewListIntRep):
- * generic/tclObj.c (Tcl_GetLongFromObj, Tcl_GetWideIntFromObj)
- (FreeBignum, Tcl_SetBignumObj):
- * generic/tclParseExpr.c (Tcl_ParseExpr):
- * generic/tclStrToD.c (TclParseNumber):
- * generic/tclStringObj.c (TclAppendFormattedObjs):
- * unix/tclLoadDyld.c (TclpLoadMemory):
- * unix/tclUnixPipe.c (TclpCreateProcess): fix signed-with-unsigned
- comparison and other warnings from gcc4 -Wextra.
-
-2006-07-13 Andreas Kupries <andreask@activestate.com>
-
- * unix/tclUnixPort.h: Added the inclusion of <AvailabilityMacros.h>.
- The missing header caused the upcoming #if conditions to wrongly
- exclude realpath, causing file normalize to ignore symbolic links in
- the path.
-
-2006-07-11 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclAsync.c: Made Tcl_AsyncDelete() more tolerant when called
- after all thread TSD has been garbage-collected.
-
-2006-07-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParseExpr.c: Completely new expression parser that
- builds a parse tree instead of operating with deep recursion. This
- corrects reports of stack-blowing crashes parsing long expressions
- [Bug 906201] and replaces a fundamentally O(N^2) algorithm with an
- O(N) one [RFE 903765]. The new parser is better able to generate error
- messages that clearly report both the nature and context of the syntax
- error [Bugs 1029267, 1381715]. For now, the code for the old parser is
- still present and can be activated with a "#define OLD_EXPR_PARSER
- 1". This is for the sake of a clean implementation patch, and for ease
- of benchmarking. The new parser is non-recursive, so much lighter in
- stack consumption, but it does use more heap, so there may be cases
- where parsing of long expressions that succeeded with the old parser
- will lead to out of memory panics with the new one. There are still
- more improvements possible on that point, though significant progress
- may require changes to the Tcl_Token specifications documented for the
- public Tcl_Parse*() routines.
- ***POTENTIAL INCOMPATIBILITY*** for any callers that rely on the exact
- (usually terrible) error messages generated by the old parser. This
- includes a large number of tests in the test suite.
-
- * generic/tclInt.h: Replaced TclParseWhiteSpace() with
- * generic/tclParse.c: TclParseAllWhiteSpace() which is what
- * generic/tclParseExpr.c: all the callers really needed.
- Breaking whitespace runs at newlines is useful only to the command
- parsing function, and it can call the file scoped routine
- ParseWhiteSpace() to do that.
-
- * tests/expr-old.test: Removed knownBug constraints that masked
- * tests/expr.test: failures due to revised error messages.
- * tests/parseExpr.test:
-
-2006-06-20 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c: Changed default configuration to
- * generic/tclInt.decls: #undef USE_OBSOLETE_FS_HOOKS which disables
- * generic/tclTest.c: access to the Tcl 8.3 internal routines for
- hooking into filesystem operations. Everyone ought to have migrated to
- Tcl_Filesystems by now.
- ***POTENTIAL INCOMPATIBILITY*** for any code still stuck in the
- pre-Tcl_Filesystem era.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- * generic/tclStrToD.c: Removed dead code that permitted disabling of
- recognition of the new 0b and 0o numeric formats.
-
- * generic/tclExecute.c: Removed dead code that implemented alternative
- * generic/tclObj.c: design where numeric values did not
- automatically narrow to the smallest Tcl_ObjType required to hold them
-
- * generic/tclCmdAH.c: Removed dead code that was old implementation
- of [format].
-
-2006-06-14 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tclUnixPort.h (Darwin): support MAC_OS_X_VERSION_MAX_ALLOWED
- define from AvailabilityMacros.h: override configure detection and
- only use API available in the indicated OS version or earlier.
-
-2006-06-14 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/format.n, doc/scan.n: Added examples for converting between
- characters and their numeric interpretations following user prompting.
-
-2006-06-13 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclLoadDl.c (TclpDlopen): Workaround for a compiler bug in Sun
- Forte 6. [Bug 1503729]
-
-2006-06-06 Don Porter <dgp@users.sourceforge.net>
-
- * doc/GetStdChan.3: Added recommendation that each call to
- Tcl_SetStdChannel() be accompanied by a call to Tcl_RegisterChannel().
-
-2006-06-05 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/Alloc.3: Added documentation of promise that Tcl_Realloc(NULL,x)
- is the same as Tcl_Alloc(x), as discussed in comp.lang.tcl. Also fixed
- nonsense sentence to say something meaningful.
-
-2006-05-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tcl.h (Tcl_DecrRefCount): use if/else construct to allow
- placement in unbraced outer if/else conditions. (jcw)
-
-2006-05-27 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/tclMacOSXNotify.c: implemented pthread_atfork() handler that
- * unix/tcl.m4 (Darwin): recreates CoreFoundation state and
- notifier thread in the child after a fork(). Note that pthread_atfork
- is available starting with Tiger only. Because vfork() is used by the
- core on Darwin, [exec]/[open] are not affected by this fix, only
- extensions or embedders that call fork() directly (such as TclX).
- However, this only makes fork() safe from corefoundation tcl with
- --disable-threads; as on all platforms, forked children may deadlock
- in threaded tcl due to the potential for stale locked mutexes in the
- child. [Patch 923072]
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2006-05-24 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/tcl.m4 (SC_CONFIG_SYSTEM): Fixed quoting of command script to
- awk; it was a rarely used branch, but it was wrong. [Bug 1494160]
-
-2006-05-23 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * doc/chan.n, doc/refchan.n: Tighten up the documentation to follow a
- slightly more consistent style with regard to argument capitalization.
-
-2006-05-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclProc.c (ProcCompileProc): When a bump of the compile
- epoch forces the re-compile of a proc body, take care not to overwrite
- any Proc struct that may be referred to on the active call stack. Note
- that the fix will not be effective for code that calls the private
- routine TclProcCompileProc() directly. [Bug 1482718]
-
-2006-05-13 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclEvent.c (HandleBgErrors): fix leak. [Coverity issue 86]
-
-2006-05-05 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclMain.c (Tcl_Main): Corrected flaw that required
- * tests/main.test: (Tcl_Main-4.5): processing of one interactive
- command before passing control to the loop routine registered with
- Tcl_SetMainLoop(). [Bug 1481986]
-
-2006-05-04 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bump version number to 8.5a5
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README.binary:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * generic/tclBasic.c (ExprSrandFunc): Restore acceptance of wide/big
- * doc/mathfunc.n: integer values by srand(). [Bug 1480509]
-
-2006-04-26 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5a4 TAGGED FOR RELEASE ***
-
- * changes: Updates for another RC.
-
- * generic/tclBinary.c: Revised the handling of the Q and q format
- * generic/tclInt.h: specifiers for [binary] to account for the
- * generic/tclStrToD.c: "middle endian" floating point format used in
- Nokia N770.
-
-2006-04-25 Don Porter <dgp@users.sourceforge.net>
-
- * doc/DoubleObj.3: More doc updates for TIP 237.
- * doc/expr.n:
- * doc/format.n:
- * doc/mathfunc.n:
- * doc/scan.n:
- * doc/string.n:
-
- * generic/tclScan.c: [scan $s %u] is documented to accept only
- * tests/scan.test: decimal formatted integers. Fixed to match.
-
-2006-04-19 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclStrToD.c: Added code to support the "middle endian"
- floating point format used in the Nokia N770's software-based floating
- point. Thanks to Bruce Johnson for reporting this bug, originally on
- https://wiki.tcl-lang.org/page/Nokia+770.
- * library/clock.tcl: Fixed a bug with Daylight Saving Time and Posix
- time zone specifiers reported by Martin Lemburg in
- http://groups.google.com/group/comp.lang.tcl/browse_thread/thread/9a8b15a4dfc0b7a0
- (and not at SourceForge).
- * tests/clock.test: Added test case for the above bug.
-
-2006-04-18 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/IntObj.3: Minor review fixes, including better documentation of
- the behaviour of Tcl_GetBignumAndClearObj.
-
-2006-04-17 Don Porter <dgp@users.sourceforge.net>
-
- * doc/IntObj.3: Documentation changes to account for TIP 237 changes.
- * doc/Object.3: [Bug 1446971]
-
-2006-04-12 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/regc_locale.c (cclass): Redefined the meaning of [:print:]
- to be exactly UNICODE letters, numbers, punctuation, symbols and
- spaces (*not* whitespace). [Bug 1376892]
-
-2006-04-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c: Stop some interference between enter traces
- * tests/trace.test: and enterstep traces. [Bug 1458266]
-
-2006-04-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Yet another revised fix for the [Bug 1379287]
- * tests/fileSystem.test: family of path normalization bugs.
-
-2006-04-06 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclRegexp.c (FinalizeRegexp): full reset data to indicate
- readiness for reinitialization.
-
-2006-04-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): It seems there
- * tests/indexObj.test: are extensions that rely on the prior behavior
- * doc/GetIndex.3: that the empty string cannot succeed as a
- unique prefix matcher, so I'm restoring Donal Fellows's solution.
- Added mention of this detail to the documentation. [Bug 1464039]
-
- * tests/compExpr-old.test: Updated testmathfunctions constraint
- * tests/compExpr.test: to post-TIP-232 world.
- * tests/expr-old.test:
- * tests/expr.test:
- * tests/info.test:
-
- * tests/indexObj.test: Corrected other test errors revealed by
- * tests/upvar.test: testing outside the tcltest application.
-
- * generic/tclPathObj.c: Revised fix for the [Bug 1379287] family of
- path normalization bugs.
-
-2006-04-06 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4: removed TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
- define on Darwin. [Bug 1457515]
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2006-04-05 Don Porter <dgp@users.sourceforge.net>
-
- * win/tclWinInit.c: More careful calls to Tcl_DStringSetLength()
- * win/tclWinSock.c: to avoid creating invalid DString states. Bump
- * win/tclWinDde.c: to version 1.3.2. [RFE 1366195]
- * library/dde/pkgIndex.tcl:
-
- * library/reg/pkgIndex.tcl: Bump to registry 1.2 because
- * win/tclWinReg.c: Registry_Unload() is a new public routine
- * win/Makefile.in: compared to the 1.1.* releases.
-
- * win/configure.in: Bump package version numbers.
- * win/configure: autoconf 2.59
-
-2006-04-05 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Allow empty
- strings to be matched by the Tcl_GetIndexFromObj machinery, in the
- same manner as any other key. [Bug 1464039]
-
-2006-04-03 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (ReadChars): Added check, panic and commentary to a
- piece of code which relies on BUFFER_PADDING to create enough space at
- the beginning of each buffer for the insertion of partial multibyte
- data at the beginning of a buffer. Commentary explains why this code
- is OK, and the panic is as a precaution if someone twiddled the
- BUFFER_PADDING into uselessness.
-
- * generic/tclIO.c (ReadChars): Temporarily suppress the use of
- TCL_ENCODING_END set when EOF was reached while the buffer we are
- converting is not truly the last buffer in the queue. Together with
- the Utf bug below it was possible to completely wreck the buffer data
- structures, eventually crashing Tcl. [Bug 1462248]
-
- * generic/tclEncoding.c (UtfToUtfProc): Stop accessing memory beyond
- the end of the input buffer when TCL_ENCODING_END is set and the last
- bytes of the buffer start a multi-byte sequence. This bug contributed
- to [Bug 1462248].
-
-2006-03-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: remove unused var and silence gcc warning
-
-2006-03-29 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/Makefile.in: convert _NATIVE paths to use / to avoid ".\"
- path-as-escape issue.
-
-2006-03-29 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for another RC.
-
- * generic/tclPathObj.c: More fixes for path normalization when /../
- * tests/fileSystem.test: tries to go beyond root.[Bug 1379287]
-
- * generic/tclExecute.c: Revised INST_MOD implementation to do
- calculations in native types as much as possible, moving to mp_ints
- only when necessary.
-
-2006-03-28 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinPipe.c (TclpCreateProcess): change panics to Tcl errors
- and do proper refcounting of noe objPtr. [Bug 1194429]
-
- * unix/tcl.m4, win/tcl.m4: []-quote AC_DEFUN functions.
-
-2006-03-28 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcode/default.pbxuser: add '-singleproc 1' cli arg to
- * macosx/Tcl.xcodeproj/default.pbxuser: tcltest to ease test debugging
-
- * macosx/Tcl.xcode/project.pbxproj: removed $prefix/share from
- * macosx/Tcl.xcodeproj/project.pbxproj: TCL_PACKAGE_PATH as per change
- to unix/configure.in of 2006-03-13.
-
- * unix/tclUnixFCmd.c (TclpObjNormalizePath): deal with *BSD/Darwin
- realpath() converting relative paths into absolute paths [Bug 1064247]
-
-2006-03-28 Vince Darley <vincentdarley@sourceforge.net>
-
- * generic/tclIOUtil.c: fix to nativeFilesystemRecord comparisons
- (lesser part of [Bug 1064247])
-
-2006-03-27 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinTest.c: Fixes for [Bug 1456373] (mingw-gcc issue)
-
-2006-03-27 Andreas Kupries <andreask@activestate.com>
-
- * doc/CrtChannel.3: Added TCL_CHANNEL_VERSION_5, made it the
- * generic/tcl.h: version where the "truncateProc" is defined at,
- * generic/tclIO.c: and moved all channel drivers of Tcl to v5.
- * generic/tclIOGT.c, generic/tclIORChan.c, unix/tclUnixChan.c:
- * unix/tclUnixPipe.c, win/tclWinChan.c, win/tclWinConsole.c:
- * win/tclWinPipe.c, win/tclWinSerial.c, win/tclWinSock.c:
-
-2006-03-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Merge INST_MOD computation in with the
- INST_?SHIFT instructions, which also operate only on two integral
- values. Also corrected flaw that made INST_BITNOT of wide values
- require mp_int calculations. Also corrected type that missed optimized
- handling of the tclBooleanType by the TclGetBooleanFromObj macro.
-
- * changes: Updates for another RC.
-
-2006-03-25 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Corrections to INST_EXPON detection of
- overflow to use mp_int calculations.
-
-2006-03-24 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c (TclExecuteByteCode): Added a couple of missing
- casts to 'int' that were affecting compilablity on VC6.
-
-2006-03-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEncoding.c: Reverted latest change [Bug 506653] since it
- reportedly killed test performance on Windows.
-
- * generic/tclExecute.c: Revised INST_EXPON implementation to do
- calculations in native types as much as possible, moving to mp_ints
- only when necessary.
-
-2006-03-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Merged INST_EXPON handling in with the other
- binary operators that operate on all number types (INST_ADD, etc.).
-
- * tests/env.test: With case preserved (see 2006-03-21 commit) be sure
- to do case-insensitive filtering. [Bug 1457065]
-
-2006-03-23 Reinhard Max <max@suse.de>
-
- * unix/tcl.spec: Cleaned up and completed the spec file. An RPM can
- now be built from the tcl source distribution with "rpmbuild -tb
- <tarball>"
-
-2006-03-22 Reinhard Max <max@suse.de>
-
- * tests/stack.test: Run the stack tests in subshells, so that they are
- reported as failed tests rather than bugs in the test suite if the
- recursion causes a segfault.
-
-2006-03-21 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for another RC.
-
- * generic/tclStrToD.c: One of the branches of AccumulateDecimalDigit
- * tests/parseExpr.test: did not. [Bug 1451233]
-
- * tests/env.test: Preserve case of saved env vars. [Bug 1409272]
-
-2006-03-21 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.decls: implement globbing for HFS creator & type
- * macosx/tclMacOSXFCmd.c:codes and 'hidden' flag, as documented in
- * tests/macOSXFCmd.test: glob.n; objectified OSType handling in [glob]
- * unix/tclUnixFile.c: and [file attributes]; fix globbing for
- hidden files with pattern==NULL arg. [Bug 823329]
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c: make genstubs
-
-2006-03-20 Andreas Kupries <andreask@activestate.com>
-
- * win/Makefile.in (install-libraries): Generate tcl8/8.4 directory
- under Windows as well (cygwin Makefile). Related entry: 2006-03-07,
- dgp. This moved the installation of http from 8.2 to 8.4, partially. A
- fix of the required directory creation was done for unix on Mar 10,
- without entry in the Changelog. This entry is for the fix of the
- directory creation under Windows.
-
- * unix/installManPage: There is always one even more broken "sed".
- Moved the # comment starting character in the sed script to the
- beginning of their respective lines. The AIX sed will not recognize
- them as comments otherwise :( The actual text stays indented for
- better association with the commands they belong to.
-
-2006-03-20 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * tests/cmdAH.test, tests/fCmd.test, tests/unixFCmd.test:
- * tests/winFCmd.test: Cleanup of some test constraint handling, and a
- few other minor issues.
-
-2006-03-18 Vince Darley <vincentdarley@sourceforge.net>
-
- * generic/tclFileName.c:
- * doc/FileSystem.3:
- * tests/fileName.test: Fix to [Bug 1084705] so that 'glob -nocomplain'
- finally agrees with its documentation and doesn't swallow genuine
- errors.
-
- ***POTENTIAL INCOMPATIBILITY*** for scripts that assumed '-nocomplain'
- removes the need for 'catch' to deal with non-understood path names.
-
- Small optimisation to implementation of pattern==NULL case of TclGlob,
- and clarification to the documentation. [Tclvfs bug 1405317]
-
-2006-03-18 Vince Darley <vincentdarley@sourceforge.net>
-
- * tests/fCmd.test: added knownBug test case for [Bug 1394972]
-
- * tests/winFCmd.test:
- * tests/tcltest.test: corrected tests to better account for behaviour
- of writable/non-writable directories on Windows 2000/XP. This, with
- the previous patches, closes [Bug 1193497]
-
-2006-03-17 Andreas Kupries <andreask@activestate.com>
-
- * doc/chan.n: Updated with documentation for the commands 'chan
- create' and 'chan postevent' (TIP #219).
-
- * doc/refchan.n: New file. Documentation of the command handler API
- for reflected channels (TIP #219).
-
-2006-03-17 Joe Mistachkin <joe@mistachkin.com>
-
- * unix/tclUnixPort.h: Include pthread.h prior to pthread_np.h [Bug
- 1444692]
-
- * win/tclWinTest.c: Corrected typo of 'initializeMutex' that prevented
- successful compilation.
-
-2006-03-16 Andreas Kupries <andreask@activestate.com>
-
- * doc/open.n: Documented the changed behaviour of 'a'ppend mode.
-
- * tests/io.test (io-43.1 io-44.[1234]): Rewritten to be self-contained
- with regard to setup and cleanup. [Bug 681793]
-
- * generic/tclIOUtil.c (TclGetOpenMode): Added the flag O_APPEND to the
- list of POSIX modes used when opening a file for 'a'ppend. This
- enables the proper automatic seek-to-end-on-write by the OS. See [Bug
- 680143] for longer discussion.
-
- * tests/ioCmd.test (iocmd-13.7.*): Extended the testsuite to check the
- new handling of 'a'.
-
-2006-03-15 Andreas Kupries <andreask@activestate.com>
-
- * tests/socket.test: Extended the timeout in socket-11.11 from 10 to
- 40 seconds to allow for really slow machines. Also extended
- actual/expected results with value of variable 'done' to make it
- clearer when a test fails due to a timeout. [Bug 792159]
-
-2006-03-15 Vince Darley <vincentdarley@sourceforge.net>
-
- * win/fCmd.test: add proper test constraints so the new tests don't
- run on Unix.
-
-2006-03-14 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclPipe.c (TclCreatePipeline): Modified the processing of
- pipebars to fail if the last bar is followed only by redirections.
- [Bug 768659]
-
-2006-03-14 Andreas Kupries <andreask@activestate.com>
-
- * doc/fconfigure.n: Clarified that -translation is binary is reported
- as lf when queried, because it is identical to lf, except for the
- special additional behaviour when setting it. [Bug 666770]
-
-2006-03-14 Andreas Kupries <andreask@activestate.com>
-
- * doc/clock.n: Removed double-quotes around section title NAME; not
- needed.
- * unix/installManpage: Reverted part to handle double-quotes in
- section NAME, chokes older sed installations.
-
-2006-03-14 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl (::tcl::tm::Defaults): Fixed handling of environment
- variable TCLX.y_TM_PATH, bad variable reference. Thanks to Julian
- Noble. [Bug 1448251]
-
-2006-03-14 Vince Darley <vincentdarley@sourceforge.net>
-
- * win/tclWinFile.c: updated patch to deal with 'file writable' issues
- on Windows XP/2000.
- * generic/tclTest.c:
- * unix/tclUnixTest.c:
- * win/tclWinTest.c:
- * tests/fCmd.test: updated test suite to deal with correct permissions
- setting and differences between XP/2000 and 95/98 3 tests still fail;
- to be dealt with shortly
-
-2006-03-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEncoding.c: Report error when an escape encoding is
- missing one of its sub-encodings. [Bug 506653]
-
- * unix/configure.in: Revert change from 2005-07-26 that sometimes
- * unix/configure: added $prefix/share to the tcl_pkgPath. See
- [Patch 1231015]. autoconf-2.59.
-
-2006-03-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c (ObjInterpProcEx):
- * tests/apply.test (apply-5.1): Fix [apply] error messages so that
- they quote the lambda expression. [Bug 1447355]
-
-2006-03-10 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- -- Summary of changes fixing [Bug 1437595] --
-
- * generic/tclEvent.c: Cosmetic touches and identation
- * generic/tclInt.h: Added TclpFinalizeSockets() call.
-
- * generic/tclIO.c: Calls TclpFinalizeSockets() as part of the
- TclFinalizeIOSubsystem().
-
- * unix/tclUnixSock.c: Added no-op TclpFinalizeSockets().
-
- * win/tclWinPipe.c, win/tclWinSock.c: Finalization of sockets/pipes is
- now solely done in TclpFinalizeSockets() and TclpFinalizePipes() and
- not over the thread-exit handler, because the order of actions the Tcl
- generic core will impose may result in cores/hangs if the thread exit
- handler tears down corresponding subsystem(s) too early.
-
-2006-03-10 Vince Darley <vincentdarley@sourceforge.net>
-
- * win/tclWinFile.c: previous patch breaks tests, so removed.
-
-2006-03-09 Vince Darley <vincentdarley@sourceforge.net>
-
- * win/tclWinFile.c: fix to 'file writable' in certain XP directories.
- Thanks to fvogel and jfg. [Patch 1344540] Modified patch to make use
- of existing use of getSecurityProc.
-
-2006-03-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Complete missing bit of TIP 215 implementation
- * tests/incr.test:
-
-2006-03-07 Joe English <jenglish@users.sourceforge.net>
-
- * unix/tcl.m4: Set SHLIB_LD_FLAGS='${LIBS}' on NetBSD, as per the
- other *BSD variants. [Bug 1334613]
- * unix/configure: Regenerated.
-
-2006-03-07 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Update in prep. for 8.5a4 release.
-
- * unix/Makefile.in: Package http 2.5.2 requires Tcl 8.4, so the
- * win/Makefile.in: *.tm installation has to be placed in an "8.4"
- directory, not an "8.2" directory.
-
-2006-03-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Revised handling of TCL_EVAL_* flags to
- * tests/parse.test: simplify TclEvalObjvInternal and to correct
- the auto-loading of alias targets (parse-8.12). [Bug 1444291]
-
-2006-03-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Revised yesterday's fix for [Bug 1379287] to
- work on Windows.
-
- * generic/tclObj.c: Compatibility support for existing code that
- calls Tcl_GetObjType("boolean").
-
-2006-03-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Fix for failed normalization of paths
- * tests/fileSystem.test: with /../ that lead back to the root
- of the filesystem, like /foo/.. [Bug 1379287]
-
-2006-03-01 Reinhard Max <max@suse.de>
-
- * unix/installManPage: Fix the script for manpages that have quotes
- around the .SH arguments, as doctools produces them. [Bug 1292145]
- Some minor cleanups and improvements.
-
-2006-02-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL
- * tests/namespace.test: evaluations act the same as [uplevel #0]
- * tests/parse.test: evaluations, even when execution traces or
- * tests/trace.test: invocations of [::unknown] are present. [Bug
- 1439836]
-
-2006-02-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Corrected a few bugs in how [namespace
- * tests/namespace.test: unknown] interacts with TCL_EVAL_* flags.
- [Patch 958222]
-
-2006-02-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIORChan.c: Revised error message generation and handling
- * tests/ioCmd.test: of exceptional return codes in the channel
- reflection layer. [Bug 1372348]
-
-2006-02-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIndexObj.c: Disallow the "ambiguous" error message
- * tests/indexObj.test: when TCL_EXACT matching is requested.
- * tests/ioCmd.test:
-
-2006-02-15 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIO.c: Made several routines tolerant of
- * generic/tclIORChan.c: interp == NULL arguments. [Bug 1380662]
- * generic/tclIOUtil.c:
-
-2006-02-09 Don Porter <dgp@users.sourceforge.net>
-
- TIP#215 IMPLEMENTATION
-
- * doc/incr.n: Revised [incr] to auto-initialize when varName
- * generic/tclExecute.c: argument is unset. [Patch 1413115]
- * generic/tclVar.c:
- * tests/compile.test:
- * tests/incr-old.test:
- * tests/incr.test:
- * tests/set.test:
-
- * tests/main.test (Tcl_Main-6.7): Improved robustness of
- command auto-completion test. [Bug 1422736]
-
-2006-02-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/Encoding.3, doc/encoding.n: Updates due to review at request of
- Don Porter. Mostly minor changes.
-
-2006-02-08 Don Porter <dgp@users.sourceforge.net>
-
- TIP#258 IMPLEMENTATION
-
- * doc/Encoding.3: New subcommand [encoding dirs].
- * doc/encoding.n: New routine Tcl_GetEncodingNameFromEnvironment
- * generic/tcl.decls: Made public:
- * generic/tclBasic.c: TclGetEncodingFromObj
- * generic/tclCmdAH.c: -> Tcl_GetEncodingFromObj
- * generic/tclEncoding.c:TclGetEncodingSearchPath
- * generic/tclInt.decls: -> Tcl_GetEncodingSearchPath
- * generic/tclInt.h: TclSetEncodingSearchPath
- * generic/tclTest.c: -> Tcl_SetEncodingSearchPath
- * library/init.tcl: Removed commands:
- * tests/cmdAH.test: [tcl::unsupported::EncodingDirs]
- * tests/encoding.test: [testencoding path] (Tcltest)
- * unix/tclUnixInit.c: [Patch 1413934]
- * win/tclWinInit.c:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
-2006-02-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c: minor improvements to [apply]
- * tests/apply.test: new tests; apply-5.1 currently fails to indicate
- missing work in error reporting
-
-2006-02-01 Don Porter <dgp@users.sourceforge.net>
-
- TIP#194 IMPLEMENTATION
-
- * doc/apply.n: (New file) New command [apply]. [Patch 944803]
- * doc/uplevel.n:
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * generic/tclProc.c:
- * tests/apply.test: (New file)
- * tests/proc-old.test:
- * tests/proc.test:
-
- TIP#181 IMPLEMENTATION
-
- * doc/Namespace.3: New command [namespace unknown]. New public C
- * doc/namespace.n: routines Tcl_(Get|Set)NamespaceUnknownHandler.
- * doc/unknown.n: [Patch 958222]
- * generic/tcl.decls:
- * generic/tclBasic.c:
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * tests/namespace.test:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
- TIP#250 IMPLEMENTATION
-
- * doc/namespace.n: New command [namespace upvar]. [Patch 1275435]
- * generic/tclInt.h:
- * generic/tclNamesp.c:
- * generic/tclVar.c:
- * tests/namespace.test:
- * tests/upvar.test:
-
-2006-01-26 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/dict.n: Fixed silly bug in example. Thanks to Heiner Marxen
- <heiner.marxen@unsel.de> for catching this! [Bug 1415725]
-
-2006-01-26 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/tclUnixChan.c (TclpOpenFileChannel): Tidy up and comment the
- mess to do with setting up serial channels. This (deliberately) breaks
- a broken FreeBSD port, indicates what we're really doing, and reduces
- the amount of conditional compilation sections for better maintenance.
-
-2006-01-25 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/tclUnixInit.c (TclpInitPlatform): Improved conditions on when
- to update the FP rounding mode on FreeBSD, taken from FreeBSD port.
-
-2006-01-23 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/string.test (string-12.21): Added test for [Bug 1410553] based
- on original bug report.
-
-2006-01-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclStringObj.c: fixed incorrect handling of internal rep in
- Tcl_GetRange. Thanks to twylite and Peter Spjuth. [Bug 1410553]
-
- * generic/tclProc.c: fixed args handling for precompiled bodies [Bug
- 1412695]; thanks to Uwe Traum.
-
-2006-01-16 Reinhard Max <max@suse.de>
-
- * generic/tclPipe.c (FileForRedirect): Prevent nameString from being
- freed without having been initialized.
- * tests/exec.test: Added a test for the above.
-
-2006-01-12 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclPathObj.c (Tcl_FSGetInternalRep): backported patch from
- core-8-4-branch. A freed pointer has been overwritten causing all
- sorts of coredumps.
-
-2006-01-12 Vince Darley <vincentdarley@sourceforge.net>
-
- * win/tclWinFile.c: fix to sharing violation [Bug 1366227]
-
-2006-01-11 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Moved Tcl_LogCommandInfo from tclBasic.c to
- * generic/tclNamesp.c: tclNamesp.c to get access to identifier with
- * tests/error.test (error-7.0): file scope. Added check for traces on
- ::errorInfo, and when present fall back to contruction of the stack
- trace in the variable so that write trace notification timings are
- compatible with earlier Tcl releases. This reduces, but does not
- completely eliminate the ***POTENTIAL INCOMPATIBILITY*** created by
- the 2004-10-15 commit. [Bug 1397843]
-
-2006-01-10 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/configure: add caching, use AC_CACHE_CHECK instead of
- * unix/configure.in: AC_CACHE_VAL where possible, consistent message
- * unix/tcl.m4: quoting, sync relevant tclconfig/tcl.m4 changes
- and gratuitous formatting differences, fix SC_CONFIG_MANPAGES with
- default argument, Darwin improvements to SC_LOAD_*CONFIG.
-
-2006-01-09 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c (NamespaceInscopeCmd): [namespace inscope]
- * tests/namespace.test: commands were not reported by [info level].
- [Bug 1400572]
-
-2006-01-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * generic/tclTrace.c: Stop exporting the guts of the trace command;
- nothing outside this file needs to see it. [Bug 971336]
-
-2006-01-05 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
-
- * unix/tcl.m4 (TCL_CONFIG_SYSTEM): Factor out the code to determine
- the operating system version number, as it was replicated in several
- places.
-
-2006-01-04 David Gravereaux <davygrvy@pobox.com>
-
- * win/tclAppInit.c: WIN32 native console signal handler removed. This
- was found to be interfering with TWAPI extension one. IMO, special
- services such as signal handlers should best be done with extensions
- to the core after discussions on c.l.t. about Roy Terry's tclsh
- children of a real windows service shell.
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" ***
- *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" ***
- *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/ChangeLog.2008 b/ChangeLog.2008
deleted file mode 100644
index 7bd2a01..0000000
--- a/ChangeLog.2008
+++ /dev/null
@@ -1,3796 +0,0 @@
-2008-12-31 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Set TCLLIBPATH in SHELL_ENV so that targets
- like `make shell` have access to builds of bundled packages.
-
-2008-12-28 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (Tcl_ZlibStreamPut): Plug a memory leak.
-
-2008-12-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ZlibStreamCmd): Fix compilation consistency. [Bug
- * generic/tcl.decls: 2470237]
-
- * generic/tclZlib.c (Tcl_ZlibStreamGet): Corrected the semantics of
- this function to be useful to the PNG implementation. If the argument
- object is empty, this gives the previous semantics.
- (Tcl_ZlibStreamChecksum): Corrected name to be less misleading; it
- only produced Adler-32 checksums when the stream was processing the
- right type of compressed data format.
- (Tcl_ZlibAdler32, Tcl_ZlibCRC32): Corrected types so that they work
- naturally with the results of Tcl_GetByteArrayFromObj().
- *** POTENTIAL INCOMPATIBILITY *** for all above changes, but very
- unlikely to be difficult for anyone to deal with.
-
-2008-12-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.decls: Tidy up the commenting style, adding markers for
- each of the big release points under TCT stewardship and noting the
- general purpose of each TIP that added C API. Overall effect is to
- make this file much more informative to read without having to spend
- effort correlating with TIPs and ChangeLogs.
-
-2008-12-23 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: Fix build of zlib objects with msvc
- * win/tcl.m4:
- * win/configure: autoconf-2.59
-
-2008-12-23 Donal K. Fellows <dkf@users.sf.net>
-
- * win/Makefile.in: Handle file extensions correctly. [Bug 2459725]
-
-2008-12-22 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- *** 8.6b1 TAGGED FOR RELEASE ***
-
- * win/makefile.vc: Ensure pkgs directories are suitable and quote the
- paths. [Bug 2458395]
-
-2008-12-22 Joe Mistachkin <joe@mistachkin.com>
-
- * tools/man2help2.tcl: Added support for "\(mi" nroff macro. [Bug
- 2330040]
-
-2008-12-22 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Support the pkgs tree in the NMAKE builds.
-
-2008-12-21 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: Fix broken build of bundled packages when path
- to build dir contains spaces by switching to
- relative paths to toplevel build dir.
-
- * unix/configure.in: Preserve configure environment variables for
- sub-configures of bundled packages; reuse
- configure cache file for sub-configures.
-
- * unix/configure: autoconf-2.59
-
-2008-12-21 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/TclZlib.3: Fix minor typo. [Bug 2455165]
-
-2008-12-20 Kevin B. Kenny <kennykb@acm.org>
-
- * win/Makefile.in: Renamed the static library libtcl86s.a to
- * win/configure.in: have a name distinct from the import library
- libtcl86.a. This renaming dodges an ancient
- bug in the Makefile revealed by the last
- commit where the $(TCL_LIB_FILE) rule can
- fire to try to build the static library in a
- --enable-shared build (and create a static
- library that subsequently fails to link).
- Revised the zlib objects so that they are
- built directly into the build dir, without
- building an intermediate static library.
- *** POTENTIAL INCOMPATIBILITY *** for
- embedders who link to the static library, but
- I couldn't figure out how to sort this out
- any other way.
- * win/configure: Autoconf 2.59
-
-2008-12-20 Donal K. Fellows <dkf@users.sf.net>
-
- * win/Makefile.in: Minor updates to make building work better with
- msys on Windows. (Apparently the gcc used doesn't like a / at the end
- of a -I argument...)
-
-2008-12-20 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6b1 release.
-
-2008-12-20 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: Make package install directory of bundled
- * unix/configure.in: packages configurable via PACKAGE_DIR makefile
- variable (set to platform-specific default).
-
- * unix/Makefile.in (*-packages): Ensure toplevel targets fail if
- sub-make/configure fails; fix quoting when
- builddir path contains spaces.
-
- * macosx/GNUmakefile: Add install-packages to install targets.
-
- * unix/configure: autoconf-2.59
-
-2008-12-19 Don Porter <dgp@users.sourceforge.net>
-
- * doc/NRE.3: Formatting errors found by `make html`
- * doc/Tcl_Main.3:
- * doc/zlib.n:
-
- * tests/chanio.test: Add missing [removeFile] cleanups.
- * tests/io.test: Add missing [close $f] to io-73.2.
-
- * unix/Makefile.in: Update `make dist' target to include the files
- from the compat/zlib directory as well as all the bundled packages
- found under the pkgs directory, according to their individual `make
- dist' targets. Change includes breaking a `configure-packages' target
- out of the `packages` target.
-
- * README: Bump version number to 8.6b1
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2008-12-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: CONSTify TclGetLoadedPackages second param
- * generic/tclLoad.c
- * generic/tclIntDecls.h (regenerated)
-
-2008-12-19 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclExecute.c: Fix compile warnings when --enable-symbols=all
-
- * win/configure.in:
- * win/Makefile.in: Added build of packages in the 'pkgs/' directory.
- * win/configure: Autoconf 2.59
-
-2008-12-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: Added build of compat/zlib
-
-2008-12-18 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (Tcl_CloseEx, CloseWrite, CloseChannelPart)
- (ChanCloseHalf): Rewrite the half-close to properly flush the channel,
- like is done for a full close, going through FlushChannel, and using
- the flag BG_FLUSH_SCHEDULED (async flush during close). New functions
- CloseWrite, CloseChannelPart, new flag CHANNEL_CLOSEDWRITE.
-
- * tests/chanio.test (chanio-28.[67]): Reactivated these tests.
- Replaced tclsh -> [interpreter] to get correct executable for the pipe
- process, and added after cancel to kill the fail timers when we are
- done. Removed the explicits calls to [flush], now that [close] handles
- this correctly.
-
-2008-12-18 Don Porter <dgp@users.sourceforge.net>
-
- * tests/chanio.test: Replaced [chan event] handlers that returned
- TCL_RETURN return code, with more conventional ones that return TCL_OK
- to suppress otherwise strange writes of outdated $::errorInfo values
- to stderr. [Bug 2444274]
-
- * generic/tclExecute.c: Disabled apparently faulty assertion. [Bug
- 2415422]
-
-2008-12-18 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/configure.in, unix/Makefile.in: Autoconf wizardry.
- * compat/zlib/*: Import of zlib 1.2.3. The license is directly
- compatible with Tcl's. This import omits the obsolete and contributed
- parts (i.e. selected directories) and the supplied examples.
-
- * generic/tclZlib.c: First implementation of the compressing and
- * doc/zlib.n: decompressing channel transformations.
- * tests/zlib.test (zlib-8.*):
-
-2008-12-18 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls: VOID -> void
- * generic/tclInt.decls:
- * compat/dlfcn.h:
- * generic/tclDecls.h: (regenerated)
- * generic/tclIntDecls.h:
-
-2008-12-18 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- TIP #332 IMPLEMENTATION - Half-Close for Bidirectional Channels
-
- * doc/close.n, generic/tclIO.c, generic/tclIOCmd.c:
- * unix/tclUnixChan.c, unix/tclUnixPipe.c, win/tclWinSock.c:
- * generic/tcl.decls, generic/tclDecls.h, generic/tclStubInit.c:
- * tests/chan.test, tests/chanio.test, tests/ioCmd.test:
-
-2008-12-17 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/SetChanErr.3: General improvements in nroff rendering and some
- corrections to language issues.
-
-2008-12-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclResult.c: Move variable "length" inside if()
- * generic/tclStringObj.c: Don't use ckfree((void *)...) but
- * generic/tclVar.c: ckfree((char *)...)
- * generic/tclZlib.c
- * generic/tclBasic.c
-
-2008-12-17 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/namespace.test (namespace-28.1): Make tests not
- * tests/namespace-old.test (namespace-old-9.5): dependent on the
- global namespace's particular imports. [Bug 2433936]
-
-2008-12-17 Don Porter <dgp@users.sourceforge.net>
-
- * unix/Makefile.in: Modify the distclean-packages target so that
- empty build directories are deleted.
-
- * unix/Makefile.in: Add build support for collections of TEA
- * unix/configure.in: packages found under the pkgs directory.
- [Patch 1163406]. Still needs porting to Windows.
-
- * unix/configure: autoconf-2.59
-
-2008-12-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.h, generic/tclZlib.c: Removed undocumented flag.
-
-2008-12-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclThreadTest.c: Eliminate -Wwrite-strings warnings in
- --enable-threads build.
- * generic/tclExecute.c: Use TclNewLiteralStringObj()
- * unix/tclUnixFCmd.c: Use TclNewLiteralStringObj()
- * win/tclWinFCmd.c: Use TclNewLiteralStringObj()
-
-2008-12-16 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #329 IMPLEMENTATION
-
- * tests/error.test: Tests for the new commands.
- * doc/throw.n, doc/try.n: Documentation of the new commands.
- * library/init.tcl (throw, try): Implementation of commands documented
- in TIP. This implementation is in Tcl and is a stop-gap until
- higher-performance ones can be written.
-
-2008-12-16 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Add TIP 338 routines to stub table.
- * generic/tcl.decls: [Bug 2431338]
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2008-12-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclExecute.c (TEBC:INST_DICT_GET): Make sure that the result
- is empty when generating an error message. [Bug 2431847]
-
-2008-12-15 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclBinary.c: Redefine non-strict decoding to ignore only
- * doc/binary.n: whitespace. [Bug 2380293]
- * tests/binary.test:
-
-2008-12-15 Don Porter <dgp@users.sourceforge.net>
-
- * doc/AddErrInfo.3: Documented Tcl_(Set|Get)ErrorLine (TIP 336).
- * doc/CrtCommand.3: Various other documentation updates to
- * doc/CrtInterp.3: reflect the lack of access to Tcl_Interp
- * doc/Interp.3: fields by default.
- * doc/SetResult.3:
- * doc/tcl.decls:
-
- TIP #338 IMPLEMENTATION
-
- * doc/AppInit.c: Made routines Tcl_SetStartupScript and
- * doc/Tcl_Main.3: Tcl_GetStartupScript public. Removed all
- * generic/tcl.h: internal stub access to Tcl*Startup* routines,
- * generic/tclInt.decls: and removed their implementations. Their
- * generic/tclMain.c: function can now be completely performed with
- the new public interface.
- *** POTENTIAL INCOMPATIBILITY for callers of the internal
- Tcl*Startup* routines. ***
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
-
-2008-12-14 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/zlib.test: Added constraint so that tests don't fail where
- they cannot work due to zlib support being missing.
-
- * unix/configure.in, win/configure.in: Improve the autodetection code.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove the assumption of the presence
- of zlib library on Windows.
- * win/makefile.vc, win/makefile.bc: Add support for building tclZlib.o
- but only in stubbed-out mode for now.
-
-2008-12-13 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/TclZlib.3: Basic documentation of the C-level API.
- * doc/zlib.n: Substantially improve documentation of Tcl-level API.
- * generic/tclZlib.c (ZlibCmd): Flesh out the argument parsing for the
- command to integrate with channels.
-
-2008-12-12 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclZlib.c (Tcl_ZlibInflate): Change PATH_MAX to MAXPATHLEN,
- since MSVC doesn't have PATH_MAX.
-
- * doc/clock.n: Document new DST fallback rules.
- * library/clock.tcl (ProcessPosixTimeZone): Fix time change in Eastern
- Europe (not 3:00 but 4:00 local time). [Bug 2207436]
-
-2008-12-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c, unix/configure.in: Added stubs to use when the
- version of zlib is not capable enough, and automagic to detect when
- that is the case. [Bug 2421265]
-
-2008-12-12 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * unix/tclUnixNotfy.c: Fix missing CLOEXEC on internal pipes [2417695]
- * unix/tclUnixPipe.c: Fix missing CLOEXEC on [chan pipe] fds.
-
-2008-12-12 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (Tcl_ZlibDeflate): Add a bit of extra space for
- the gzip header. [Bug 2419061]
- (Tcl_ZlibInflate): Ensure that gzip header extraction is done
- correctly.
-
-2008-12-12 Kevin Kenny <kennykb@acm.org>
-
- TIP #322 IMPLEMENTATION
-
- * doc/NRE.3 (new file): Added documentation of the published API for
- Non-Recursive Evaluation (NRE).
-
-2008-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclZlib.c: Eliminate warning: different 'const' qualifiers
- with msvc compiler. A few more 'const' optimizations.
- * win/tcl.m4: Fix Windows build (msvc) for TIP #234 implementation
- * win/Makefile.in:
- * win/configure:
-
-2008-12-11 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (SetChannelFromAny and related): Modified the
- * tests/io.test: internal representation of the tclChannelType to
- contain not only the ChannelState pointer, but also a reference to
- the interpreter it was made in. Invalidate and recompute the
- internal representation when it is used in a different interpreter,
- like cmdName intrep's. Added testcase. [Bug 2407783]
-
-2008-12-11 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclZlib.c (ConvertError): Factor out code to turn zlib
- errors into Tcl errors.
-
- * doc/zlib.n: Added a start at the documentation. Still very rough.
-
-2008-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/Makefile.in: Fix Windows build (mingw) for TIP #234
- implementation (additionally, first make sure that zlib is available,
- and rename the standard zdll.lib to libz.a, but at least this works so
- far).
-
-2008-12-11 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/zlib.test: Start of test suite for zlib command.
-
-2008-12-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * library/clock.tcl (ProcessPosixTimeZone): Fallback to European time
- zone DST rules, when the timezone is between 0 and -12. [Bug 2207436]
- * tests/clock.test (clock-52.[23]): Test cases for [Bug 2207436]
-
-2008-12-11 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #234 IMPLEMENTATION
-
- * generic/tclZlib.c: A very preliminary hack at an interface to the
- zlib library, based on code from Pascal Scheffers.
- WARNING! The C API may be subect to change without much warning! USE
- AT YOUR OWN RISK!
-
-2008-12-10 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/*: Update from Olson's tzdata2008i.
-
-2008-12-10 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- TIP #343 IMPLEMENTATION - A Binary Specifier for [format/scan]
-
- * doc/format.n
- * doc/scan.n
- * generic/tclInt.h
- * generic/tclScan.c
- * generic/tclStrToD.c
- * generic/tclStringObj.c
- * tests/format.test
- * tests/scan.test
-
-2008-12-10 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #341 IMPLEMENTATION
-
- * generic/tclDictObj.c (DictFilterCmd): Made key and value filtering
- * tests/dict.test, doc/dict.n: accept arbitrary numbers of
- glob arguments.
-
-2008-12-09 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: Restore source and binary compatibility for
- TIP #337 implementation. (When it is _that_
- simple, there is no excuse not to do it! :-))
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2008-12-09 Don Porter <dgp@users.sourceforge.net>
-
- TIP #337 IMPLEMENTATION
-
- * doc/BackgdErr.3: Converted internal routine
- * doc/interp.n: TclBackgroundException() into public routine
- * generic/tcl.decls: Tcl_BackgroundException().
- * generic/tclEvent.c:
- * generic/tclInt.decls:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
-
- * generic/tclIO.c: Update callers.
- * generic/tclIOCmd.c:
- * generic/tclInterp.c:
- * generic/tclTimer.c:
- *** POTENTIAL INCOMPATIBILITY only for extensions using the converted
- internal routine ***
-
-2008-12-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIO.c (ChanClose,ChanRead,...): Factored out some of the
- code to connect to channel drivers that was common in multiple
- locations so as to make code more readable.
-
-2008-12-06 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (FileTempfileCmd): Force temporary files to be
- created in the native filesystem. Attempting to provide a template
- that puts it elsewhere will result in the directory part of the
- template being ignored. Partial address of [Bug 2388866] concerns.
-
-2008-12-05 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #335 IMPLEMENTATION
-
- * generic/tclBasic.c (Tcl_InterpActive): Added function for working
- * doc/CrtInterp.3: out if an interp is in use.
-
- TIP #307 IMPLEMENTATION
-
- * generic/tclResult.c (Tcl_TransferResult): Renamed function from
- * generic/tcl.decls: TclTransferResult. Added
- * doc/SetResult.3: to public stubs table.
-
-2008-12-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c (Tcl_FSGetNormalizedPath): Added another
- flag value TCLPATH_NEEDNORM to mark those intreps which need more
- complete normalization attention for correct results. [Bug 2385549]
-
-2008-12-03 Donal K. Fellows <dkf@users.sf.net>
-
- * win/tclWinPipe.c (TclpOpenTemporaryFile): Avoid an infinite loop due
- to GetTempFileName/CreateFile interaction. [Bug 2380318]
-
-2008-12-03 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c (DoGlob): One of the Tcl_FSMatchInDirectory
- calls did not have its return code checked. This caused error messages
- returned by some Tcl_Filesystem drivers to be swallowed.
-
-2008-12-02 Don Porter <dgp@users.sourceforge.net>
-
- TIP #336 IMPLEMENTATION
-
- * generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine.
- * generic/tcl.h: Dropped default access to interp->errorLine.
- * generic/tclCmdAH.c: Restore it with -DUSE_INTERP_ERRORLINE.
- * generic/tclCmdMZ.c: Updated callers.
- * generic/tclDictObj.c:
- * generic/tclIOUtil.c:
- * generic/tclNamesp.c:
- * generic/tclOOBasic.c:
- * generic/tclOODefinedCmds.c:
- * generic/tclOOMethod.c:
- * generic/tclProc.c:
- * generic/tclResult.c:
- *** POTENTIAL INCOMPATIBILITY for C code directly using the
- interp->errorLine field ***
-
- * generic/tclDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2008-12-02 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre
- Ferrieux's first patch for [Bug 2270477] with a gentler version, also
- supplied by him.
-
-2008-12-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c: Coding standards fixups.
-
-2008-12-01 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/cmdAH.test (cmdAH-32.6): Test was not portable; depended on a
- C API function not universally available. [Bug 2371623]
-
-2008-11-30 Kevin B. Kenny <kennykb@acm.org>
-
- * library/clock.tcl (format, ParseClockScanFormat): Added a [string
- map] to get rid of namespace delimiters before caching a scan or
- format procedure. [Bug 2362156]
- * tests/clock.test (clock-64.[12]): Added test cases for the bug that
- was tickled by a namespace delimiter inside a format string.
-
-2008-11-29 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #210 IMPLEMENTATION
-
- * generic/tclCmdAH.c (FileTempfileCmd):
- * unix/tclUnixFCmd.c (TclpOpenTemporaryFile, DefaultTempDir):
- * win/tclWinPipe.c (TclpOpenTemporaryFile):
- * doc/file.n, tests/cmdAH.test: Implementation of [file tempfile]. I
- do not claim that this is a brilliant implementation, especially on
- Windows, but it covers the main points.
-
- * generic/tclThreadStorage.c: General revisions to make code clearer
- and more like the style used in the rest of the core. Includes adding
- more comments and explanation of what is going on. Reduce the amount
- of locking required.
-
-2008-11-27 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tcl.h: Alternate fix for [Bug 2251175]: missing
- * generic/tclCompile.c: backslash substitution on expanded literals.
- * generic/tclParse.c:
- * generic/tclTest.c:
- * tests/parse.test:
-
-2008-11-26 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIndexObj.c: Eliminate warning: unused variable
- * generic/tclTest.c: A few more (harmless) Tcl_SetResult
- eliminations.
-
-2008-11-26 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tclIndex: Removed reference to no-longer-extant procedure
- 'tclLdAout'.
- * doc/library.n: Corrected mention of 'auto_exec' to 'auto_execok'.
- [Patch 2114900] thanks to Stuart Cassoff <stwo@users.sf.net>
-
-2008-11-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclIndexObj.c: Eliminate 3 calls to Tcl_SetResult, as
- * generic/tclIO.c: examples how it should have been done.
- * generic/tclTestObj.c: purpose: contribute in the TIP #340
- discussion.
-
-2008-11-25 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (TclFinalizeIOSubsystem): Applied Alexandre
- Ferrieux's patch for [Bug 2270477] to prevent infinite looping during
- finalization of channels not bound to interpreters.
-
-2008-11-25 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Don't assume that Tcl_SetResult sets
- interp->result, especially not in a DString test, in preparation for
- TIP #340
-
-2008-11-24 Donal K. Fellows <dkf@users.sf.net>
-
- * tools/tcltk-man2html.tcl: Improvements to tackle tricky aspects of
- cross references and new entities to map. [Bug 2330040]
-
-2008-11-19 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclThreadTest.c: Convert Tcl_SetResult(......, TCL_DYNAMIC)
- to Tcl_SetResult(......, TCL_VOLATILE), in preparation for TIP #340
-
-2008-11-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.decls: Fix signature and implementation of
- * generic/tclDecls.h: Tcl_HashStats, such that it conforms to the
- * generic/tclHash.c: documentation. [Bug 2308236]
- * generic/tclVar.c:
- * doc/Hash.3:
- * generic/tclDictObj.c: Convert Tcl_SetResult call to
- Tcl_SetObjResult.
-
-2008-11-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/for.test: Check for uncompiled-for-continue [Bug 2186888]
- fixed earlier.
-
- * generic/tcl.h: Fix [Bug 2251175]: missing backslash
- * generic/tclCompCmds.c: substitution on expanded literals.
- * generic/tclCompile.c
- * generic/tclParse.c
- * generic/tclTest.c
- * tests/compile.test
- * tests/parse.test
-
-2008-11-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclTest.c: Replace two times Tcl_SetResult with
- Tcl_SetObjResult, a little simplification in preparation for the TIP
- #340 patch.
-
-2008-11-13 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Rename static function FSUnloadTempFile to
- * generic/tclIOUtil.c: TclFSUnloadTempFile, needed in tclLoad.c
-
- * generic/tclLoad.c: Fixed [Bug 2269431]: Load of shared
- objects leaves temporary files on windows.
-
-2008-11-12 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/registry.test: Use HKCU to avoid requiring admin access for
- registry testing on Vista/Server2008
-
-2008-11-11 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclNamesp.c: Eliminate warning: passing arg 4 of
- Tcl_SplitList from incompatible pointer type.
- * win/tcl.m4: Reverted change from 2008-11-06 (was under the
- impression that "-Wno-implicit-int" added an extra
- warning)
- * win/configure: (regenerated)
- * unix/tcl.m4: Use -O2 as gcc optimization compiler flag, and get rid
- of -Wno-implicit-int for UNIX.
- * unix/configure: (regenerated)
-
-2008-11-10 Andreas Kupries <andreask@activestate.com>
-
- * doc/platform_shell.n: Fixed [Bug 2255235], reported by Ulrich
- * library/platform/pkgIndex.tcl: Ring <uring@users.sourceforge.net>.
- * library/platform/shell.tcl: Updated the LOCATE command in the
- * library/tm.tcl: package 'platform::shell' to handle the new form
- * unix/Makefile.in: of 'provide' commands generated by tm.tcl. Bumped
- * win/Makefile.in: package to version 1.1.4. Added cross-references
- to the relevant parts of the code to avoid future desynchronization.
-
-2008-11-07 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclInt.h: Applied [Patch 2215022] from Duoas to clean up
- * generic/tclBinary.c: the binary ensemble initiailization code.
- * generic/tclNamesp.c: Extends the TclMakeEnsemble to do
- * doc/ByteArrObj.3: sub-ensembles from tables.
-
-2008-11-06 Jan Nijtmans <nijtmans@users.sf.net>
-
- * win/tcl.m4: Add "-Wno-implicit-int" flag for gcc, as on UNIX
- * win/configure: (regenerated)
- * generic/tclIO.c: Eliminate an 'array index out of bounds' warning
- on HP-UX.
-
-2008-11-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclPort.h: Remove the ../win/ header dir as the build system
- already has it, and it confuses builds when used with private headers
- installed.
-
-2008-11-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.h (TCLOO_VERSION): Bump version of TclOO.
-
-2008-10-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOONRUpcatch): Reworked the code that does
- * generic/tclOO.c (InitFoundation): class constructor handling so
- that it is more robust and runs the constructor call in the context of
- the caller of the class's constructor method. Needed because the
- previously used code did not work at all after applying the fix below;
- no Tcl existing command could reliably do what was needed any more.
-
- * generic/tclOODefineCmds.c (GetClassInOuterContext): Rework and
- factor out the code to resolve class names in definitions so that
- classes are resolved from the perspective of the caller of the
- [oo::define] command, rather than from the oo::define namespace! This
- makes much code simpler by reducing how often fully-qualified names
- are required (previously always in practice, so no back-compat issues
- exist). [Bug 2200824]
-
-2008-10-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCompile.h: CONSTify TclDTraceInfo
- * generic/tclBasic.c:
- * generic/tclProc.c:
- * generic/tclEnv.c: Eliminate some -Wwrite-strings warnings
- * generic/tclLink.c:
-
-2008-10-27 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclEncoding.c: Use "iso8859-1" and not "identity" as
- the default and original [encoding system] value. Since "iso8859-1" is
- built in to the C source code for Tcl now, there's no availability
- issue, and it has the good feature of "identity" that we must have
- ("bytes in" == "bytes out") without the bad feature of "identity"
- ("broken as designed") that makes us want to abandon it. [RFE 2008609]
- *** POTENTIAL INCOMPATIBILITY for older releases of Tclkit and any
- other code expecting a particular value for Tcl's default system
- encoding ***
-
-2008-10-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: Fixed a failure to read SHOUTcast streams
- with the new 2.7 package. Introduced a new intial state as the first
- response may not be HTTP*.
-
-2008-10-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdAH.c (ForNextCallback): handle TCL_CONTINUE in the for
- body. [Bug 2186888]
-
-2008-10-22 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tcl.h: CONST -> const and white-spacing
- * generic/tclCompile.h:
- * generic/tclEncoding.c:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c:
- * generic/tcl.decls
- * generic/tclInt.decls
- * generic/tclTomMath.decls
- * generic/tclDecls.h: (regenerated)
- * generic/tclIntDecls.h: (regenerated)
- * generic/tclIntPlatDecls.h: (regenerated)
- * generic/tclOODecls.h: (regenerated)
- * generic/tclOOIntDecls.h: (regenerated)
- * generic/tclPlatDecls.h: (regenerated)
- * generic/tclTomMathDecls.h: (regenerated)
- * generic/tclIntDecls.h: (regenerated)
- * tools/genStubs.tcl: CONST -> const and white-spacing
-
-2008-10-19 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclProc.c: Reset -level and -code values to defaults
- after they are used. [Bug 2152286]
-
-2008-10-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (TclInfoCoroutineCmd): Added code to make this
- check for being invoked in a syntactically correct way.
-
- * doc/info.n: Added documentation of [info coroutine].
-
- * doc/prefix.n: Improved the documentation by fixing formatting,
- adding good-practice recommendations and cross-references, etc.
-
-2008-10-17 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclOO.decls: CONST -> const.
- * generic/tclOODecls.h: (regenerated)
- * generic/tclOOIntDecls.h: (regenerated)
-
-2008-10-17 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORTrans.c (DeleteReflectedTransformMap): Removed debug
- output in C++ comment.
-
-2008-10-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompile.h: Declare the internal tclInstructionTable to
- * generic/tclExecute.c: simply be "const", not CONST86.
-
- * generic/tclCmdAH.c: whitespace.
- * generic/tclCmdIL.c: Uninitialized variable warning.
- * generic/tclTest.c: const correctness warning.
-
-2008-10-17 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/*: Many very small formatting fixes.
- * doc/{glob,http,if}.n: More substantial reformatting for clarity.
- * doc/split.n: Remove mention of defunct c.l.t.announce
-
-2008-10-16 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/regc_locale.c: Add "const" to many internal const tables.
- * generic/tclClock.c: No functional or API change.
- * generic/tclCmdIL.c
- * generic/tclConfig.c
- * generic/tclDate.c
- * generic/tclEncoding.c
- * generic/tclEvent.c
- * generic/tclExecute.c
- * generic/tclFileName.c
- * generic/tclGetDate.y
- * generic/tclInterp.c
- * generic/tclIO.c
- * generic/tclIOCmd.c
- * generic/tclIORChan.c
- * generic/tclIORTrans.c
- * generic/tclLoad.c
- * generic/tclObj.c
- * generic/tclOOBasic.c
- * generic/tclOOCall.c
- * generic/tclOOInfo.c
- * generic/tclPathObj.c
- * generic/tclPkg.c
- * generic/tclResult.c
- * generic/tclStringObj.c
- * generic/tclTest.c
- * generic/tclTestObj.c
- * generic/tclThreadTest.c
- * generic/tclTimer.c
- * generic/tclTrace.c
- * macosx/tclMacOSXFCmd.c
- * win/cat.c
- * win/tclWinInit.c
- * win/tclWinTest.c
-
-2008-10-16 Don Porter <dgp@users.sourceforge.net>
-
- * library/init.tcl: Revised [unknown] so that it carefully
- preserves the state of the ::errorInfo and ::errorCode variables at
- the start of auto-loading and restores that state before the
- autoloaded command is evaluated. [Bug 2140628]
-
-2008-10-15 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.h: Add "const" to many internal const tables, so
- * generic/tclBinary.c: those will be put by the C-compiler in the
- * generic/tclCompile.c: TEXT segment in stead of the DATA segment.
- * generic/tclDictObj.c: This makes those tables sharable in shared
- * generic/tclHash.c: libraries.
- * generic/tclListObj.c:
- * generic/tclNamesp.c:
- * generic/tclObj.c:
- * generic/tclProc.c:
- * generic/tclRegexp.c:
- * generic/tclStringObj.c:
- * generic/tclUtil.c:
- * generic/tclVar.c:
-
-2008-10-14 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclCmdAH.c: Fix minor compiler warnings when compiling
- * generic/tclCmdMZ.c: with -Wwrite-strings.
- * generic/tclIndexObj.c:
- * generic/tclProc.c:
- * generic/tclStubLib.c:
- * generic/tclUtil.c:
- * win/tclWinChan.c:
- * win/tclWinDde.c:
- * win/tclWinInit.c:
- * win/tclWinReg.c:
- * win/tclWinSerial.c:
-
-2008-10-14 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/binary.n: Formatting fix.
-
-2008-10-14 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bump version number to 8.6a4
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * generic/tclExecute.c: Fix compile warnings when --enable-symbols=all
-
- * generic/tclCmdIL.c: Fix write to unallocated memory whenever
- [lrepeat] returns an empty list.
-
-2008-10-14 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n, doc/fconfigure.n: Added even more emphatic text to
- direct people to the correct manual pages for specific channel types,
- suitable for the hard-of-reading. Following discussion on tcl-core.
-
-2008-10-13 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/tclWinThrd.c (TclpThreadCreate): We need to initialize the
- thread id variable to 0 as on 64 bit windows this is a pointer sized
- field while windows only fills it with a 32 bit value. The result is
- an inability to join the threads as the ids cannot be matched.
-
- * generic/tclTest.c (TestNRELevels): Set array to the right size.
-
-2008-10-13 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOInfo.c (InfoClassDestrCmd): Handle error case.
-
- * generic/tclOOInt.h: Added macro magic to make things work with
- Objective C. [Bug 2163447]
-
-2008-10-12 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: Fix bug in srcDelta encoding within ByteCodes.
- The bug can only be triggered under conditions that cannot happen in
- Tcl, but were met during development of L. Thanks go to Robert Netzer
- for diagnosis and fix.
-
-2008-10-10 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6a3 TAGGED FOR RELEASE ***
-
- * changes: Updates for 8.6a3 release.
-
-2008-10-10 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOODefineCmds.c (TclOODefineUnexportObjCmd)
- (TclOODefineExportObjCmd): Corrected export/unexport record synthesis.
- [Bug 2155658]
-
-2008-10-08 Jan Nijtmans <nijtmans@users.sf.net>
-
- * unix/tclUnixChan.c: Fix minor compiler warning.
- * unix/tcl.m4: Fix for [Bug 2073255]
- * unix/configure: Regenerated
-
-2008-10-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic (TclInfoCoroutineCmd):
- * tests/unsupported.test: Arrange for [info coroutine] to return {}
- when a coroutine is running but the resume command has been deleted.
- [Bug 2153080]
-
-2008-10-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTrace.c: Corrected handling of errors returned by
- variable traces so that the errorInfo value contains the original
- error message. [Bug 2151707]
-
- * generic/tclVar.c: Revised implementation of TclObjVarErrMsg so
- that error message construction does not disturb an existing
- iPtr->errorInfo that may be in progress.
-
-2008-10-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/binary.n: Added better documentation of the [binary encode] and
- [binary decode] subcommands.
-
-2008-10-07 Miguel Sofer <msofer@users.sf.net>
-
- TIP #327,#328 IMPLEMENTATIONS
-
- * generic/tclBasic.c: Move [tailcall], [coroutine] and
- * generic/tclCmdIL.c: [yield] out of ::tcl::unsupported
- * tclInt.h:
- * tests/info.test: and into global scope: TIPs #327
- * tests/unsupported.test: and #328
-
-2008-10-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/chan.n, doc/transchan.n: Documented the channel transformation
- API of TIP #230.
-
-2008-10-06 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * tests/winFCmd.test: Fixed some erroneous tests on Vista+.
- * generic/tclFCmd.c: Fix constness for msvc of last commit
-
-2008-10-06 Joe Mistachkin <joe@mistachkin.com>
-
- * tools/man2tcl.c: Added missing line from patch by Harald Oehlmann.
- [Bug 1934200]
-
-2008-10-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/FileSystem.3: CONSTified Tcl_FSFileAttrStringsProc
- * generic/tclFCmd.c: and tclpFileAttrStrings. This allows
- * generic/tclIOUtil.c: FileSystems to report their attributes
- * generic/tclTest.c: as const strings, without worrying that
- * unix/tclUnixFCmd.c: Tcl modifies them (which Tcl should not
- * win/tclWinFCmd.c: do anyway, but the API didn't indicate that)
- * generic/tcl.decls
- * generic/tclDecls.h: regenerated
- * generic/tcl.h: Make sure that if CONST84 is defined as empty,
- CONST86 should be defined as empty as well
- (unless overridden). This change complies with
- TIP #27
- *** POTENTIAL INCOMPATIBILITY ***
-
-2008-10-05 Kevin B, Kenny <kennykb@acm.org>
-
- * libtommath/bn_mp_sqrt.c (bn_mp_sqrt): Handle the case where a
- * tests/expr.test (expr-47.13): number's square root is
- between n<<DIGIT_BIT and n<<DIGIT_BIT+1. [Bug 2143288]
- Thanks to Malcolm Boffey (malcolm.boffey@virgin.net) for the patch.
-
- TIP #331 IMPLEMENTATION
-
- * doc/lset.n:
- * generic/tclListObj.c (TclLsetFlat):
- * tests/lset.test: Modified the [lset] command so that it allows for
- an index of 'end+1', which has the effect of appending an element to
- the list.
-
-2008-10-05 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclInt.decls: CONSTified the AuxDataType argument
- * generic/tclCompCmds.c: of TclCreateAuxData and
- * generic/tclCompile.c: TclRegisterAuxDataType and the return
- * generic/tclCompile.h: values of TclGetAuxDataType and
- * generic/tclExecute.c: TclGetInstructionTable
- * generic/tclIntDecls.h: regenerated
- This change complies with TIP #27 (even though it only involves
- internal function, so this is not even necessary).
-
-2008-10-05 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclIndexObj.c (TclInitPrefixCmd): Make the [tcl::prefix]
- into an exported command. [Bug 2144595]
-
-2008-10-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdIL.c (InfoFrameCmd): Improved hygiene of result
- * generic/tclRegexp.c (TclRegAbout): handling.
-
-2008-10-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/tclLoad.c: Make sure that any library which doesn't have an
- unloadproc is only really unloaded when no library code is executed
- yet. [Bug 2059262]
-
-2008-10-04 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOInfo.c (GetClassFromObj): Factor out the code to parse
- a Tcl_Obj and get a class. Also make result handling hygienic.
- * generic/tclOOBasic.c (TclOOSelfObjCmd): Better hygiene of results,
- and stop allocating quite so much memory by sharing special "method"
- names.
-
-2008-10-04 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/ChnlStack.3: CONSTified the typePtr argument
- * doc/CrtChannel.3: of Tcl_CreateChannel and Tcl_StackChannel
- * generic/tcl.decls: and the return value of Tcl_GetChannelType
- * generic/tcl.h
- * generic/tclIO.h
- * generic/tclIO.c
- * generic/tclDecls.h: regenerated
- This change complies with TIP #27.
-
- * doc/Hash.3: CONSTified the typePtr argument
- * generic/tcl.decls: of Tcl_InitCustomHashTable.
- * generic/tcl.h
- * generic/tclHash.c
- * generic/tclDecls.h: regenerated
- This change complies with TIP #27.
-
- * doc/RegConfig.3: CONSTified the configuration argument
- * generic/tcl.decls: of Tcl_RegisterConfig.
- * generic/tcl.h
- * generic/tclConfig.c
- * generic/tclPkgConfig.c
- * generic/tclDecls.h: regenerated
- This change complies with TIP #27.
-
- * doc/GetIndex.3: CONSTified the tablePtr argument
- * generic/tcl.decls: of Tcl_GetIndexFromObj.
- * generic/tclIndexObj.c
- * generic/tclDecls.h: regenerated
- This change complies with TIP #27.
-
-2008-10-03 Miguel Sofer <msofer@users.sf.net>
-
- * tests/stack.test:
- * unix/tclUnixTest.c: Removed test command teststacklimit and the
- corresponding constraint: it is not needed with NRE
-
-2008-10-03 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #195 IMPLEMENTATION
-
- * generic/tclIndexObj.c (TclGetIndexFromObjList, PrefixMatchObjCmd)
- * doc/prefix.n, tests/string.test: Added [tcl::prefix] command for
- working with prefixes of strings at the Tcl level. [Patch 1040206]
-
- TIP #265 IMPLEMENTATION
-
- * generic/tclIndexObj.c (Tcl_ParseArgsObjv, PrintUsage):
- * generic/tcl.h (Tcl_ArgvInfo): Added function for simple parsing of
- * doc/ParseArgs.3 (new file): optional arguments to commands. Still
- needs tests and the like. [FRQ 1446696] Note that some of the type
- signatures are changed a bit from the proposed implementation so that
- they better reflect codified good practice for argument order.
-
-2008-10-02 Andreas Kupries <andreask@activestate.com>
-
- * tests/info.test (info-23.3): Updated output of the test to handle
- the NRE-enabled eval and the proper propagation of location
- information through it. [Bug 2017632]
-
- * doc/info.n: Rephrased the documentation of 'info frame' for positive
- numbers as level argument. [Bug 2134049]
-
- * tests/info.test (info-22.8): Made pattern for file containing
- tcltest less specific to accept both .tcl and .tm variants of the file
- during matching. [Bug 2129828]
-
-2008-10-02 Don Porter <dgp@users.sourceforge.net>
-
- TIP #330 IMPLEMENTATION
-
- * generic/tcl.h: Remove the "result" and "freeProc" fields
- * generic/tclBasic.c: from the default public declaration of the
- * generic/tclResult.c: Tcl_Interp struct. Code should no longer
- * generic/tclStubLib.c: be accessing these fields. Access can be
- * generic/tclTest.c: restored by defining USE_INTERP_RESULT, but
- * generic/tclUtil.c: that should only be a temporary migration aid.
- *** POTENTIAL INCOMPATIBILITY ***
-
-2008-10-02 Joe Mistachkin <joe@mistachkin.com>
-
- * doc/info.n: Fix unmatched font change.
- * doc/tclvars.n: Fix unmatched font change.
- * doc/variable.n: Fix unmatched font change.
- * tools/man2help2.tcl: Integrated patch from Harald Oehlmann.
- [Bug 1934272]
- * tools/man2tcl.c: Increase MAX_LINE_SIZE to fix "Too long line" error.
- * win/buildall.vc.bat: Prefer the HtmlHelp target over the WinHelp
- target. [Bug 2072891]
- * win/makefile.vc: Fix the HtmlHelp and WinHelp targets to not be
- mutually exclusive.
-
-2008-09-29 Don Porter <dgp@users.sourceforge.net>
-
- TIP #323 IMPLEMENTATION (partial)
-
- * doc/glob.n: Revise [glob] to accept zero patterns.
- * generic/tclFileName.c:
- * tests fileName.test:
-
- * doc/linsert.n: Revise [linsert] to accept zero elements.
- * generic/tclCmdIL.c:
- * tests/linsert.test:
-
-2008-09-29 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #326 IMPLEMENTATION
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Added -stride option to carry
- * doc/lsort.n, tests/cmdIL.test: out sorting of lists where the
- elements are grouped. Adapted from [Patch 2082681]
-
- TIP #313 IMPLEMENTATION
-
- * generic/tclCmdIL.c (Tcl_LsearchObjCmd): Added -bisect option to
- * doc/lsearch.n, tests/lsearch.test: allow the finding of the
- place to insert an element in a sorted list when that element is
- not already there. [Patch 1894241]
-
- TIP #318 IMPLEMENTATION
-
- * generic/tclCmdMZ.c (StringTrimCmd,StringTrimLCmd,StringTrimRCmd):
- Update the default set of trimmed characters to include some from the
- larger UNICODE space. Factor out the default trim set into a macro so
- that it is easier to keep them in synch.
-
-2008-09-28 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #314 IMPLEMENTATION
-
- * generic/tclCompCmds.c (TclCompileEnsemble)
- * generic/tclNamesp.c (NamespaceEnsembleCmd)
- (Tcl_SetEnsembleParameterList, Tcl_GetEnsembleParameterList)
- (NsEnsembleImplementationCmdNR):
- * generic/tcl.decls, doc/Ensemble.3, doc/namespace.n
- * tests/namespace.test: Allow the handling of a (fixed) number of
- formal parameters between an ensemble's command and subcommand at
- invocation time. [Patch 1901783]
-
-2008-09-28 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Fix the numLevels computations on
- * generic/tclInt.h: coroutine yield/resume
- * tests/unsupported.test:
-
-2008-09-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclFileName.c (Tcl_GetBlock*FromStat): Made this work
- acceptably when working with OSes that don't support reporting the
- block size from the stat() call. [Bug 2130726]
-
- * generic/tclCmdIL.c (Tcl_LrepeatObjCmd): Improve the handling of the
- case where the combination of number of elements and repeat count
- causes the resulting list to be too large. [Bug 2130992]
-
-2008-09-26 Don Porter <dgp@users.sourceforge.net>
-
- TIP #323 IMPLEMENTATION (partial)
-
- * doc/lrepeat.n: Revise [lrepeat] to accept both zero
- * generic/tclCmdIL.c: repetitions and zero elements to be repeated.
- * tests/lrepeat.test:
-
- * doc/object.n: Revise standard oo method [my variable] to
- * generic/tclOOBasic.c: accept zero variable names.
- * tests/oo.test:
-
- * doc/tm.n: Revise [tcl::tm::path add] and
- * library/tm.tcl: [tcl::tm::path remove] to accept zero paths.
- * tests/tm.test:
-
- * doc/namespace.n: Revise [namespace upvar] to accept zero
- * generic/tclNamesp.c: variable names.
- * tests/upvar.test:
-
- * doc/lassign.n: Revise [lassign] to accept zero variable names.
- * generic/tclCmdIL.c:
- * tests/cmdIL.test:
-
-2008-09-26 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.h (TCLOO_VERSION): Bump the version.
-
-2008-09-25 Don Porter <dgp@users.sourceforge.net>
-
- TIP #323 IMPLEMENTATION (partial)
-
- * doc/global.n: Revise [global] to accept zero variable names.
- * doc/variable.n: Revise [variable] likewise.
- * generic/tclVar.c:
- * tests/proc-old.test:
- * tests/var.test:
-
- * doc/global.n: Correct false claim about [info locals].
-
-2008-09-25 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #315 IMPLEMENTATION
-
- * tests/platform.test: Update tests to expect revised results
- * tests/safe.test: corresponding to the TIP 315 change.
-
- * unix/tclUnixInit.c, win/tclWinInit.c (TclpSetVariables):
- * doc/tclvars.n (tcl_platform): Define what character is used for
- separating PATH-like lists. Forms part of the tcl_platform array.
-
- * generic/tclOOCall.c (InitCallChain, IsStillValid):
- * tests/oo.test (oo-25.2): Revise call chain cache management so that
- it takes into account class-wide caching correctly. [Bug 2120903]
-
-2008-09-24 Don Porter <dgp@users.sourceforge.net>
-
- TIP #323 IMPLEMENTATION (partial)
-
- * doc/file.n: Revise [file delete] and [file mkdir] to
- * generic/tclCmdAH.c: accept zero "pathname" arguments (the
- * generic/tclFCmd.c: no-op case).
- * tests/cmdAH.test:
- * tests/fCmd.test:
-
-2008-09-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (DBPRINT): Remove obsolete debugging macro.
- [Bug 2124814]
-
- TIP #316 IMPLEMENTATION
-
- * generic/tcl.decls, generic/tclFileName.c (Tcl_GetSizeFromStat, etc):
- * doc/FileSystem.3: Added reader functions for Tcl_StatBuf.
-
-2008-09-23 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/Method.3: Corrected documentation. [Patch 2082450]
-
- * doc/lreverse.n, mathop.n, regexp.n, regsub.n: Make sure that the
- initial line of the manpage includes nothing that chokes old versions
- of man. [Bug 2118123]
-
-2008-09-22 Donal K. Fellows <dkf@users.sf.net>
-
- TIP #320 IMPLEMENTATION
-
- * generic/tclOODefineCmds.c (TclOODefineVariablesObjCmd):
- * generic/tclOOInfo.c (InfoObjectVariablesCmd, InfoClassVariablesCmd):
- * generic/tclOOMethod.c (TclOOSetupVariableResolver, etc):
- * doc/define.n, doc/ooInfo.n, benchmarks/cps.tcl:
- * tests/oo.test (oo-26.*): Allow the declaration of the common
- variables used in methods of a class or object. These are then mapped
- in using a variable resolver. This makes many class declarations much
- simpler overall, encourages good usage of variable names, and also
- boosts speed a bit.
-
- * generic/tclOOMethod.c (TclOOGetMethodBody): Factor out the code to
- get the body of a procedure-like method. Reduces the amount of "poking
- inside the abstraction" that is done by the introspection code.
-
-2008-09-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * doc/chan.n: Clean up paragraph order.
-
-2008-09-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (NEXT_INST_F):
- * generic/tclInt.h (TCL_CT_ASSERT): New compile-time assertions,
- adapted from www.pixelbeat.org/programming/gcc/static_assert.html
-
-2008-09-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: Correct the TclGetLongFromObj, TclGetIntFromObj,
- and TclGetIntForIndexM macros so that they retrieve the longValue
- field from the internalRep instead of casting the otherValuePtr field
- to type long.
-
-2008-09-17 Miguel Sofer <msofer@users.sf.net>
-
- * library/init.tcl: Export min and max commands from the mathfunc
- namespace. [Bug 2116053]
-
-2008-09-16 Joe Mistachkin <joe@mistachkin.com>
-
- * generic/tclParse.c: Move TclResetCancellation to be called on
- returning to level 0, as opposed to it being called on starting a
- substitution at level 0.
-
-2008-09-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Move TclResetCancellation to be called on
- returning to level 0, as opposed to it being called on starting a
- command at level 0. Add a call on returning via Tcl_EvalObjEx to fix
- [Bug 2114165].
-
-2008-09-10 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/binary.n: Added partial documentation of [binary encode] and
- [binary decode].
-
- * tests/binary.test,cmdAH.test,cmdIL.test,cmdMZ.test,fileSystem.test:
- More use of tcltest2 to simplify the tests as exposed to people.
- * tests/compile.test (compile-18.*): Added *some* tests of the
- disassmbler, though not of its output format.
-
-2008-09-10 Miguel Sofer <msofer@users.sf.net>
-
- * tests/nre.test: Add missing constraints; enable test of foreach
- recursion.
-
- * generic/tclBasic.c:
- * generic/tclCompile.h:
- * generic/tclExecute.c (INST_EVAL_STK): Wrong numLevels when evaling a
- canonical list. [Bug 2102930]
-
-2008-09-10 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclListObj.c (Tcl_ListObjGetElements): Make this list->dict
- transformation - encountered when using [foreach] with dicts - not as
- expensive as it was before. Spotted by Kieran Elby and reported on
- tcl-core.
-
-2008-09-08 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/append.test, appendComp.test, cmdAH.test: Use the powers of
- tcltest2 to make these files simpler.
-
-2008-09-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c (TclCompileTokens):
- * generic/tclExecute.c (CompileExprObj): Fix a perf bug (found by Alex
- Ferrieux) where some variables in the LVT where not being accessed by
- index. Fix missing localCache management in compiled expressions found
- while analyzing the bug.
-
-2008-09-07 Miguel Sofer <msofer@users.sf.net>
-
- * doc/namespace.n: Fix [Bug 2098441]
-
-2008-09-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclTrace.test (TraceVarProc):
- * generic/unsupported.test: Insure that unset traces are run even when
- the coroutine is unwinding. [Bug 2093947]
-
- * generic/tclExecute.c (CACHE_STACK_INFO):
- * tests/unsupported.test: Restore execEnv's bottomPtr. [Bug 2093188]
-
-2008-09-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Stripped "callers" of the _ANSI_ARGS_ macro
- * compat/dirent2.h: to support a TCL_NO_DEPRECATED build.
- * compat/dlfcn.h:
- * unix/tclUnixPort.h:
-
- * generic/tcl.h: Removed the conditional #define of
- _ANSI_ARGS_ that would support pre-prototype C compilers. Since
- _ANSI_ARGS_ is no longer used in tclDecls.h, it's clear no one
- compiling against Tcl 8.5 headers is making use of a -DNO_PROTOTYPES
- configuration.
-
-2008-09-02 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/socket.test: Rewrote so as to use tcltest2 better.
-
-2008-09-01 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdAH.c: NRE-enabling [eval]; eval scripts are now
- * generic/tclOOBasic.c: bytecompiled. Adapted recursion limit tests
- * tests/interp.test: that were relying on eval not being
- * tests/nre.test: compiled. Part of the [Bug 2017632] project.
- * tests/unsupported.test:
-
-2008-09-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (InvokeProcedureMethod):
- * generic/tclOO.c (ObjectRenamedTrace): Arrange for only methods that
- involve callbacks into the Tcl interpreter to be skipped when the
- interpreter is being torn down. Allows the semantics of destructors in
- a dying interpreter to be more useful when they're implemented in C.
-
-2008-08-29 Donal K. Fellows <dkf@users.sf.net>
-
- * unix/Makefile.in: Ensure that all TclOO headers get installed.
- * win/Makefile.in: [Bug 2082299]
- * win/makefile.bc:
- * win/makefile.vc:
-
-2008-08-28 Don Porter <dgp@users.sourceforge.net>
-
- * README: Bump version number to 8.6a3
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2008-08-27 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/tclvars.n, doc/library.n: Ensured that these two manual pages
- properly cross-reference each other. Issue reported on Tcler's Chat.
-
-2008-08-26 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (InfoCoroutine):
- * tests/unsupported.test: New command that returns the FQN of the
- currently executing coroutine. Lives as infoCoroutine under
- unsupported, but is designed to become a subcommand of [info]
-
-2008-08-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (NRInterpCoroutine): Store the caller's eePtr,
- stop assuming the coroutine is invoked from the same execEnv where it
- was created.
-
-2008-08-24 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCmdAH.c (TclNRForeachCmd): Converted the [foreach]
- command to have an NRE-aware non-compiled implementation. Part of the
- [Bug 2017632] project. Also restructured the code so as to manage its
- temporary memory more efficiently.
-
-2008-08-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Removed unused var; fixed function pointer
- * generic/tclOOInt.h: declarations (why did gcc start complaining
- * generic/tclOOMethod.c: all of a sudden?)
- * generic/tclProc.c:
-
-2008-08-23 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclInt.h (EnsembleImplMap): Added extra field to make it
- * generic/tclNamesp.c (TclMakeEnsemble): easier to build non-recursive
- ensembles in the core.
-
- * generic/tclDictObj.c (DictForNRCmd): Converted the [dict for]
- command to have an NRE-aware non-compiled implementation. Part of the
- [Bug 2017632] project.
-
-2008-08-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c:
- * generic/tclExecute.c: Set special errocodes: COROUTINE_BUSY,
- COROUTINE_CANT_YIELD, COROUTINE_ILLEGAL_YIELD.
-
-2008-08-22 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6a2 TAGGED FOR RELEASE ***
-
- * changes: Updates for 8.6a2 release.
-
- * generic/tcl.h: Drop use of USE_COMPAT85_CONST. That added
- indirection without value. Use -DCONST86="" to engage source compat
- support for code written for 8.5 headers.
-
- * generic/tclUtil.c (TclReToGlob): Added missing set of the
- *exactPtr value to really fix [Bug 2065115]. Also avoid possible
- DString overflow.
- * tests/regexpComp.test: Correct duplicate test names.
-
-2008-08-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Previous fix, now done right.
- * generic/tclCmdIL.c:
- * generic/tclInt.h:
- * tests/unsupported.test:
-
-2008-08-21 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/regexp.test, tests/regexpComp.test: Correct re2glob ***=
- * generic/tclUtil.c (TclReToGlob): translation from exact
- to anywhere-in-string match. [Bug 2065115]
-
-2008-08-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Reduced the use of CONST86 and eliminated
- * generic/tcl.decls: the use of CONST86_RETURN to support source
- code compatibility with Tcl 8.5 on those public routines passing
- (Tcl_Filesystem *), (Tcl_Timer *), and (Tcl_Objtype *) values which
- have been const-ified. What remains is the minimum configurability
- needed to support code written for pre-8.6 headers via the new
- -DUSE_COMPAT85_CONST compiler directive.
- *** POTENTIAL INCOMPATIBILITY ***
-
- * generic/tclDecls.h: make genstubs
-
-2008-08-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Fix the cmdFrame level count in
- * generic/tclCmdIL.c: coroutines. Fix small bug on coroutine
- * generic/tclInt.h: rewind.
-
-2008-08-21 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (Tcl_DisassembleObjCmd): Added ability to
- disassemble TclOO methods. The code to do this is very ugly.
-
-2008-08-21 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclOOMethod.c: Added casts to make MSVC happy
- * generic/tclBasic.c:
-
-2008-08-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (AllocObject): Suppress compilation of commands in
- the namespace allocated for each object.
- * generic/tclOOMethod.c (PushMethodCallFrame): Restore some of the
- hackery that makes calling methods of classes fast. Fixes performance
- problem introduced by the fix of [Bug 2037727].
-
- * generic/tclCompile.c (TclCompileScript): Allow the suppression of
- * generic/tclInt.h (NS_SUPPRESS_COMPILATION): compilation of commands
- * generic/tclNamesp.c (Tcl_CreateNamespace): from a namespace or its
- children.
-
-2008-08-20 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclTest.c (TestconcatobjCmd): Fix use of internal-only
- TclInvalidateStringRep macro. [Bug 2057479]
-
-2008-08-17 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Implementation of [coroutine] and [yield]
- * generic/tclCmdAH.c: commands (in tcl::unsupported).
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclInt.h:
- * tests/unsupported.test:
-
- * generic/tclTest.c (TestconcatobjCmd):
- * generic/tclUtil.c (Tcl_ConcatObj):
- * tests/util.test (util-4.7):
- Fix [Bug 1447328]; the original "fix" turned Tcl_ConcatObj() into a
- hairy monster. This was exposed by [Bug 2055782]. Additionally,
- Tcl_ConcatObj could corrupt its input under certain conditions!
-
- *** NASTY BUG FIXED ***
-
-2008-08-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Better cmdFrame management
-
-2008-08-14 Don Porter <dgp@users.sourceforge.net>
-
- * tests/fileName.test: Revise new tests for portability to case
- insensitive filesystems.
-
-2008-08-14 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclBasic.c (TclNREvalObjv, Tcl_NRCallObjProc):
- * generic/tclProc.c (TclNRInterpProcCore, InterpProcNR2):
- DTrace probes for NRE. [Bug 2017160]
-
- * generic/tclBasic.c (TclDTraceInfo): Add two extra arguments to
- * generic/tclCompile.h: DTrace 'info' probes for tclOO
- * generic/tclDTrace.d: method & class/object info.
-
- * generic/tclCompile.h: Add support for debug logging of DTrace
- * generic/tclBasic.c: 'proc', 'cmd' and 'inst' probes (does _not_
- require a platform with DTrace).
-
- * generic/tclCmdIL.c (TclInfoFrame): Check fPtr->line before
- dereferencing as line info may
- not exists when TclInfoFrame()
- is called from a DTrace probe.
-
- * tests/fCmd.test (fCmd-6.23): Made result matching robust when test
- workdir and /tmp are not on same FS.
-
- * unix/tclUnixThrd.c: Remove unused TclpThreadGetStackSize()
- * generic/tclInt.h: and related ifdefs and autoconf tests.
- * unix/tclUnixPort.h: [Bug 2017264] (jenglish)
- * unix/tcl.m4:
-
- * unix/Makefile.in: Ensure Makefile shell is /bin/bash for
- * unix/configure.in (SunOS): DTrace-enabled build on Solaris.
- (followup to 2008-06-12) [Bug 2016584]
-
- * unix/tcl.m4 (SC_PATH_X): Check for libX11.dylib in addition to
- libX11.so et al.
-
- * unix/configure: autoconf-2.59
- * unix/tclConfig.h.in: autoheader-2.59
-
-2008-08-13 Miguel Sofer <msofer@users.sf.net>
-
- * tests/nre.test: Added test for large {*}-expansion effects
-
-2008-08-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclFileName.c: Fix for errors handling -types {}
- * tests/fileName.test: option to [glob]. [Bug 1750300]
- Thanks to Matthias Kraft and George Peter Staplin.
-
-2008-08-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclOOInfo.c (InfoObjectDefnCmd, InfoObjectMixinsCmd):
- Fix # args displayed. [Bug 2048676]
-
-2008-08-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclOOMethod.c (PushMethodCallFrame): Added missing check
- for bytecode validity. [Bug 2037727]
-
- * generic/tclProc.c (TclProcCompileProc): On recompile of a
- proc, clear away any entries on the CompiledLocal list from the
- previous compile. This will prevent compile of temporary variables in
- the proc body from growing the localCache arbitrarily large.
-
- * README: Bump version number to 8.6a2
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * changes: Updates for 8.6a2 release.
-
-2008-08-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: Remove 8.5 requirement.
- * library/http/pkgIndex.tcl:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc:
-
-2008-08-11 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl: Added a 'package provide' command to the generated
- ifneeded scripts of Tcl Modules, for early detection of conflicts
- between the version specified through the file name and a 'provide'
- command in the module implementation, if any. Note that this change
- also now allows Tcl Modules to not provide a 'provide' command at all,
- and declaring their version only through their filename.
-
- * generic/tclProc.c (Tcl_ProcObjCmd): Fixed memory leak triggered by
- * tests/proc.test: procbody::test::proc. See [Bug 2043636]. Added a
- test case demonstrating the leak before the fix. Fixed a few spelling
- errors in test descriptions as well.
-
-2008-08-11 Don Porter <dgp@users.sourceforge.net>
-
- * library/http/http.tcl: Bump http version to 2.7.1 to account
- * library/http/pkgIndex.tcl: for [Bug 2046486] bug fix. This
- * unix/Makefile.in: release of http now requires a
- * win/Makefile.in: dependency on Tcl 8.5 to be able to
- * win/makefile.bc: use the unsigned formats in the
- * win/makefile.vc: [binary scan] command.
-
-2008-08-11 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: CRC field from zlib data should be treated as
- unsigned for 64bit support. [Bug 2046846]
-
-2008-08-10 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclProc.c: Completely removed ProcCompileProc, which was a
- fix for [Bug 1482718]. This is not needed at least since varReform,
- where the local variable data at runtime is read from the CallFrame
- and/or the LocalCache.
-
-2008-08-09 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Slight cleanup
- * generic/tclCompile.h:
- * generic/tclExecute.c:
-
-2008-08-09 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclExecute.c: Fix warnings.
-
- * generic/tclOOMethod.c (PushMethodCallFrame): Fix uninitialized efi
- name field.
-
- * tests/lrange.test (lrange-1.17): Add test cleanup; whitespace.
-
-2008-08-08 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6a2 release.
-
-2008-08-08 Kevin Kenny <kennykb@acm.org>
-
- * library/tzdata/CET:
- * library/tzdata/MET:
- * library/tzdata/Africa/Casablanca:
- * library/tzdata/America/Eirunepe:
- * library/tzdata/America/Rio_Branco:
- * library/tzdata/America/Santarem:
- * library/tzdata/America/Argentina/San_Luis:
- * library/tzdata/Asia/Karachi:
- * library/tzdata/Europe/Belgrade:
- * library/tzdata/Europe/Berlin:
- * library/tzdata/Europe/Budapest:
- * library/tzdata/Europe/Sofia:
- * library/tzdata/Indian/Mauritius: Olson's tzdata2008e.
-
-2008-08-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Fix tailcalls falling out of tebc into
- * generic/tclExecute.c: Tcl_EvalEx. [Bug 2017946]
- * generic/tclInt.h:
-
-2008-08-06 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclOO.c: Revised TclOO's check for an interp being
- deleted during handling of object command deletion. The old code was
- relying on documented features of command delete traces that do not in
- fact work. [Bug 2039178]
-
- * tests/oo.test (oo-26.*): Added tests that demonstrate failure
- of TclOO to check for various kinds of invalid bytecode during method
- dispatch. [Bug 2037727]
-
-2008-08-06 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclLookupSimpleVar): Fix bug that the core could
- not trigger before TclOO: the number of locals was being read from the
- Proc, which can under some circumstance be out of sync with the
- localCache's. Found by dgp while investigating [Bug 2037727].
-
- * library/init.tcl (::unknown): Removed the [namespace inscope]
- hack that was maintained for Itcl
-
- *** POTENTIAL INCOMPATIBILITY *** for Itcl
- Itcl users will need a new release with Itcl's [Patch 2040295], or
- else load the tiny script in that patch by themselves (rewrite
- ::unknown). Note that it is a script-only patch.
-
-2008-08-05 Joe English <jenglish@users.sourceforge.net>
-
- * unix/tclUnixChan.c: Streamline async connect logic [Patch 1994512]
-
-2008-08-05 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Fix for [Bug 2038069] by dgp.
- * tests/execute.test:
-
-2008-08-04 Miguel Sofer <msofer@users.sf.net>
-
- * tests/nre.test: Added tests for [if], [while] and [for]. A test
- for [foreach] has been added and marked as knownbug, awaiting for it
- to be NR-enabled.
-
- * generic/tclBasic.c: Made atProcExit commands run
- * generic/tclCompile.h: unconditionally, streamlined
- * generic/tclExecute.c: atProcExit/tailcall processing in TEBC.
- * generic/tclProc.c:
- * tests/unsupported.test:
-
-2008-08-04 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Stopped faulty double-logging of errors to
- * tests/execute.test: stack trace when a compile epoch bump triggers
- fallback to direct evaluation of commands in a compiled script.
- [Bug 2037338]
-
-2008-08-03 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: New unsupported command atProcExit that
- * generic/tclCompile.h: shares the implementation with tailcall.
- * generic/tclExecute.c: Fixed a segfault in tailcalls. Tests added.
- * generic/tclInt.h:
- * generic/tclInterp.c:
- * generic/tclNamesp.c:
- * tests/unsupported.test:
-
-2008-08-02 Miguel Sofer <msofer@users.sf.net>
-
- * tests/NRE.test (removed): Migrated tests to standard locations,
- * tests/nre.test (new): separating core functionality from the
- * tests/unsupported.test (new): experimental commands.
-
-2008-08-01 Jeff Hobbs <jeffh@ActiveState.com>
-
- * doc/Exit.3: Do not call Tcl_Finalize implicitly
- * generic/tclEvent.c: on DLL_PROCESS_DETACH as it may lead
- * win/tclWin32Dll.c (DllMain): to issues and the user should be
- explicitly calling Tcl_Finalize before unloading regardless. Clarify
- the docs to note the explicit need in embedded use.
-
-2008-08-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c: Revised timing of the CmdFrame stack
- * tests/info.test: management in TclEvalEx so that the CmdFrame
- will still be on the stack at the time Tcl_LogCommandInfo is called to
- append another level of -errorinfo information. Sets the stage to add
- file and line data to the stack trace. Added test to check that [info
- frame] functioning remains unchanged by the revision.
-
-2008-07-31 Miguel Sofer <msofer@users.sf.net>
-
- * tests/NRE.test: Replaced all deep-recursing tests by shallower
- tests that actually measure the C-stack depth. This makes them
- bearable again (even under memdebug) and avoid crashing on failure.
-
- * generic/tclBasic.c: NR-enabling [catch], [if] and [for] and
- * generic/tclCmdAH.c: [while] (the script, not the tests)
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclInt.h:
- * tests/NRE.test:
-
- * generic/tclBasic.c: Moved the few remaining defs from tclNRE.h to
- * generic/tclDictObj.c: tclInt.h, eliminated inclusion of tclNRE.h
- * generic/tclExecute.c: everywhere.
- * generic/tclInt.h:
- * generic/tclInterp.c:
- * generic/tclNRE.h (removed):
- * generic/tclNamesp.c:
- * generic/tclOOBasic.c:
- * generic/tclOOInt.h:
- * generic/tclProc.c:
- * generic/tclTest.c:
- * unix/Makefile.in:
-
-2008-07-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Improved tailcalls.
- * generic/tclCompile.h:
- * generic/tclExecute.c:
- * generic/tclTest.c:
- * tests/NRE.test:
-
- * generic/tclBasic.c (TclNREvalObjEx): New comments and code reorg
- to clarify what is happening.
-
- * generic/tclBasic.c: Guard against the value of iPtr->evalFlags
- changing between the times where TEOV and TEOV_exception run. Thanks
- dgp for catching this.
-
-2008-07-29 Miguel Sofer <msofer@users.sf.net>
-
- * tests/NRE.test: New tests that went MIA in the NRE revamping
-
- * generic/tclBasic.c: Clean up
- * generic/tclNRE.h:
- * generic/tclExecute.c:
-
- * generic/tclBasic.c: Made use of the thread's alloc cache stored in
- * generic/tclInt.h: the ekeko at interp creation to avoid hitting
- * generic/tclNRE.h: the TSD each time an NRE callback is pushed or
- * generic/tclThreadAlloc.c: pulled; the approach is suitably general
- to extend to every other obj allocation where an interp is know; this
- is left for some other time, requires a lot of grunt work.
-
- * generic/tclExecute.c: Fix [Bug 2030670] that cause TclStackRealloc
- to panic on rare corner cases. Thx ajpasadyn for diagnose and patch.
-
- * generic/tcl.decls: Completely revamped NRE implementation, with
- * generic/tclBasic.c: (almost) unchanged API.
- * generic/tclCompile.h:
- * generic/tclExecute.c: TEBC will require a bit of a facelift, but
- * generic/tclInt.decls: TEOV at least looks great now. There are new
- * generic/tclInt.h: tests (incomplete!) to verify that execution
- * generic/tclInterp.c: is indeed in the same TEBC instance, at the
- * generic/tclNRE.h: same level in all stacks involved. Tailcalls
- * generic/tclNamesp.c: are still a bit leaky, still deserving to be
- * generic/tclOOBasic.c: in tcl::unsupported.
- * generic/tclOOMethod.c:
- * generic/tclProc.c: Uninit'd var warnings in TEBC with -O2, no
- * generic/tclTest.c: warnings otherwise.
-
-2008-07-28 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/FileSystem.3: CONSTified many functions using
- * generic/tcl.decls: Tcl_FileSystem which all are supposed
- * generic/tclDecls.h: to be a constant, but this was not
- * generic/tclFileSystem.h: reflected in the API: Tcl_FSData,
- * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister,
- * generic/tclPathObj.c: Tcl_FSNewNativePath, Tcl_FSUnregister,
- * generic/tclTest.c: Tcl_FSGetFileSystemForPath ...
- This change complies with TIP #27.
- ***POTENTIAL INCOMPATIBILITY***
-
-2008-07-28 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c: Added missing ref count when creating an empty
- string as path (TclEvalEx). In 8.4 the missing code caused panics in
- the testsuite. It doesn't in 8.5. I am guessing that the code path
- with the missing the incr-refcount is not invoked any longer. Because
- the bug in itself is certainly the same.
-
-2008-07-27 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (PushMethodCallFrame): Remove hack that should
- have gone when this code was merged into Tcl.
-
-2008-07-27 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/Object.3: CONSTified 3 functions using Tcl_ObjType
- * doc/ObjectType.3: which all are supposed to be a constant, but
- * generic/tcl.decls: this was not reflected in the API:
- * generic/tcl.h: Tcl_RegisterObjType, Tcl_ConvertToType,
- * generic/tclDecls.h: Tcl_GetObjType
- * generic/tclObj.c: Introduced a CONST86_RETURN, so extensions
- * generic/tclCompCmds.c: which use Tcl_ObjType directly can be
- * generic/tclOOMethod.c: modified to compile against both Tcl 8.5 and
- * generic/tclTestobj.c: Tcl 8.6. tclDecls.h regenerated
- This change complies with TIP #27.
- ***POTENTIAL INCOMPATIBILITY***
-
-2008-07-25 Andreas Kupries <andreask@activestate.com>
-
- * test/info.test: More work on singleTestInterp usability. [1605269]
-
- * tests/info.test: Tests 38.* added, exactly testing the tracking of
- location for uplevel scripts. Resolved merge conflict on info-37.0,
- switched !singleTestInterp constraint to glob matching instead. Ditto
- info-22.8, removed constraint, more glob matching, and reduced the
- depth of the stack we check. More is coming, right now I want to
- commit the bug fixes.
-
- * tests/oo.test: Updated oo-22.1 for expanded location tracking.
-
- * generic/tclCompile.c (TclInitCompileEnv): Reorganized the
- initialization of the #280 location information to match the flow in
- TclEvalObjEx to get more absolute contexts.
-
- * generic/tclBasic.c (TclEvalObjEx): Added missing cleanup of extended
- location information.
-
-2008-07-25 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/info.test (info-37.0): Add !singleTestInterp constraint;
- (info-22.8, info-23.0): switch to glob matching to avoid sensitivity
- to tcltest.tcl line number changes, remove knownBug constraint, fix
- expected result. [Bug 1605269]
-
-2008-07-24 Jan Nijtmans <nijtmans@users.sf.net>
-
- * doc/Notifier.3: CONSTified 4 functions in the Notifier which
- * doc/Thread.3: all have a Tcl_Time* in it which is supposed
- * generic/tcl.decls: to be a constant, but this was not reflected
- * generic/tcl.h: reflected in the API:
- * generic/tclDecls.h: Tcl_SetTimer, Tcl_WaitForEvent,
- * generic/tclNotify.c: Tcl_ConditionWait, Tcl_SetMaxBlockTime
- * macosx/tclMacOSXNotify.c:
- * generic/tclThread.c: Introduced a CONST86, so extensions which have
- * unix/tclUnixNotfy.c: have their own Notifier (are there any?) can
- * unix/tclUnixThrd.c: can be modified to compile against both Tcl
- * win/tclWinNotify.c: Tcl 8.5 and Tcl 8.6
- * win/tclWinThrd.c: Regenerated tclDecls.h with "make stubs".
- This change complies with TIP #27
- ***POTENTIAL INCOMPATIBILITY***
-
-2008-07-23 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * tests/lrange.test: Added relative speed test to check for lrange
- in-place optimization committed 2008-06-30.
- * tests/binary.test: Added relative speed test to check for pure byte
- array CONCAT1 optimization committed 2008-06-30.
-
-2008-07-23 Andreas Kupries <andreask@activestate.com>
-
- * tests/info.test: Reordered the tests to have monotonously increasing
- numbers.
-
- * generic/tclBasic.c: Modified TclArgumentGet to reject pure lists
- * generic/tclCmdIL.c: immediately, without search. Reworked setup of
- * generic/tclCompile.c: eoFramePtr, doesn't need the line information,
- * tests/info.test: more sensible to have everything on line 1 when
- eval'ing a pure list. Updated the users of the line information to
- special case this based on the frame type (i.e.
- TCL_LOCATION_EVAL_LIST). Added a testcase demonstrating the new
- behaviour.
-
-2008-07-23 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c (GetCommandSource): Added comment with
- explanation and warning for waintainers.
-
-2008-07-22 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCompile.c: Made the new TclEnterCmdWordIndex static, and
- * generic/tclCompile.h: ansified.
-
- * generic/tclBasic.c: Ansified the new functions. Added missing
- function comments.
-
- * generic/tclBasic.c: Reworked the handling of bytecode literals for
- * generic/tclCompile.c: #280 to fix the abysmal performance for deep
- * generic/tclCompile.h: recursion, replaced the linear search through
- * generic/tclExecute.c: the whole stack with another hashtable and
- * generic/tclInt.h: simplified the data structure used by the compiler
- by using an array instead of a hashtable. Incidentially this also
- fixes the memory leak reported via [Bug 2024937].
-
-2008-07-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Added numLevels field to CommandFrame, let
- * generic/tclExecute.c: GetCommandSource use it. This solves [Bug
- * generic/tclInt.h: 2017146]. Thx dgp for the analysis.
-
-2008-07-21 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclBasic.c: Extended the existing TIP #280 system (info
- * generic/tclCmdAH.c: frame), added the ability to track the absolute
- * generic/tclCompCmds.c: location of literal procedure arguments, and
- * generic/tclCompile.c: making this information available to uplevel
- * generic/tclCompile.h: eval, and siblings. This allows proper
- * generic/tclInterp.c: tracking of absolute location through custom
- * generic/tclInt.h: (Tcl-coded) control structures based on uplevel,
- * generic/tclNamesp.c: etc.
- * generic/tclProc.c:
- * tests/info.test:
-
-2008-07-21 Jan Nijtmans <nijtmans@users.sf.net>
-
- * generic/*.c: Fix [2021443] inconsistant "wrong # args" messages
- * win/tclWinReg.c
- * win/tclWinTest.c
- * tests/*.test
-
-2008-07-21 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- TIP #304 IMPLEMENTATION
-
- * generic/tcl.decls: Public API
- * generic/tclIOCmds.c: Generic part
- * unix/tclUnixPipe.c: OS part
- * win/tclWinPipe.c: OS part
- * tests/chan.test: [chan pipe] tests
- * tests/ioCmd.test: Modernized checks
- * tests/ioTrans.test:
-
-2008-07-21 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclFCmd.c: Inodes on windows are unreliable. [Bug 2015723]
- * tests/winFCmd.test: test rename with inode collision
-
-2008-07-21 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tcl.decls: Changed the implementation of
- * generic/tclBasic.c: [namespace import]; removed
- * generic/tclDecls.h: Tcl_NRObjProc, replaced with
- * generic/tclExecute.c: Tcl_NRCmdSwap (proposed public
- * generic/tclInt.h: NRE API). This should fix
- * generic/tclNRE.h: [Bug 582506].
- * generic/tclNamesp.c:
- * generic/tclStubInit.c:
-
- * generic/tclBasic.c: NRE: enabled calling NR commands
- * generic/tclExecute.c: from the callbacks. Completely
- * generic/tclInt.h: redone tailcall implementation
- * generic/tclNRE.h: using the new feature. [Bug 2021489]
- * generic/tclProc.c:
- * tests/NRE.test:
-
-2008-07-20 Kevin B. Kenny <kenykb@acm.org>
-
- * tests/fileName.test: Repaired the failing test fileName-15.7 from
- dkf's commit earlier today.
-
-2008-07-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (SetDictFromAny): Make the list->dict
- transformation a bit more efficient; modern dicts are ordered and so
- we can round-trip through lists without needing the string rep at all.
- * generic/tclListObj.c (SetListFromAny): Make the dict->list
- transformation not lossy of internal representations and hence more
- efficient. [Bug 2008248] (ajpasadyn) but using a more efficient patch.
-
- * tests/fileName.test: Revise to reduce the obscurity of tests. In
- particular, all tests should now produce informative messages on
- failure and the quantity of [catch]-based obscurity is now greatly
- reduced; non-erroring is now checked for directly.
-
-2008-07-19 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/env.test: Add LANG to the list of variables that are not
- touched by the environment variable tests, so that subprocesses can
- get their system encoding correct.
-
- * tests/exec.test, tests/env.test: Rewrite so that non-ASCII
- characters are not used in the final comparison. Part of fixing [Bug
- 1513659].
-
-2008-07-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Optimization: replace calls to
- * generic/tclDictObj.c: Tcl_NRAddCallback with the macro
- * generic/tclExecute.c: TclNRAddCallback.
- * generic/tclInterp.c:
- * generic/tclNRE.h:
- * generic/tclNamesp.c:
- * generic/tclOO.c:
- * generic/tclOOBasic.c:
- * generic/tclOOCall.c:
- * generic/tclOOInt.h:
- * generic/tclOOMethod.c:
- * generic/tclProc.c:
-
-2008-07-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (TclNRNewObjectInstance, FinalizeAlloc):
- * generic/tclOOBasic.c (TclOO_Class_Create, TclOO_Class_CreateNs)
- (TclOO_Class_New, FinalizeConstruction, AddConstructionFinalizer):
- NRE-enablement of the class construction methods.
-
-2008-07-18 Miguel Sofer <msofer@users.sf.net>
-
- * tests/NRE.test: Added basic tests for deep TclOO calls
-
- * generic/tcl.decls: Change the public api prefix from
- * generic/tcl.h: TclNR_foo to Tcl_NRfoo
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/tclDictObj.c:
- * generic/tclExecute.c:
- * generic/tclInterp.c:
- * generic/tclNRE.h:
- * generic/tclNamesp.c:
- * generic/tclOO.c:
- * generic/tclOOBasic.c:
- * generic/tclOOCall.c:
- * generic/tclOOMethod.c:
- * generic/tclProc.c:
- * generic/tclStubInit.c:
-
-2008-07-18 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOBasic.c (TclOO_Object_Eval, FinalizeEval): NRE-enable
- the oo::object.eval method.
-
-2008-07-18 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclDictObj.c (DictWithCmd, DictUpdateCmd): Fix refcounting
- bugs that caused crashes [Bug 2017857].
-
- * generic/tclBasic.c (TclNREvalObjEx): Streamline the management of
- the command frame (opt).
-
-2008-07-17 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclDictObj.c (DictWithCmd, FinalizeDictWith): Split the
- implementation of [dict with] so that it works with NRE.
- (DictUpdateCmd, FinalizeDictUpdate): Similarly for the non-compiled
- version of [dict update].
-
-2008-07-16 George Peter Staplin <georgeps@users.sf.net>
-
- * win/tclWinThrd.c: Test for TLS_OUT_OF_INDEXES to make certain that
- thread key creation is successful.
-
-2008-07-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c, generic/tclOOInt.h, generic/tclOOBasic.c:
- * generic/tclOOCall.c, generic/tclOOMethod.c: NRE-enable the TclOO
- implementation in Tcl. No change to public APIs, except that method
- implementations can now be NRE-aware if they choose (which normal
- methods and forwards are). On the other hand, callers of
- TclOOInvokeObject (which is only in the internal stub table) will need
- to deal with the fact that it's only safe to call inside an NRE-aware
- context.
- ***POTENTIAL INCOMPATIBILITY***
-
-2008-07-15 Miguel Sofer <msofer@users.sf.net>
-
- * tests/NRE.test: Better constraint for testing the existence of
- * tests/stack.test: teststacklimit, to insure that the test suite
- runs under tclsh.
-
- * generic/tclParse.c: Fixing incomplete reversion of "fix" for [Bug
- 2017583], missing TclResetCancellation call.
-
-2008-07-15 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclBasic.c (Tcl_CancelEval): Fix blunder. [Bug 2018603]
-
- * doc/DictObj.3: Fix error in example. [Bug 2016740]
-
- * generic/tclNamesp.c (EnsembleUnknownCallback): Factor out some of
- the more complex parts of the ensemble code to make it easier to
- understand and hence to permit tighter compilation of code on the
- critical path.
-
-2008-07-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclParse.c: Reverting the "fix" for [Bug 2017583], numLevel
- * tests/parse.test: management and TclInterpReady check seems to be
- necessary after all.
-
-2008-07-14 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclProc.c (TclNRApplyObjCmd, TclObjInterpProcCore):
- * generic/tclBasic.c (TclNR_AddCallback, TclEvalObjv_NR2):
- * generic/tclNRE.h (TEOV_callback): Change the callback storage type
- to use an array, so guaranteeing correct inter-member spacing and
- memory layout.
-
-2008-07-14 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Remove unneeded TclInterpReady calls
- * generic/tclParse.c:
-
- * generic/tclBasic.c.: Embedded Tcl_Canceled() calls into
- * generic/tclExecute.c: TclInterpReady().
- * generic/tclParse.c:
-
- * generic/tclVar.c: Fix error message
-
- * generic/tclParse.c: Remove unnecessary numLevel management
- * tests/parse.test: [Bug 2017583]
-
- * generic/tclBasic.c.: NRE left too many calls to
- * generic/tclExecute.c: TclResetCancellation lying around: it
- * generic/tclProc.c: only needs to be called prior to any
- iPtr->numLevels++. Thanks mistachkin.
-
- * generic/tclBasic.c: TclResetCancellation() calls were misplaced
- (merge mishap); stray //. Thanks patthoyts.
-
- * generic/tclInt.h: The new macros TclSmallAlloc and TclSmallFree
- were badly defined under mem debugging [Bug 2017240] (thx das)
-
-2008-07-13 Miguel Sofer <msofer@users.sf.net>
-
- NRE implementation [Patch 2017110]
-
- * generic/tcl.decls: The NRE infrastructure
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclCmdAH.c:
- * generic/tclCompile.h:
- * generic/tclDecls.h:
- * generic/tclExecute.c:
- * generic/tclHistory.c:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclNRE.h:
- * generic/tclStubInit.c:
- * unix/Makefile.in:
-
- * generic/tclInterp.c: NRE-enabling: procs, lambdas, uplevel,
- * generic/tclNamesp.c: same-interp aliases, ensembles, imports
- * generic/tclProc.c: and namespace_eval.
-
- * generic/tclTestProcBodyObj.c: New NRE specific tests (few, but
- * tests/NRE.test: note that the thing is actually
- tested by the whole testsuite.
-
- * tests/interp.test: Fixed numLevel counting.
- * tests/parse.test:
- * tests/stack.test:
-
- * unix/configure: Removing support for the hacky nonportable
- * unix/configure.in: stack check: it is not needed anymore, Tcl
- * unix/tclConfig.h.in: is very thrifty on the C stack.
- * unix/tclUnixInit.c:
- * unix/tclUnixTest.c:
- * win/tclWin32Dll.c:
-
-2008-07-08 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclGet.c: Corrected out of date comments and removed
- * generic/tclInt.decls: internal routine TclGetLong() that's no
- longer used. If an extension is using this from the internal stubs
- table, it can shift to the public routine Tcl_GetLongFromObj() or
- can request addition of a public Tcl_GetLong().
- ***POTENTIAL INCOMPATIBILITY***
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2008-07-08 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/CrtInterp.3: Tighten up the descriptions of behaviour to make
- this page easier to read for a "Tcl 8.6" audience.
-
-2008-07-07 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCmdIL.c (InfoFrameCmd): Fixed unsafe idiom of setting
- the interp result found by Don Porter.
-
-2008-07-07 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/regexp.n, doc/regsub.n: Correct examples. [Bug 1982642]
-
-2008-07-06 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/lindex.n: Improve examples.
-
-2008-07-03 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (InvokeTclMethod): Fixed the memory leak
- reported in [Bug 1987821]. Thanks to Miguel for the report and Don
- Porter for tracking the cause down.
-
-2008-07-03 Don Porter <dgp@users.sourceforge.net>
-
- * library/package.tcl: Removed [file readable] testing from
- [tclPkgUnknown] and friends. We find out soon enough whether a file is
- readable when we try to [source] it, and not testing before allows us
- to workaround the bugs on some common filesystems where [file
- readable] lies to us. [Patch 1969717]
-
-2008-07-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/regc_nfa.c (duptraverse): Impose a maximum stack depth on
- the single most recursive part of the RE engine. The actual maximum
- may need tuning, but that needs a system with a small stack to carry
- out. [Bug 1905562]
-
- * tests/string.test: Eliminate non-ASCII characters from the actual
- test script. [Bug 2006884]
-
-2008-06-30 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/ObjectType.3: Clean up typedef formatting.
-
-2008-06-30 Don Porter <dgp@users.sourceforge.net>
-
- * doc/ObjectType.3: Updated documentation of the Tcl_ObjType
- struct to match expectations of Tcl 8.5. [Bug 1917650]
-
-2008-06-30 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
-
- * generic/tclCmdIL.c: Lrange cleanup and in-place optimization. [Patch
- 1890831]
-
- * generic/tclExecute.c: Avoid useless String conversion for CONCAT1 of
- pure byte arrays. [Patch 1953758]
-
-2008-06-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/*.1, doc/*.3, doc/*.n: Many small updates, purging out of date
- change bars and cleaning up the formatting of typedefs. Added a few
- missing bits of documentation in the process.
-
-2008-06-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Plug memory leak in [Bug 1999176] fix. Thanks
- to Rolf Ade for detecting.
-
-2008-06-29 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/interp.n: Corrected order of subcommands. [Bug 2004256]
- Removed obsolete (i.e. 8.5) .VS/.VE pairs.
-
- * doc/object.n (EXAMPLES): Fix incorrect usage of oo::define to be
- done with oo::objdefine instead. [Bug 2004480]
-
-2008-06-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Plug memory leak in [Bug 1972879] fix. Thanks
- to Rolf Ade for detecting and Dan Steffen for the fix. [Bug 2004654]
-
-2008-06-26 Andreas Kupries <andreask@activestate.com>
-
- * unix/Makefile.in: Followup to my change of 2008-06-25, make code
- generated by the Makefile and put into the installed tm.tcl
- conditional on interpreter safeness as well. Thanks to Daniel Steffen
- for reminding me of that code.
-
-2008-06-25 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.6a1 TAGGED FOR RELEASE ***
-
- * changes: Updates for 8.6a1 release.
-
- * generic/tclOO.h: Bump to TclOO 0.5.
-
-2008-06-25 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl: Modified the handling of Tcl Modules and of the
- * library/safe.tcl: Safe Base to interact nicely with each other,
- * library/init.tcl: enabling requiring Tcl Modules in safe
- * tests/safe.test: interpreters. [Bug 1999119]
-
-2008-06-25 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/rules.vc: Fix versions of dde and registry dlls
- * win/makefile.vc: Fix problem building with staticpkg option
-
-2008-06-24 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Fixed some internals management in the "path"
- Tcl_ObjType for the empty string value. Problem led to a crash in the
- command [glob -dir {} a]. [Bug 1999176]
-
-2008-06-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * doc/fileevent.n: Fix examples and comment on eof use. [Bug 1995063]
-
-2008-06-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclPathObj.c: Fixed bug in Tcl_GetTranslatedPath() when
- operating on the "Special path" variant of the "path" Tcl_ObjType
- intrep. A full normalization was getting done, in particular, coercing
- relative paths to absolute, contrary to what the function of producing
- the "translated path" is supposed to do. [Bug 1972879]
-
-2008-06-20 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6a1 release.
-
- * generic/tclInterp.c: Fixed completely boneheaded mistake that
- * tests/interp.test: [interp bgerror $slave] and [$slave bgerror]
- would always act like [interp bgerror {}]. [Bug 1999035]
-
- * tests/chanio.test: Corrected flawed tests revealed by a -debug 1
- * tests/cmdAH.test: -singleproc 1 test suite run.
- * tests/event.test:
- * tests/interp.test:
- * tests/io.test:
- * tests/ioTrans.test:
- * tests/namespace.test:
-
- * tests/encoding.test: Make failing tests pass again. [Bug 1972867]
-
-2008-06-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (Tcl_ObjectContextInvokeNext): Corrected 'next' (at
- * tests/oo.test (oo-7.8): end of a call chain) to make it
- * doc/next.n: consistent with the TIP. [Bug 1998244]
-
- * generic/tclOOCall.c (AddSimpleClassChainToCallContext): Make sure
- * tests/oo.test (oo-14.8): that class mixins are processed in the
- documented order. [Bug 1998221]
-
-2008-06-19 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updates for 8.6a1 release.
-
- * README: Bump version number to 8.6a1
- * generic/tcl.h:
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2008-06-17 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclClock.c (ClockConvertlocaltoutcObjCmd): Removed left
- over debug output.
-
-2008-06-17 Andreas Kupries <andreask@activestate.com>
-
- * doc/tm.n: Followup to changelog entry 2008-03-18 regarding
- ::tcl::tm::Defaults. Updated the documentation to not only mention the
- new (underscored) form of environment variable names, but make it the
- encouraged form as well. [Bug 1914604]
-
-2008-06-17 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclClock.c (ConvertLocalToUTC):
- * tests/clock.test (clock-63.1): Fixed a bug where the internal
- ConvertLocalToUTC command segfaulted if passed a dictionary without
- the 'localSeconds' key. To the best of my knowledge, the bug was not
- observable in the [clock] command itself.
-
-2008-06-16 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclCmdIL.c (TclInfoFrame): Moved the code looking up the
- * tests/info.test: information for key 'proc' out of the
- TCL_LOCATION_BC branch to after the switch, this is common to all
- frame types. Updated the testsuite to match. This was exposed by the
- 2008-06-08 commit (Miguel), switching uplevel from direct eval to
- compilation. [Bug 1987851]
-
-2008-06-16 Andreas Kupries <andreask@activestate.com>
-
- * tests/ioTrans.test (iortrans-11.*): Fixed same issue as for
- iortrans.tf-11.*, cleanup of temp file, making this a followup to the
- entry on 2008-06-10 by myself.
-
-2008-06-13 David Gravereaux <davygrvy@pobox.com>
-
- * win/rules.vc: SYMBOLS macro is now being set to zero when $(OPTS) is
- not available.
- * win/makefile.vc: The Stubs source files (tclStubLib.c and
- tclOOStubLib.c) should not be compiled with the -GL flag.
-
-2008-06-13 Joe Mistachkin <joe@mistachkin.com>
-
- TIP #285 IMPLEMENTATION
-
- * doc/Eval.3: Added documentation for the Tcl_CancelEval and
- Tcl_Canceled functions and the TCL_CANCEL_UNWIND flag bit.
- * doc/after.n: Corrected the spelling of 'canceled' in the
- documentation.
- * doc/interp.n: Added documentation for [interp cancel].
- * generic/tcl.decls: Added the Tcl_CancelEval and Tcl_Canceled
- functions to the stubs table.
- * generic/tcl.h: Added the TCL_CANCEL_UNWIND flag bit.
- * generic/tclBasic.c: The bulk of the script cancellation
- functionality is defined here. Added code to initialize and manage the
- script cancellation hash table in a thread-safe manner. Reset script
- cancellation flags prior to increasing the nesting level (if the
- nesting level is currently zero) and always cooperatively check for
- script cancellation near the start of TclEvalObjvInternal and after
- invoking async handlers.
- * generic/tclDecls.h: Regenerated.
- * generic/tclEvent.c: Call TclFinalizeEvaluation during finalization
- to cleanup the script cancellation hash table. During [vwait], always
- cooperatively check for script cancellation. Corrected the spelling of
- 'canceled' in comments to be consistent with the documentation.
- * generic/tclExecute.c: Reset script cancellation flags prior to
- increasing the nesting level (if the nesting level is currently zero)
- and always cooperatively check for script cancellation after invoking
- async handlers. Prevent [catch] from catching script cancellation when
- the TCL_CANCEL_UNWIND flag is set (similar to the manner used by TIP
- 143 when a limit has been exceeded).
- * generic/tclInt.decls: Added TclResetCancellation to the internal
- stubs table.
- * generic/tclInt.h: Added asyncCancel and asyncCancelMsg fields to the
- private Interp structure. Added private interp flag value CANCELED to
- help control script cancellation.
- * generic/tclIntDecls.h: Regenerated.
- * generic/tclInterp.c (Tcl_InterpObjCmd): Added [interp cancel]
- subcommand.
- * generic/tclNotify.c (Tcl_DeleteEventSource): Corrected the spelling
- of 'canceled' in comments to be consistent with the documentation.
- * generic/tclParse.c: Reset script cancellation flags prior to
- * generic/tclProc.c: increasing the nesting level (if the nesting
- level is currently zero) and cooperatively check for script
- cancellation prior to evaluating commands.
- * generic/tclStubInit.c: Regenerated.
- * generic/tclThreadTest.c (Tcl_ThreadObjCmd): Added script
- cancellation support ([testthread cancel]).
- Modified [testthread id] to allow querying of the 'main' thread ID.
- Corrected comments to reflect the actual command syntax. Made
- [testthread wait] cooperatively check for script cancellation. Added
- [testthread event] to allow for processing one pending event without
- blocking.
- * generic/tclTimer.c: Delay for a maximum of 500 milliseconds prior to
- checking for async handlers and script cancellation.
- * tests/cmdAH.test: Changed [interp c] to [interp create].
- * tests/interp.test: Added and fixed tests for [interp cancel].
- * tests/thread.test: Added tests for script cancellation via
- [testthread cancel].
- * tools/man2help2.tcl: Fixed problems with WinHelp target (see
- * tools/man2tcl.c: [Bug 1934200], [Bug 1934265], and [Bug 1934272]).
- * win/makefile.vc: Added 'pdbs' option for Windows build rules to
- * win/rules.vc: allow for non-debug builds with full symbols.
- * win/tcl.hpj.in: Corrected version for WinHelp target.
- * win/tclWinNotify.c: Used SleepEx and WaitForSingleObjectEx on
- * win/tclWinThrd.c: Windows because they are alertable.
-
-2008-06-12 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: Add complete deps on tclDTrace.h.
-
- * generic/tclOO.c: Use TclOOStubs hooks field to retrieve
- * generic/tclOODecls.h: TclOOIntStubs pointer. [Bug 1980953]
- * generic/tclOOIntDecls.h:
- * generic/tclOOStubInit.c:
- * generic/tclOOStubLib.c:
-
- * generic/tclIORTrans.c: Fix signed <-> unsigned cast warnings.
-
- * unix/Makefile.in: Clean generated tclDTrace.h file.
- * unix/configure.in (SunOS): Fix static DTrace-enabled build.
-
- * unix/tcl.m4 (SunOS-5.11): Fix 64bit amd64 support with gcc & Sun cc.
- * unix/configure: autoconf-2.59
-
- * macosx/Tcl.xcodeproj/project.pbxproj: Add tclIORTrans.c; updates and
- cleanup for Xcode 3.1/Leopard.
- * macosx/Tcl.xcode/project.pbxproj: Sync Tcl.xcodeproj changes.
- * macosx/README: Document new build configs.
-
-2008-06-10 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclEncoding.c(UtfToUtfProc): Avoid unwanted sign extension
- when converting incomplete UTF-8 sequences. See [Bug 1908443] for
- details.
-
-2008-06-10 Andreas Kupries <andreask@activestate.com>
-
- * tests/ioTrans.test (iortrans.tf-6.1): Fixed the [Bug 1988552],
- reported by Kevin. Have to close the channel before removal of the
- file. Fixed same bug in test 'iortrans.tf-11.0', after fixing missing
- cleanup of the file in 'iortrans.tf-11.*'. Lastly fixed the names of
- the threaded tests 'iortrans-8.*' to the correct 'iortrans.tf-8.*'.
-
-2008-06-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-
- * generic/tclIORTrans.c (ReflectInput): Fixed a bug triggered by Pat
- Thoyts <patthoyts@users.sourceforge.net>. Reset the EOF flag after
- draining the Tcl level into the result buffer, to make sure that the
- result buffer will be drained as well by repeated calls to
- ReflectInput should it contain more than one buffer-full of data.
- Without that reset the higher I/O system will not call on ReflectInput
- anymore due to the assumed EOF, thus losing the data which did not fit
- in the buffer of the call which caused the eof and drain.
-
-2008-06-09 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOCall.c (TclOOGetSortedMethodList): Plug memory leak
- that occurred when all methods were hidden. [Bug 1987817]
-
-2008-06-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Compilation of uplevel scripts, allow
- * generic/tclCompCmds.c: non-body compiled scripts to access the
- * generic/tclCompile.c: LVT (but not to extend it) and enable the
- * generic/tclCompile.h: canonical list opt to sidestep the
- * generic/tclExecute.c: compiler. [Patch 1973096]
- * generic/tclProc.c:
- * tests/uplevel.test:
-
-2008-06-06 Andreas Kupries <andreask@activestate.com>
-
- TIP #230 IMPLEMENTATION
-
- * generic/tclIOCmd.c: Integration of transform commands into 'chan'
- ensemble.
- * generic/tclInt.h: Definitions of the transform commands.
- * generic/tclIORTrans.c: Implementation of the reflection transforms.
- * tests/chan.test: Tests updated for new sub-commands of 'chan'.
- * tests/ioCmd.test: Tests updated for new sub-commands of 'chan'.
- * tests/ioTrans.test: Whole new set of tests for the reflection
- transform.
- * unix/Makefile.in: Integration of new files into build rules.
- * win/Makefile.in: Integration of new files into build rules.
- * win/makefile.vc: Integration of new files into build rules.
-
- NOTE: The file 'tclIORTrans.c' has a lot of code in common with the
- file 'tclIORChan.c', as that made it much easier to develop the
- reference implementation as a separate module. Now that the
- transforms have been committed the one thing left to do is to go
- over both modules and see which of the common parts we can
- factor out and share.
-
-2008-06-04 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclBinary.c: TIP #317 implementation
- * tests/binary.test:
-
-2008-06-02 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclOO.c (ReleaseClassContents): Fix the one remaining
- valgrind complaint about oo.test, caused by failing to protect the
- Object as well as the Class corresponding to a subclass being deleted
- and hence getting a freed-memory read when attempting to delete the
- class command. [Bug 1981001]
-
-2008-06-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOOMethod.c (Tcl_NewMethod): Complete the fix of [Bug
- 1981001], previous fix was incomplete though helpful in telling me
- where to look.
-
-2008-06-01 Joe Mistachkin <joe@mistachkin.com>
-
- * win/Makefile.in: Add tclOO genstubs to Windows makefiles and remove
- * win/makefile.vc: -DBUILD_tcloo because it is no longer required.
-
-2008-06-01 Kevin B. Kenny <kennykb@acm.org>
-
- * generic/tclOODecls.h: Added the swizzling of DLLEXPORT and
- * generic/tclOOIntDecls.h: DLLIMPORT needed to make EXTERN work.
-
- * generic/tclDictObj.c: Added missing initializers to the ensemble
- map to silence a compiler warning. Thanks to
- George Peter Staplin for the report.
-
- * generic/tclOOMethod.c: Fix a bug where the refcount of a method was
- reset if the method was redefined while there
- was an active invocation. [Bug 1981001]
-
-2008-06-01 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.decls, unix/Makefile.in (genstubs): Make generation of
- stub tables correct.
- * generic/tclOO{Decls.h,IntDecls.h,StubInit.c,StubLib.c}: Fixes to
- make the generation work correctly, removing subtle differences
- between output of different versions of stub generator.
-
-2008-06-01 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclOOStubLib.c: Ensure use of tcl stubs; include in
- * unix/Makefile.in: stub lib; disable broken tclOO
- genstubs
-
- * generic/tclOO.c: Make tclOO stubs tables 'static const'
- * generic/tclOODecls.h: and stub table pointers MODULE_SCOPE
- * generic/tclOOIntDecls.h: (change generated files manually
- * generic/tclOOStubInit.c: pending genstubs support for tclOO).
- * generic/tclOOStubLib.c:
-
- * generic/tclOO.c: Fix warnings for 'int<->ptr
- * generic/tclOOCall.c: conversion' and 'signed vs unsigned
- * generic/tclOOMethod.c: comparison'.
-
- * tests/msgcat.test: Fix for ::tcl::mac::locale with @modifier.
-
- * tools/tsdPerf.tcl: Use [info sharedlibextension]
-
- * unix/tclConfig.h.in: autoheader-2.59
-
- * macosx/Tcl.xcodeproj/project.pbxproj: Add new tclOO files; add debug
- * macosx/README: configs with corefoundation
- disabled and with gcov; update
- to Xcode 3.1.
-
-2008-05-31 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclOO.c (InitFoundation): Correct reference counting for
- strings used when creating the constructor for classes.
- * generic/tclOOMethod.c (TclOODelMethodRef): Correct fencepost error
- in reference counting of method implementation structures.
- * tests/oo.test (oo-0.5): Added a test to detect a memory leak problem
- relating to disposal of the core object system.
-
- TIP#257 IMPLEMENTATION
-
- * generic/tclBasic.c, generic/tclOOInt.h: Correct declarations.
- * win/Makefile.in, win/makefile.bc, win/makefile.vc: Build support for
- Win32, from Joe Mistachkin. [Patch 1980861]
-
- * generic/tclOO*, doc/*, tests/oo.test: Port of implementation of
- TclOO to sit directly inside Tcl. Note that this is incomplete (e.g.
- no build support yet for Windows).
-
-2008-05-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tests/io.test (io-53.9): Need to close chan before removing file.
-
-2008-05-26 Donal K. Fellows <dkf@users.sf.net>
-
- * win/makefile.bc: Remove deprecated winhelp target.
- * win/Makefile.in, win/makefile.vc: It didn't work correctly anyway.
-
-2008-05-23 Andreas Kupries <andreask@activestate.com>
-
- * win/tclWinChan.c (FileWideSeekProc): Accepted a patch by Alexandre
- Ferrieux <ferrieux@users.sourceforge.net> to fix the [Bug 1965787].
- 'tell' now works for locations > 2 GB as well instead of going
- negative.
-
- * generic/tclIO.c (Tcl_SetChannelBufferSize): Accepted a patch by
- * tests/io.test: Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * tests/chanio.test: to fix the [Bug 1969953]. Buffersize outside of
- the supported range are now clipped to nearest boundary instead of
- ignored.
-
-2008-05-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclNamesp.c (Tcl_LogCommandInfo): Restored ability to
- handle the argument value length = -1. Thanks to Chris Darroch for
- discovering the bug and providing the fix. [Bug 1968245]
-
-2008-05-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclParse.c (ParseComment): The new TclParseAllWhiteSpace
- * tests/parse.test (parse-15.60): routine has no mechanism to
- return the "incomplete" status of "\\\n" so calling this routine
- anywhere that can be reached within a Tcl_ParseCommand() call is a
- mistake. In particular, ParseComment() must not use it. [Bug 1968882]
-
-2008-05-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclNamesp.c (Tcl_SetNamespaceUnknownHandler): Corrected odd
- logic for handling installation of namespace unknown handlers which
- could lead too very strange things happening in the error case.
-
-2008-05-16 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompile.c: Fix crash with tcl_traceExec. Found and fixed
- by Alexander Pasadyn. [Bug 1964803]
-
-2008-05-15 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * win/makefile.vc: We should use the thread allocator for threaded
- * win/rules.vc: builds. Added 'tclalloc' option to disable.
-
-2008-05-09 George Peter Staplin <georgeps@xmission.com>
-
- * tools/tsdPerf.c: A loadable Tcl extension for testing TSD
- performance.
- * tools/tsdPerf.tcl: A simplistic tool that uses the thread
- extension and tsdPerf.so to get some performance metrics by,
- simulating, simple TSD contention.
-
-2008-05-09 George Peter Staplin <georgeps@xmission.com>
-
- * generic/tcl.h: Make Tcl_ThreadDataKey a void *.
- * generic/tclInt.h: Change around some function names and add some
- new per-platform declarations for thread-specific data functions.
- * generic/tclThread.c: Make use of of the new function names that no
- longer have a Tclp prefix.
- * generic/tclThreadStorage.c: Replace the core thread-specific data
- (TSD) mechanism with an array offset solution that eliminates the hash
- tables, and only uses one slot of native TSD. Many thanks to Kevin B.
- Kenny for his help with this.
-
- * unix/tclUnixThrd.c: Add platform-specific TSD functions for use by
- * win/tclWinThrd.c: tclThreadStorage.c.
-
-2008-05-09 Kevin B. Kenny <kennykb@acm.org>
-
- * tests/dict.test (dict-19.2): Corrected a bug where the test was
- changed to use [apply] instead of a temporary proc, but the cleanup
- script still attempted to delete the temporary proc.
-
-2008-05-07 Donal K. Fellows <dkf@cspool38.cs.man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileDictAppendCmd): Fix silly off-by
- one error that caused a crash every time a compiled 'dict append' with
- more than one argument was used. Found by Colin McCormack.
-
-2008-05-02 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclBasic.c: Converted the [binary] command into an
- * generic/tclBinary.c: ensemble.
- * generic/tclInt.h:
- * test/binary.test: Updated the error tests for ensemble errors.
-
- * generic/tclFileName.c: Reverted accidental commit of TIP 316 APIs.
-
-2008-04-27 Donal K. Fellows <dkf@users.sf.net>
-
- * */*.c: A large tranche of getting rid of pre-C89-isms; if your
- compiler doesn't support things like proper function declarations,
- 'void' and 'const', borrow a proper one when building Tcl. (The header
- files allow building things that link against Tcl with really ancient
- compilers still; the requirement is just when building Tcl itself.)
-
-2008-04-26 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-
- * generic/tclAsync.c: Tcl_AsyncDelete(): panic if attempt to locate
- handler token fails. Happens when some other thread attempts to delete
- somebody else's token.
-
- Also, panic early if we find out the wrong thread attempting to delete
- the async handler (common trap). As, only the one that created the
- handler is allowed to delete it.
-
-2008-04-24 Andreas Kupries <andreask@activestate.com>
-
- * tests/ioCmd.test: Extended testsuite for reflected channel
- implementation. Added test cases about how it handles if the rug is
- pulled out from under a channel (= killing threads, interpreters
- containing the tcl command for a channel, and channel sitting in a
- different interpreter/thread.)
-
- * generic/tclIORChan.c: Fixed the bugs exposed by the new testcases,
- redone most of the cleanup and exit handling.
-
-2008-04-21 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclIOUtil.c: Removed all code delimited by
- * generic/tclTest.c: USE_OBSOLETE_FS_HOOKS, completing
- * tests/ioCmd.test: the deprecation path for these
- * tests/ioUtil.test (removed): obsolete interfaces. (Code was active
- in Tcl 8.4, present but enabled only by customized compile switch in
- Tcl 8.5, and now completely gone for Tcl 8.6). Also removed all tests
- relevant only to the removed interfaces.
-
-2008-04-19 George Peter Staplin <georgeps@xmission.com>
-
- * doc/Ensemble.3: Fix a typo: s/defiend/defined/
- Thanks to hat0 for spotting this.
-
-2008-04-16 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclInt.h: Make stubs tables 'static const' and
- * generic/tclStubInit.c: export only module-scope pointers to
- * generic/tclStubLib.c: the main stubs tables (for package
- * tools/genStubs.tcl: initialization). [Patch 1938497]
- * generic/tclBasic.c (Tcl_CreateInterp):
- * generic/tclTomMathInterface.c (TclTommath_Init):
-
- * generic/tclInt.h: Revise Tcl_SetNotifier() to use a
- * generic/tclNotify.c: module-scope hooks table instead of
- * generic/tclStubInit.c: runtime stubs-table modification;
- * macosx/tclMacOSXNotify.c: ensure all hookable notifier functions
- * win/tclWinNotify.c: check for hooks; remove hook checks in
- * unix/tclUnixNotfy.c: notifier API callers. [Patch 1938497]
-
-2008-04-15 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CopyData): Applied another patch by Alexandre
- * io.test (io-53.8a): Ferrieux <ferrieux@users.sf.net>,
- * chanio.test (chan-io-53.8a): to shift EOF handling to the async
- part of the command if a callback is specified, should the channel be
- at EOF already when fcopy is called. Testcase by myself.
-
-2008-04-15 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/Makefile.in: Adjust tclDTrace.h dependencies for removal
- of tclStubLib.o from TCL_OBJS. [Bug 1942795]
-
-2008-04-14 Kevin B. Kenny <kennykb@acm.org>
-
- * unix/tclUnixTime.c (NativeGetTime): Removed obsolete use of
- 'struct timezone' in the call to 'gettimeofday'. [Bug 1942197]
-
- * tests/clock.test (clock-33.5, clock-33.5a, clock-33.8, clock-33.8a):
- Added comments to the test that it can fail on a heavily loaded
- system.
-
-2008-04-10 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Keeping check for negative
- values, changed to not be an error, but behave like the special value
- -1 (copy all, default).
-
- * tests/iocmd.test (iocmd-15.{12,13}): Removed.
-
- * tests/io.test (io-52.5{,a,b}): Reverted last change, added
- * tests/chanio.test (chan-io-52.5{,a,b}): comment regarding the
- meaning of -1, added two more testcases for other negative values,
- and input wrapped to negative.
-
-2008-04-09 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/{fCmd,unixFCmd,winFCmd,winFile}.test: Tidying up of the test
- suite to make better use of tcltest2 and be clearer about what is
- being tested.
-
- * win/Makefile.in (html): Added target for doing convenient
- documentation builds, mirroring the one from unix/Makefile.
-
-2008-04-09 Andreas Kupries <andreask@activestate.com>
-
- * tests/chanio.test (chan-io-52.5): Removed '-size -1' from test,
- * tests/io.test (io-52.5): does not seem to have any bearing, and was
- an illegal value. Test case is not affected by the value of -size,
- test flag restoration and that evrything was properly copied.
-
- * generic/tclIOCmd.c (Tcl_FcopyObjCmd): Added checking of -size value
- * tests/ioCmd.test (iocmd-15.{13,14}): to reject negative values, and
- values overflowing 32-bit signed. Basic patch by Alexandre Ferrieux
- <ferrieux@users.sourceforge.net>, with modifications from me to
- separate overflow from true negative value. Extended testsuite. [Bug
- 1557855]
-
-2008-04-09 Daniel Steffen <das@users.sourceforge.net>
-
- * tests/chanio.test (chan-io-53.8,53.9,53.10): Fix typo & quoting for
- * tests/io.test (io-53.8,53.9,53.10): spaces in builddir path
-
-2008-04-08 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c: Added comments to the alignment macros used in
- GrowEvaluationStack() and friends.
-
-2008-04-08 Daniel Steffen <das@users.sourceforge.net>
-
- * tools/genStubs.tcl: Revert erroneous 2008-04-02 change marking
- *StubsPtr as EXTERN instead of extern.
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclTomMathDecls.h:
-
-2008-04-07 Andreas Kupries <andreask@activestate.com>
-
- * tests/io.test (io-53.10): Testcase for bi-directional fcopy.
- * tests/chanio.test:
- * generic/tclIO.c: Additional changes to data structures for fcopy and
- * generic/tclIO.h: channels to perform proper cleanup in case of a
- channel having two background copy operations running as is now
- possible.
-
- * generic/tclIO.c (BUSY_STATE, CheckChannelErrors, TclCopyChannel):
- New macro, and the places using it. This change allows for
- bi-directional fcopy on channels. Thanks to Alexandre Ferrieux
- <ferrieux@users.sourceforge.net> for the patch. [Bug 1350564]
-
-2008-04-07 Reinhard Max <max@suse.de>
-
- * generic/tclStringObj.c (Tcl_AppendFormatToObj): Fix [format {% d}]
- so that it behaves the same way as in 8.4 and as C's printf().
- * tests/format.test: Add a test for '% d' and '%+d'.
-
-2008-04-05 Kevin B. Kenny <kennykb@acm.org>
-
- * win/tclWinFile.c: (WinSymLinkDirectory): Fixed a problem that Tcl
- was creating an NTFS junction point (IO_REPARSE_TAG_MOUNT_POINT) but
- filling in the union member for a Vista symbolic link. We had gotten
- away with this error because the union member
- (SymbolicLinkReparseBuffer) was misdefined in this file and in the
- 'winnt.h' in early versions of MinGW. MinGW 3.4.2 has the correct
- definition of SymbolicLinkReparseBuffer, exposing the mismatch, and
- making tests cmdAH-19.4.1, fCmd-28.*, and filename-11.* fail.
- * tests/chanio.test (chan-io-53.9):
- * tests/io.test (io-53.9): Made test cleanup robust against the
- possibility of slow process shutdown on Windows.
-
- * win/tcl.m4: Added -D_CRT_SECURE_NO_DEPRECATE and
- -DCRT_NONSTDC_NO_DEPRECATE to the MSVC compilation flags so that the
- compilation doesn't barf on perfectly reasonable Posix system calls.
- * win/configure: Manually patched (don't have the right autoconf to
- hand).
-
-2008-04-04 Andreas Kupries <andreask@activestate.com>
-
- * tests/io.test (io-53.9): Added testcase for [Bug 780533], based
- * tests/chanio.test: on Alexandre's test script. Also fixed problem
- with timer in preceding test, was not canceled properly in the ok case
-
-2008-04-04 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIORChan.c (ReflectOutput): Allow zero return from write
- when input was zero-length anyway. Otherwise keept it an error, and
- separate the message from 'written too much'.
-
- * tests/ioCmd.test (iocmd-24.6): Testcase updated for changed message.
-
- * generic/tclIORChan.c (ReflectClose): Added missing removal of the
- now closed channel from the reflection map. Before we could crash the
- system by invoking 'chan postevent' on a closed reflected channel,
- dereferencing the dangling pointer in the map.
-
- * tests/ioCmd.test (iocmd-31.8): Testcase for the above.
-
-2008-04-03 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CopyData): Applied patch [Bug 1932639] to
- * tests/io.test: prevent fcopy from calling -command synchronously
- * tests/chanio.test: the first time. Thanks to Alexandre Ferrieux
- <ferrieux@users.sourceforge.net> for report and patch.
-
-2008-04-02 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tcl.decls: Remove 'export' declarations of symbols now
- only in libtclstub and no longer in libtcl.
-
- * generic/tclStubLib.c: Make symbols in libtclstub.a MODULE_SCOPE to
- * tools/genStubs.tcl: avoid exporting them from libraries that link
- with -ltclstub; constify tcl*StubsPtr and stub
- table hook pointers. [Bug 1819422]
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclStubInit.c:
- * generic/tclTomMathDecls.h:
-
-2008-04-02 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclIO.c (CopyData): Applied patch for fcopy problem [Bug
- 780533], with many thanks to Alexandre Ferrieux
- <ferrieux@users.sourceforge.net> for tracking it down and providing a
- solution. Still have to convert his test script into a proper test
- case.
-
-2008-04-01 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclStrToD.c: Applied patch for [Bug 1839067] (fp rounding
- * unix/tcl.m4: setup on solaris x86, native cc), provided by
- Michael Schlenker.
-
-2008-04-01 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStubLib.c: Removed needless #ifdef complexity.
-
- * generic/tclStubLib.c (Tcl_InitStubs): Added missing error message.
- * generic/tclPkg.c (Tcl_PkgInitStubsCheck):
-
- * README: Bump version number to 8.6a0
- * generic/tcl.h:
- * library/init.tcl:
- * macosx/Tcl-Common.xcconfig:
- * macosx/Tcl.pbproj/default.pbxuser:
- * macosx/Tcl.pbproj/project.pbxproj:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/README:
- * win/configure.in:
- * win/makefile.bc:
- * win/tcl.m4:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * generic/tclBasic.c: Revised stubs-generation tool and interp
- * tools/genStubs.tcl: creation so that "tclStubsPtr" is not present
- * unix/Makefile.in: in libtcl.so, but is present only in
- * win/Makefile.in: libtclstub.a. This tightens up the rules for
- * win/makefile.bc: users of the stubs interfaces. [Bug 1819422]
- * win/makefile.vc:
-
- * generic/tclDecls.h: make genstubs
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclTomMathDecls.h:
-
-2008-03-30 Kevin Kenny <kennykb@acm.org>
-
- * generic/tclInt.h (TclIsNaN):
- * unix/configure.in: Added code to the configurator to check for a
- standard isnan() macro and use it if one is
- found. This change avoids bugs where the test of
- ((d) != (d)) is optimized away by an
- overaggressive compiler. [Bug 1783544]
- * generic/tclObj.c: Added missing #include <math.h> needed to locate
- isnan() after the above change.
-
- * unix/configure: autoconf-2.61
-
- * tests/mathop.test (mathop-25.9, mathop-25.14): Modified tests to
- deal with (slightly buggy) math libraries in which pow() returns an
- incorrectly rounded result. [Bug 1808174]
-
-2008-03-26 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5.2 TAGGED FOR RELEASE ***
-
- * generic/tcl.h: Bump to 8.5.2 for release.
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
- * changes: Updated for 8.5.2 release.
-
-2008-03-28 Donal K. Fellows <dkf@users.sf.net>
-
- * tests/fCmd.test: Substantial rewrite to use many more tcltest
- features. Great reduction in quantity of [catch] gymnastics. Several
- buggy tests fixed, including one where the result of the previous test
- was being checked!
-
-2008-03-27 Kevin B. Kenny <kennykb@acm.org>
-
- * library/tzdata/America/Marigot:
- * library/tztata/America/St_Barthelemy:
- * library/tzdata/America/Argentina/San_Luis:
- * library/tzdata/Asia/Ho_Chi_Minh:
- * library/tzdata/Asia/Kolkata: (new files)
- * library/tzdata/America/Caracas:
- * library/tzdata/America/Havana:
- * library/tzdata/America/Santiago:
- * library/tzdata/America/Argentina/Buenos_Aires:
- * library/tzdata/America/Argentina/Catamarca:
- * library/tzdata/America/Argentina/Cordoba:
- * library/tzdata/America/Argentina/Jujuy:
- * library/tzdata/America/Argentina/La_Rioja:
- * library/tzdata/America/Argentina/Mendoza:
- * library/tzdata/America/Argentina/Rio_Gallegos:
- * library/tzdata/America/Argentina/San_Juan:
- * library/tzdata/America/Argentina/Tucuman:
- * library/tzdata/America/Argentina/Ushuaia:
- * library/tzdata/Asia/Baghdad:
- * library/tzdata/Asia/Calcutta:
- * library/tzdata/Asia/Damascus:
- * library/tzdata/Asia/Saigon:
- * library/tzdata/Pacific/Easter:
- Changes up to and including Olson's tzdata2008b.
-
-2008-03-27 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/tcl.m4 (SunOS-5.1x): Fix 64bit support for Sun cc. [Bug
- 1921166]
-
- * unix/configure: autoconf-2.59
-
-2008-03-26 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.2 release.
-
-2008-03-24 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * generic/tclBinary.c: [Bug 1923966] - crash in binary format
- * tests/binary.test: Added tests for the above crash condition.
-
-2008-03-21 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/switch.n: Clarified documentation in respect of two-argument
- invocation. [Bug 1899962]
-
- * tests/switch.test: Added more tests of regexp-mode compilation of
- the [switch] command. [Bug 1854435]
-
-2008-03-20 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.h, generic/tclThreadAlloc.c: Tidied up the declarations
- of Tcl_GetMemoryInfo so that it is always defined. Will panic when
- called against a Tcl that was previously built without it at all,
- which is OK because that also indicates a serious mismatch between
- memory configuration options.
-
-2008-03-19 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tcl.h, generic/tclThreadAlloc.c (Tcl_GetMemoryInfo): Make
- sure this function is available when direct linking. [Bug 1868171]
-
- * tests/reg.test (reg-33.14): Marked nonPortable because some
- environments have small default stack sizes. [Bug 1905562]
-
-2008-03-18 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl (::tcl::tm::UnknownHandler): Changed 'source' to
- 'source -encoding utf-8'. This fixes a portability problem of Tcl
- Modules pointed out by Don Porter. By using plain 'source' we were at
- the mercy of 'encoding system', making modules less portable than they
- could be. The exact scenario: A writes a TM in some weird encoding
- which is A's system encoding, distributes it, and somewhere else it
- cannot be read/used because the system encoding is different. Forcing
- the use of utf-8 makes the module portable.
-
- ***INCOMPATIBILITY*** for all Tcl Modules already written in non-utf-8
- compatible encodings.
-
-2008-03-18 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c: Patch from Miguel Sofer to correct the
- alignment of memory allocated by GrowEvaluationStack(). [Bug 1914503]
-
-2008-03-18 Andreas Kupries <andreask@activestate.com>
-
- * library/tm.tcl (::tcl::tm::Defaults): Modified handling of
- environment variables. Solution slightly different than proposed in
- the report. Using the underscored form TCLX_y_TM_PATH even if
- TCLX.y_TM_PATH exists. Also using a loop to cut prevent code
- replication. [Bug 1914604]
-
-2008-03-16 Donal K. Fellows <dkf@users.sf.net>
-
- * generic/tclCompCmds.c (TclCompileDictForCmd): Correct the handling
- of stack space calculation (the jump pattern used was confusing the
- simple-minded code doing the calculations). [Bug 1903325]
-
- * doc/lreplace.n: Clarified documentation of what happens with
- negative indices. [Bug 1905809] Added example, tidied up formatting.
-
-2008-03-14 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (OldMathFuncProc): Same workaround protection
- from bad TclStackAlloc() alignment. Thanks George Peter Staplin.
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): Use ckalloc() to allocate
- SortElement arrays instead of TclStackAlloc() which isn't getting
- alignment right. Workaround for [Bug 1914503].
-
-2008-03-14 Reinhard Max <max@suse.de>
-
- * generic/tclTest.c: Ignore the return value of write() when we are
- * unix/tclUnixPipe.c: about to exit anyways.
-
-2008-03-13 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/configure.in: Use backslash-quoting instead of double-quoting
- * unix/tcl.m4: for lib paths in tclConfig.sh. [Bug 1913622]
- * unix/configure: autoconf-2.59
-
-2008-03-13 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.2 release.
-
- * generic/tclStrToD.c: Resolve identifier conflict over "pow10" with
- libm in Cygwin and DJGPP. Thanks to Gordon Schumacher and Philip
- Moore. [Patch 1800636]
-
-2008-03-12 Daniel Steffen <das@users.sourceforge.net>
-
- * macosx/Tcl.xcodeproj/project.pbxproj: Add support for Xcode 3.1
- * macosx/Tcl.xcodeproj/default.pbxuser: CODE_SIGN_IDENTITY and
- * macosx/Tcl-Common.xcconfig: 'xcodebuild install'.
-
-2008-03-12 Andreas Kupries <andreask@activestate.com>
-
- * doc/info.n: Replaced {expand} with {*}.
-
-2008-03-12 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/Makefile.in (install-libraries): Bump http to 2.7
- * win/Makefile.in (install-libraries): Added -myaddr option to allow
- * library/http/http.tcl (http::geturl): control of selected socket
- * library/http/pkgIndex.tcl: interface. [Bug 559898]
- * doc/http.n, tests/http.test: Added -keepalive and
- -protocol 1.1 with chunked transfer encoding support. [Bug 1063703,
- 1470377, 219225] (default keepalive is 0)
- Added ability to override Host in -headers. [Bug 928154]
- Added -strict option to control URL validation on per-call basis.
- [Bug 1560506]
-
-2008-03-11 Jeff Hobbs <jeffh@ActiveState.com>
-
- * library/http/http.tcl (http::geturl): Add -method option to support
- * tests/http.test (http-3.1): http PUT and DELETE requests.
- * doc/http.n: [Bug 1599901, 862554]
-
- * library/http/http.tcl: Whitespace changes, code cleanup. Allow http
- to be re-sourced without overwriting http state.
-
-2008-03-11 Daniel Steffen <das@users.sourceforge.net>
-
- * generic/tclEncoding.c (LoadEscapeEncoding): Avoid leaking escape
- sub-encodings, fixes encoding-11.1 failing after iso2022-jp loaded.
- [Bug 1893053]
-
- * macosx/tclMacOSXNotify.c: Avoid using CoreFoundation after fork() on
- Darwin 9 even when TclpCreateProcess() uses vfork().
-
- * macosx/Tcl.xcodeproj/project.pbxproj: Add support for Xcode 3.1 and
- * macosx/Tcl.xcodeproj/default.pbxuser: configs for building with
- * macosx/Tcl-Common.xcconfig: gcc-4.2 and llvm-gcc-4.2.
-
- * unix/tclUnixPort.h: Workaround vfork() problems in
- llvm-gcc-4.2.1 -O4 build.
-
- * unix/tclUnixPort.h: Move MODULE_SCOPE compat
- define to top. [Bug 1911102]
-
- * macosx/GNUmakefile: Fix quoting to allow paths
- * macosx/Tcl-Common.xcconfig: to ${builddir} and
- * unix/Makefile.in: ${INSTALL_ROOT} to contain
- * unix/configure.in: spaces.
- * unix/install-sh:
- * unix/tcl.m4:
- * tests/ioCmd.test:
-
- * unix/configure: autoconf-2.59
-
- * unix/Makefile.in (install-strip): Strip non-global symbols from
- dynamic library.
-
- * unix/tclUnixNotfy.c: Fix warning.
-
- * tests/exec.test (exec-9.7): Reduce timing sensitivity
- * tests/socket.test (socket-2.11): (esp. on multi-proc machines).
-
- * tests/fCmd.test (fCmd-9.4): Skip on Darwin 9 (xfail).
-
-2008-03-11 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclVar.c (TclDeleteNamespaceVars):
- * tests/var.test (var-8.2): Unset traces on vars should be called with
- a FQ named during namespace deletion. This was causing infinite loops
- when unset traces recreated the var, as reported by Julian Noble. [Bug
- 1911919]
-
-2008-03-10 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.2 release.
-
- * doc/http.n: Revised to indicate that [package require http 2.5.5]
- is needed to get all the documented commands ([http::meta]).
-
- * generic/tclEvent.c (TclDefaultBgErrorHandlerObjCmd): Added error
- * tests/event.test (event-5.*): checking to protect against callers
- passing invalid return options dictionaries. [Bug 1901113]
-
- * generic/tclBasic.c (ExprAbsFunc): Revised so that the abs()
- * tests/expr.test: function and the [::tcl::mathfunc::abs]
- command do not return the value of -0, or equivalent values with more
- alarming string reps like -1e-350. [Bug 1893815]
-
-2008-03-07 Andreas Kupries <andreask@activestate.com>
-
- * generic/tclResult.c (ReleaseKeys): Workaround for [Bug 1904907].
- Reset the return option keys to NULL to allow full re-initialization
- by GetKeys(). This introduces a memory leak for the key objects, but
- gets us around a crash in the finalization of reflected channels when
- handling returns, either at compile- or runtime. In both cases we
- access the keys after they have been released by their thread exit
- handler. A proper fix is entangled with the untangling of the
- finalization ordering and attendant issues. For now we choose the
- lesser evil.
-
-2008-03-07 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclExecute.c (Tcl_ExprObj): Revised expression bytecode
- compiling so that bytecodes invalid due to changing context or due to
- the difference between expressions and scripts are not reused. [Bug
- 1899164]
-
- * generic/tclCmdAH.c: Revised direct evaluation implementation of
- [expr] so that [expr $e] caches compiled bytecodes for the expression
- as the intrep of $e.
-
- * tests/execute.test (execute-6.*): More tests checking that
- script bytecode is invalidated in the right situations.
-
-2008-03-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * win/configure.in: Add AC_HEADER_STDC to support msys/win64.
-
-2008-03-06 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/namespace.n: Minor tidying up. [Bug 1909019]
-
-2008-03-04 Don Porter <dgp@users.sourceforge.net>
-
- * tests/execute.test (6.3,4): Added tests for [Bug 1899164].
-
-2008-03-03 Reinhard Max <max@suse.de>
-
- * unix/tclUnixChan.c: Fix mark and space parity on Linux, which uses
- CMSPAR instead of PAREXT.
-
-2008-03-02 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclNamesp.c (GetNamespaceFromObj):
- * tests/interp.test (interp-28.2): Spoil the intrep of an nsNameType
- obj when the reference crosses interpreter boundaries.
-
-2008-02-29 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclResult.c (Tcl_SetReturnOptions): Revised the refcount
- management of Tcl_SetReturnOptions to become that of a conventional
- Consumer routine. Thanks to Peter Spjuth for pointing out the
- difficulties calling Tcl_SetReturnOptions with non-0-count value for
- options.
- * generic/tclExecute.c (INST_RETURN_STK): Revised the one caller
- within Tcl itself which passes a non-0-count value to
- Tcl_SetReturnOptions().
-
- * generic/tclBasic.c (Tcl_AppendObjToErrorInfo): Revised the
- refcount management of Tcl_AppendObjToErrorInfo to become that of a
- conventional Consumer routine. This preserves the ease of use for the
- overwhelming common callers who pass in a 0-count value, but makes the
- proper call with a non-0-count value less surprising.
- * generic/tclEvent.c (TclDefaultBgErrorHandlerObjCmd): Revised the
- one caller within Tcl itself which passes a non-0-count value to
- Tcl_AppendObjToErrorInfo().
-
-2008-02-28 Joe English <jenglish@users.sourceforge.net>
-
- * unix/tclPort.h, unix/tclCompat.h, unix/tclUnixChan.h: Reduce scope
- of <sys/filio.h> and <sys/ioctl.h> #includes. [Patch 1903339]
-
-2008-02-28 Joe English <jenglish@users.sourceforge.net>
-
- * unix/tclUnixChan.c, unix/tclUnixNotfy.c, unix/tclUnixPipe.c:
- Consolidate all code conditionalized on -DUSE_FIONBIO into one place.
- * unix/tclUnixPort.h, unix/tclUnixCompat.c: New routine
- TclUnixSetBlockingMode(). [Patch 1903339]
-
-2008-02-28 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclBasic.c (TclEvalObjvInternal): Plug memory leak when
- an enter trace deletes or changes the command, prompting a reparsing.
- Don't let the second pass lose commandPtr value allocated during the
- first pass.
-
- * generic/tclCompExpr.c (ParseExpr): Plug memory leak in error
- message generation.
-
- * generic/tclStringObj.c (Tcl_AppendFormatToObj): [format %llx $big]
- leaked an mp_int.
-
- * generic/tclCompCmds.c (TclCompileReturnCmd): The 2007-10-18 commit
- to optimize compiled [return -level 0 $x] [RFE 1794073] introduced a
- memory leak of the return options dictionary. Fixing that.
-
-2008-02-27 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/http.tcl: [Bug 705956] - fix inverted logic when
- cleaning up socket error in geturl.
-
-2008-02-27 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n: Corrected minor indentation gaffe in the penultimate
- paragraph. [Bug 1898025]
- * generic/tclClock.c (ParseClockFormatArgs): Changed to check that the
- clock value is in the range of a 64-bit integer. [Bug 1862555]
- * library/clock.tcl (::tcl::clock::format, ::tcl::clock::scan,
- (::tcl::clock::add, ::tcl::clock::LocalizeFormat): Fixed bugs in
- caching of localized strings that caused weird results when localized
- date/time formats were used. [Bug 1902423]
- * tests/clock.test (clock-61.*, clock-62.1): Regression tests for [Bug
- 1862555] and [Bug 1902423].
-
-2008-02-26 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclIOUtil.c, unix/tclUnixPort.h, unix/tclUnixChan.c:
- Remove dead/unused portability-related #defines and unused conditional
- code. See [Patch 1901828] for discussion.
-
-2008-02-26 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclIORChan.c (enum MethodName),
- * generic/tclCompExpr.c (enum Marks): More stray trailing ","s
-
-2008-02-26 Joe English <jenglish@users.sourceforge.net>
-
- * unix/configure.in(socklen_t test): Define socklen_t as "int" if
- missing, not "unsigned". Use AC_TRY_COMPILE instead of
- AC_EGREP_HEADER.
- * unix/configure: regenerated.
-
-2008-02-26 Joe English <jenglish@users.sourceforge.net>
-
- * generic/tclCompile.h: Remove stray trailing "," from enum
- InstOperandType definition (C99ism).
-
-2008-02-26 Jeff Hobbs <jeffh@ActiveState.com>
-
- * generic/tclUtil.c (TclReToGlob): Fix the handling of the last star
- * tests/regexpComp.test: possibly being escaped in
- determining right anchor. [Bug 1902436]
-
-2008-02-26 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/pkgIndex.tcl: Set version 2.5.5
- * library/http/http.tcl: It is better to do the [eof] check after
- trying to read from the socket. No clashes found in testing. Added
- http::meta command to access the http headers. [Bug 1868845]
-
-2008-02-22 Pat Thoyts <patthoyts@users.sourceforge.net>
-
- * library/http/pkgIndex.tcl: Set version 2.5.4
- * library/http/http.tcl: Always check that the state array exists
- in the http::status command. [Bug 1818565]
-
-2008-02-13 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump version number to 8.5.2b1 to distinguish
- * library/init.tcl: CVS development snapshots from the 8.5.1 and
- * unix/configure.in: 8.5.2 releases.
- * unix/tcl.spec:
- * win/configure.in:
- * README
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
-2008-02-12 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * generic/tclCompCmds.c (TclCompileSwitchCmd): Corrected logic for
- * tests/switch.test (switch-10.15): handling -nocase compilation; the
- -exact -nocase option cannot be compiled currently. [Bug 1891827]
-
- * unix/README: Documented missing configure flags. [Bug 1799011]
-
-2008-02-06 Kevin B. Kenny <kennykb@acm.org>
-
- * doc/clock.n (%N): Corrected an error in the explanation of the %N
- format group.
- * generic/tclClock.c (ClockParseformatargsObjCmd):
- * library/clock.tcl (::tcl::clock::format):
- * tests/clock.test (clock-1.0, clock-1.4):
- Performance enhancements in [clock format] (moving the analysis of
- $args into C code, holding on to Tcl_Objs with resolved command names,
- [lassign] in place of [foreach], avoiding [namespace which] for
- command resolution).
-
-2008-02-04 Don Porter <dgp@users.sourceforge.net>
-
- *** 8.5.1 TAGGED FOR RELEASE ***
-
- * changes: Updated for 8.5.1 release.
-
- * generic/tcl.h: Bump to 8.5.1 for release.
- * library/init.tcl:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
-
- * unix/configure: autoconf-2.59
- * win/configure:
-
-2008-02-04 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclExecute.c (INST_CONCAT1): Fix optimisation for in-place
- concatenation (was going over String type)
-
-2008-02-02 Daniel Steffen <das@users.sourceforge.net>
-
- * unix/configure.in (Darwin): Correct Info.plist year substitution
- in non-framework builds.
-
- * unix/configure: autoconf-2.59
-
-2008-01-30 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInterp.c (Tcl_GetAlias): Fix for [Bug 1882373], thanks go
- to an00na.
-
-2008-01-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * tools/tcltk-man2html.tcl: Reworked manual page scraper to do a
- proper job of handling references to Ttk options. [Tk Bug 1876493]
-
-2008-01-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
-
- * doc/man.macros (SO, SE): Adjusted macros so that it is possible for
- Ttk to have its "standard options" on a manual page that is not called
- "options". [Tk Bug 1876493]
-
-2008-01-25 Don Porter <dgp@users.sourceforge.net>
-
- * changes: Updated for 8.5.1 release.
-
-2008-01-23 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclInt.h: New macro TclGrowParseTokenArray() to
- * generic/tclCompCmds.c: simplify code that might need to grow
- * generic/tclCompExpr.c: an array of Tcl_Tokens in the parsePtr
- * generic/tclParse.c: field of a Tcl_Parse. Replaces the
- TclExpandTokenArray() routine via replacing:
- int needed = parsePtr->numTokens + growth;
- while (needed > parsePtr->tokensAvailable) {
- TclExpandTokenArray(parsePtr);
- }
- with:
- TclGrowParseTokenArray(parsePtr, growth);
- This revision merged over from dgp-refactor branch.
-
- * generic/tclCompile.h: Demote TclCompEvalObj() from internal stubs to
- * generic/tclInt.decls: a MODULE_SCOPE routine declared in
- tclCompile.h.
-
- * generic/tclIntDecls.h: make genstubs
- * generic/tclStubInit.c:
-
-2008-01-22 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclTimer.c (AfterProc): Replace Tcl_EvalEx() with
- Tcl_EvalObjEx() to evaluate [after] callbacks. Part of trend to favor
- compiled execution over direct evaluation.
-
-2008-01-22 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCmdIl.c (Tcl_LreverseObjCmd):
- * tests/cmdIL.test (cmdIL-7.7): Fix crash on reversing an empty list.
- [Bug 1876793]
-
-2008-01-20 Jeff Hobbs <jeffh@ActiveState.com>
-
- * unix/README: Minor typo fixes [Bug 1853072]
-
- * generic/tclIO.c (TclGetsObjBinary): Operate on topmost channel.
- [Bug 1869405] (Ficicchia)
-
-2008-01-17 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclCompExpr.c: Revision to preserve parsed intreps of
- numeric and boolean literals when compiling expressions with (optimize
- == 1).
-
-2008-01-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclCompExpr.c: Add an 'optimize' argument to
- * generic/tclCompile.c: TclCompileExpr() to profit from better
- * generic/tclCompile.h: literal management according to usage.
- * generic/tclExecute.c:
-
- * generic/tclCompExpr.c: Fix literal leak in exprs [Bug 1869989] (dgp)
- * generic/tclExecute.c:
- * tests/compExpr.test:
-
- * doc/proc.n: Changed wording for access to non-local variables; added
- mention to [namespace upvar]. Lame attempt at dealing with
- documentation. [Bug 1872708]
-
-2008-01-15 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclBasic.c: Replacing 'operator' by 'op' in the def of
- * generic/tclCompExpr.c: struct TclOpCmdClientData to accommodate C++
- * generic/tclCompile.h: compilers. [Bug 1855644]
-
-2008-01-13 Jeff Hobbs <jeffh@ActiveState.com>
-
- * win/tclWinSerial.c (SerialCloseProc, TclWinOpenSerialChannel): Use
- critical section for read & write side. [Bug 1353846] (newman)
-
-2008-01-11 Miguel Sofer <msofer@users.sf.net>
-
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): Restore stack checking
- functionality in freebsd. [Bug 1850424]
-
- * unix/tclUnixThrd.c (TclpThreadGetStackSize): Fix for crash in
- freebsd. [Bug 1860425]
-
-2008-01-10 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tclStringObj.c (Tcl_AppendFormatToObj): Correct failure to
- * tests/format.test: account for big.used == 0 corner case in the
- %ll(idox) format directives. [Bug 1867855]
-
-2008-01-09 George Peter Staplin <georgeps@xmission.com>
-
- * doc/vwait.n: Add a missing be to fix a typo.
-
-2008-01-04 Jeff Hobbs <jeffh@ActiveState.com>
-
- * tools/tcltk-man2html.tcl (make-man-pages): Make man page title use
- more specific info on lhs to improve tabbed browser view titles.
-
-2008-01-02 Donal K. Fellows <dkf@users.sf.net>
-
- * doc/binary.n: Fixed documentation bug reported on tcl-core, and
- reordered documentation to discourage people from using the hex
- formatter that is hardly ever useful.
-
-2008-01-02 Don Porter <dgp@users.sourceforge.net>
-
- * generic/tcl.h: Bump version number to 8.5.1b1 to distinguish
- * library/init.tcl: CVS development snapshots from the 8.5.0 and
- * unix/configure.in: 8.5.1 releases.
- * unix/tcl.spec:
- * win/configure.in:
- * README
-
- * unix/configure: autoconf (2.59)
- * win/configure:
-
- ******************************************************************
- *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" ***
- *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" ***
- *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" ***
- *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" ***
- *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" ***
- *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
- *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
- *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
- ******************************************************************
diff --git a/README.md b/README.md
index 1c5cd4b..8b84860 100644
--- a/README.md
+++ b/README.md
@@ -1,13 +1,13 @@
# README: Tcl
-This is the **Tcl 8.6.13** source distribution.
+This is the **Tcl 8.7a6** source distribution.
You can get any source release of Tcl from [our distribution
site](https://sourceforge.net/projects/tcl/files/Tcl/).
-[![Build Status](https://github.com/tcltk/tcl/workflows/Linux/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-6-branch)
-[![Build Status](https://github.com/tcltk/tcl/workflows/Windows/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-6-branch)
-[![Build Status](https://github.com/tcltk/tcl/workflows/macOS/badge.svg?branch=core-8-6-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Acore-8-6-branch)
+[![Build Status](https://github.com/tcltk/tcl/workflows/Linux/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Linux%22+branch%3Acore-8-branch)
+[![Build Status](https://github.com/tcltk/tcl/workflows/Windows/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22Windows%22+branch%3Acore-8-branch)
+[![Build Status](https://github.com/tcltk/tcl/workflows/macOS/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions?query=workflow%3A%22macOS%22+branch%3Acore-8-branch)
## Contents
1. [Introduction](#intro)
@@ -45,7 +45,7 @@ and selling it either in whole or in part. See the file
## <a id="doc">2.</a> Documentation
Extensive documentation is available on our website.
The home page for this release, including new features, is
-[here](https://www.tcl-lang.org/software/tcltk/8.6.html).
+[here](https://www.tcl-lang.org/software/tcltk/8.7.html).
Detailed release notes can be found at the
[file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/)
by clicking on the relevant version.
@@ -55,8 +55,8 @@ Xchange](https://www.tcl-lang.org/about/).
There have been many Tcl books on the market. Many are mentioned in
[the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206).
-The complete set of reference manual entries for Tcl 8.6 is [online,
-here](https://www.tcl-lang.org/man/tcl8.6/).
+The complete set of reference manual entries for Tcl 8.7 is [online,
+here](https://www.tcl-lang.org/man/tcl8.7/).
### <a id="doc.unix">2a.</a> Unix Documentation
The `doc` subdirectory in this release contains a complete set of
diff --git a/changes b/changes
index 6641777..78ae47e 100644
--- a/changes
+++ b/changes
@@ -2486,7 +2486,7 @@ interpreter. (JL)
installing and requesting security policies, purely in Tcl code. Overloads
the package command to also allow an interpreter to "require" a policy. The
following new library commands are provided:
- tcl_safeCreateInterp -- creates a slave an initializes the
+ tcl_safeCreateInterp -- creates a slave and initializes the
policy mechanism.
tcl_safeInitInterp -- initializes an existing slave with the
policy mechanism.
@@ -4650,7 +4650,7 @@ threading may still cause problems on AIX. (hobbs)
9/21/99 (bug fix) fixed bug when setting array in non-existent
namespace. [Bug: 2613] (hobbs)
---- Released 8.2.1, October 04, 1999 --- See ChangeLog for details ---
+--- Released 8.2.1, October 04, 1999
10/30/99 (feature enhancement) new regexp engine from Henry Spencer
was patched in - should greatly reduce stack space usage. (spencer)
@@ -4680,7 +4680,7 @@ when indexing into one (test case string-5.16) [Bug: 2871] (hobbs)
10/30/99 (bug fix) fixes for mac UTF filename handling (ingham)
---- Released 8.2.2, November 04, 1999 --- See ChangeLog for details ---
+--- Released 8.2.2, November 04, 1999
11/19/99 (feature enhancement) bug fixes for http package as well as
patch required by TLS (SSL) extension that adds http::(un)register
@@ -4705,7 +4705,7 @@ atexit handlers.
12/07/99 (bug fix) fixes for 'expr + {[incr]}' and 'expr + {[error]}'
cases (different causes).
---- Released 8.2.3, December 16, 1999 --- See ChangeLog for details ---
+--- Released 8.2.3, December 16, 1999
1999-09-14 (feature enhancement) added -start switch to regexp and regsub.
@@ -4762,7 +4762,7 @@ ExitThread to _endthreadex to prevent 4K mem leak (gravereaux)
1999-12-21 (bug fix) changed thread ids to longs (for 64bit systems)
---- Released 8.3b1, December 22, 1999 --- See ChangeLog for details ---
+--- Released 8.3b1, December 22, 1999
2000-01-10 (feature enhancement) clock scan now supports the common
ISO 8601 date/time formats. See docs for details. (melski)
@@ -4788,7 +4788,7 @@ symbolicly (like chmod) in [file attributes $file -permissions ...] (schoebel)
2000-01-13 (bug fix) fixed lsort -dictionary problem when sorting
characters between 'Z' and 'a' (flawed upper/lower comparison logic) (melski)
---- Released 8.3b2, January 13, 2000 --- See ChangeLog for details ---
+--- Released 8.3b2, January 13, 2000
2000-01-14 (feature enhancement) clock format %Q added, clock scan updated
@@ -4827,7 +4827,7 @@ mac panic from an error when closing an async socket (steffen, ingham)
2000-02-10 (feature enhancement) improved error reporting for failed
loads on Windows (dejong, hobbs)
---- Released 8.3.0, February 10, 2000 --- See ChangeLog for details ---
+--- Released 8.3.0, February 10, 2000
2000-03 (bug fixes, feature enhancement) overhaul of http package for
proper handling of async callbacks (new options), version is now at 2.3
@@ -4870,7 +4870,7 @@ tclLoadDyld.c dl type. (sanchez)
2000-04-24 (bug fix) fixed hang in threaded Unix case when backgrounded
exec process was running (dejong)
---- Released 8.3.1, April 26, 2000 --- See ChangeLog for details ---
+--- Released 8.3.1, April 26, 2000
2000-04-26 (doc fix) updated/added documentation for many API's and
commands (melski)
@@ -4920,7 +4920,7 @@ pattern matching for [array names] (gazetta)
2000-05-31 (feature enhancement) added -nocomplain and -- flags to
[unset] to allow for silent unset operation (hobbs)
---- Released 8.4a1, June 6, 2000 --- See ChangeLog for details ---
+--- Released 8.4a1, June 6, 2000
2000-05-29 (bug fix) corrected resource cleanup in http error cases.
Improved handling of error cases in http. (tamhankar)
@@ -4959,7 +4959,7 @@ sections. (english)
2000-08-07 (bug fix) new man pages memory.n, TCL_MEM_DEBUG.3, Init.3 and
DumpActiveMemory.3. (melski)
---- Released 8.3.2, August 9, 2000 --- See ChangeLog for details ---
+--- Released 8.3.2, August 9, 2000
2000-06 thru 2000-11 (build improvements) Added support for mingw (gcc on
Windows), AIX-5 and Win64 builds (dejong, hobbs)
@@ -5018,7 +5018,7 @@ environment (gravereaux)
2000-11-03 (new feature) Tcl_SetMainLoop enables defining an event loop for
tclsh. This enables Tk as a truly loadable package. (hobbs)
---- Released 8.4a2, November 3, 2000 --- See ChangeLog for details ---
+--- Released 8.4a2, November 3, 2000
2000-09-27 (bug fix) fixed a bug introduced by a partial fix in 8.3.2 that
didn't set nonBlocking correctly when resetting the flags for the write
@@ -5076,7 +5076,7 @@ Update of READMEs.
Corrected IRIX-5* configure (english). Added support for AIX-5 (hobbs).
Added support for Win64 (hobbs).
---- Released 8.3.3, April 6, 2001 --- See ChangeLog for details ---
+--- Released 8.3.3, April 6, 2001
2000-11-23 (new feature)[TIP 7] higher resolution timer on Windows (kenny)
@@ -5150,7 +5150,7 @@ system. This includes the addition of 'file normalize', 'file system',
* corrected several minor errors noted by Purify (hobbs)
---- Released 8.4a3, August 6, 2001 --- See ChangeLog for details ---
+--- Released 8.4a3, August 6, 2001
2001-06-27 (bug fix)[217987] corrected backslash substitution of non-ASCII
characters. (hobbs, riefenstahl)
@@ -5256,7 +5256,7 @@ bundles to standard .dylib dynamic libraries like on other unices.
2001-10-18 (bug fix) corrected off-by-one-day error in clock scan with
relative months and years during swing hours. (lavana)
---- Released 8.3.4, October 19, 2001 --- See ChangeLog for details ---
+--- Released 8.3.4, October 19, 2001
2001-08-21 (bug fix)[219184] overagressive compilation of [catch] (sofer)
@@ -5282,8 +5282,6 @@ compiles to 0 bytecodes (sofer)
2001-09-13 (new feature)[TIP 56] Tcl_EvalTokensStandard API (sofer)
-2001-09-13 (new feature) Old ChangeLog entries => ChangeLog.1999 (hobbs)
-
2001-09-17 (new feature) compiling with TCL_COMPILE_DEBUG now required to
enable all compile and execution tracing (sofer)
*** POTENTIAL INCOMPATIBILITY ***
@@ -5368,8 +5366,6 @@ of the Host: header value
2002-01-25 (new feature)[496733] socket options -eofchar and -translation
return read-only values (dejong)
-2002-01-28 (new feature) Old ChangeLog entries => ChangeLog.20900 (hobbs)
-
2002-01-28 (performance enhancement) bytecompiled [regexp] for trivial cases
that amount to string matching. Also -nocase and --. (hobbs)
@@ -5394,7 +5390,7 @@ errored out. (kupries, sofer)
2002-02-15 (new feature)[TIP 72] support for 64-bit integer values on
32-bit platforms and ability to work with >2GiB files. Extends many
-commands. See ChangeLog and TIP for details.
+commands. See TIP for details.
*** POTENTIAL INCOMPATIBILITY ***
2002-02-22 (bug fix)[476537] Fix panic when loading shared library without
@@ -5435,7 +5431,7 @@ of prior Tcl releases. Others will need to be reconciled.
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)
---- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---
+--- Released 8.4a4, March 5, 2002
2002-03-06 (new feature)[TIP 80] expanded [lsearch] options (wilkason, fellows)
@@ -5545,7 +5541,7 @@ options to configure (max)
2002-07-03 (bug fix)[577015] [catch] catches even compile errors (sofer)
---- Released 8.4b1, July 5, 2002 --- See ChangeLog for details ---
+--- Released 8.4b1, July 5, 2002
2002-07-08 (bug fix) restored compatibility of [viewFile] in tcltest (porter)
@@ -5583,7 +5579,7 @@ options to configure (max)
Many internal bugs fixed.
Considerable cleanup of the test suite.
---- Released 8.4b2, August 9, 2002 --- See ChangeLog for details ---
+--- Released 8.4b2, August 9, 2002
2002-08-20 (new feature) --enable-memdebug configure option (kupries)
@@ -5598,7 +5594,7 @@ Considerable cleanup of the test suite.
2002-09-02 (platfrom support) 64-bit compile on HP-11 (martin)
---- Released 8.4.0, September 10, 2002 --- See ChangeLog for details ---
+--- Released 8.4.0, September 10, 2002
2002-09-18 (platform support) Updated support for compiling with Cygwin and
either mingw or gcc. (khan, howell, dejong)
@@ -5661,7 +5657,7 @@ dirs to tcl_pkgPath: @executable_path/../Frameworks and
@executable_path/../PrivateFrameworks (if they exist), as well as the dirs
in DYLD_FRAMEWORK_PATH (if set). (steffen)
---- Released 8.4.1, October 22, 2002 --- See ChangeLog for details ---
+--- Released 8.4.1, October 22, 2002
2002-10-28 (bug fix)[627660] [package unknown] chaining for platform specifics
@@ -5754,7 +5750,7 @@ packages in multiple interps.
2003-02-27 (bug fix)[694232] stop [lsearch -start 0 {} x] segfault
---- Released 8.4.2, March 3, 2003 --- See ChangeLog for details ---
+--- Released 8.4.2, March 3, 2003
2003-03-06 (bug fix)[699042] Correct case-insensitive unicode string
comparison in Tcl_UniCharNcasecmp
@@ -5836,7 +5832,7 @@ encoding for the original. Most uses of gb2312 really mean euc-cn.
2003-05-14 (bug fix)[736421] Corrected another putenv() copy behavior
problem when compiling on Windows and using Microsoft's runtime.
---- Released 8.4.3, May 20, 2003 --- See ChangeLog for details ---
+--- Released 8.4.3, May 20, 2003
2003-05-23 (bug fix)[726018] reverted internals change to the
'cmdName' Tcl_ObjType that broke several extensions (TclBlend, e4graph...)
@@ -5877,7 +5873,7 @@ Improved documentation, new tests, and some code cleanup.
[655300, 720634, 735364, 748700, 756112, 756744, 756951, 758488, 760768,
763312, 769895, 771539, 771840, 771947, 771949, 772333]
---- Released 8.4.4, July 22, 2003 --- See ChangeLog for details ---
+--- Released 8.4.4, July 22, 2003
2003-07-23 (bug fix)[775976] fix registry compilation for VC7.
@@ -5923,7 +5919,7 @@ asked for writable events by the generic layer.
2003-11-17 (bug fix)[230589, 504785, 505048, 703709, 840258] fixes to
various odd regexp "can't happen" bugs.
---- Released 8.4.5, November 20, 2003 --- See ChangeLog for details ---
+--- Released 8.4.5, November 20, 2003
2003-12-02 (bug fix)[851747] object sharing fix in [binary scan]
@@ -5960,7 +5956,7 @@ various odd regexp "can't happen" bugs.
2004-03-01 (platform support)[218561] Allow 64-bit configure on IRIX64-6.5*
---- Released 8.4.6, March 1, 2004 --- See ChangeLog for details ---
+--- Released 8.4.6, March 1, 2004
Changes to 8.5a1 include all changes to the 8.4 line through 8.4.6,
plus the following, which focuses on the high-level feature changes
@@ -6046,7 +6042,7 @@ in this changeset (new minor version) rather than bug fixes:
* [TIP #157] leading {expand} syntax on words to cause argument expansion.
This is a safer/cleaner alternative to the use of 'eval'.
---- Released 8.5a1, March 3, 2004 --- See ChangeLog for details ---
+--- Released 8.5a1, March 3, 2004
2004-03-04 (new feature) registry package is [unload]able (thoyts)
=> registry 1.1.4
@@ -6070,7 +6066,7 @@ each command/interp validity before executing. (sofer)
2004-04-06 (clean up) refactored Tcl header file #include order. Might
create need for changes in extensions that #include private headers.
-Changed source code files should work with older Tcl as well. See ChangeLog.
+Changed source code files should work with older Tcl as well.
*** POTENTIAL INCOMPATIBILITY ***
2004-04-07 (bug fix)[920667] install into any Unicode path on Win (hobbs)
@@ -6346,7 +6342,7 @@ Doc improvements [759545,926590,935853,1017072,1018486,1022527,1027849,
1032243,1047928,1048005,1058446,1062647,1065732,1073334,etc.]
Test suite expansion [1036649,1001997,etc.]
---- Released 8.5a2, December 7, 2004 --- See ChangeLog for details ---
+--- Released 8.5a2, December 7, 2004
2004-12-13 (bug fix)[1083082] encoding memory leaks (ade,porter)
@@ -6490,7 +6486,7 @@ Can support [load] from memory as well (steffen)
Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.]
---- Released 8.5a3, June 4, 2005 --- See ChangeLog for details ---
+--- Released 8.5a3, June 4, 2005
2005-06-06 (bug fix)[1213678] Windows/gcc: crash in stack.test (kenny)
@@ -6741,7 +6737,7 @@ removed (steffen)
Documentation improvements [1211078,1190891,1292427,1277503,1104682,1359183,
1415725,666770]
---- Released 8.5a4, April 27, 2006 --- See ChangeLog for details ---
+--- Released 8.5a4, April 27, 2006
2006-05-04 (bug fix)[1480509] srand() accept wide input (porter,afredd)
@@ -6837,7 +6833,7 @@ URL validity checking against RFC 2986 (hobbs)
2006-10-13 (platform support) get stack size on Darwin (steffen)
---- Released 8.5a5, October 20, 2006 --- See ChangeLog for details ---
+--- Released 8.5a5, October 20, 2006
2006-10-20 (configure change) Added autodetection for OS-supplied timezone
files (max)
@@ -6919,7 +6915,7 @@ upvar and namespace upvar (sofer)
2007-04-23 (bug fix) fts_open() crash on 64bit Darwin 8 or earlier (steffen)
---- Released 8.5a6, April 25, 2007 --- See ChangeLog for details ---
+--- Released 8.5a6, April 25, 2007
2007-04-30 (bug fix)[1705778] many valgrind-detected leaks corrected
@@ -7022,7 +7018,7 @@ project for Xcode 3.0 (steffen)
(bug fix)[1066755] Several stack efficiency efforts increases recursion limit
on Windows to be larger than the default [interp recursionlimit] value
---- Released 8.5b1, September 26, 2007 --- See ChangeLog for details ---
+--- Released 8.5b1, September 26, 2007
2007-10-02 (bug fix)[1806422] proper [tcl::tm::path] autoload (porter)
@@ -7034,7 +7030,7 @@ on Windows to be larger than the default [interp recursionlimit] value
2007-10-25 (bug fix)[1726873] intermittent crash in threads (vasiljevic)
---- Released 8.5b2, October 26, 2007 --- See ChangeLog for details ---
+--- Released 8.5b2, October 26, 2007
2007-10-27 (bug fix)[1821159] fixed broken compile on x86_64 (sofer)
@@ -7070,7 +7066,7 @@ on Windows to be larger than the default [interp recursionlimit] value
Many significant documentation improvements (fellows, sofer)
---- Released 8.5b3, November 19, 2007 --- See ChangeLog for details ---
+--- Released 8.5b3, November 19, 2007
2007-11-20 (enhancement) string rep of dict has stable order (fellows)
@@ -7104,7 +7100,7 @@ over-consumption of resources (drewry,lane,ormandy,fellows)
Several documentation and release notes improvements
---- Released 8.5.0, December 20, 2007 --- See ChangeLog for details ---
+--- Released 8.5.0, December 20, 2007
2007-12-23 (bug fix)[1857126] restore backref support to regexps (hobbs)
@@ -7126,7 +7122,7 @@ Several documentation and release notes improvements
Several documentation and release notes improvements
---- Released 8.5.1, February 5, 2008 --- See ChangeLog for details ---
+--- Released 8.5.1, February 5, 2008
2008-02-06 (enhancement) [clock format] performance (kenny)
@@ -7187,7 +7183,7 @@ variables without "." added to customization hooks (kupries)
2008-03-27 clock tzdata updated to Olson's tzdata2008b (kenny)
---- Released 8.5.2, March 28, 2008 --- See ChangeLog for details ---
+--- Released 8.5.2, March 28, 2008
2008-03-30 (bug fix)[1783544] more robust TclIsNaN() (kenny,teterin)
@@ -7242,7 +7238,7 @@ variables without "." added to customization hooks (kupries)
2008-06-25 (bug fix)[1999119] Support TM packages in Safe Base (kupries)
---- Released 8.6a1, June 25, 2008 --- See ChangeLog for details ---
+--- Released 8.6a1, June 25, 2008
2008-06-29 (bug fix)[2004480] plug memory leaks (ade,porter,steffen)
@@ -7295,7 +7291,7 @@ in a deleted interp. (porter)
2008-08-21 (bug fix)[2065115] Restored ***= regexp functioning (hobbs,porter)
---- Released 8.6a2, August 25, 2008 --- See ChangeLog for details ---
+--- Released 8.6a2, August 25, 2008
2008-08-29 (bug fix)[2082299] Install TclOO header files (fellows)
@@ -7376,7 +7372,7 @@ Tcl_FSFileAttrStringsProc prototype. (nijtmans)
2008-10-10 (bug fix)[2155658] crash in oo method export (fellows)
---- Released 8.6a3, October 10, 2008 --- See ChangeLog for details ---
+--- Released 8.6a3, October 10, 2008
2008-10-13 (bug fix) Fix ability to join threads on 64-bit Windows (thoyts)
@@ -7446,7 +7442,7 @@ evaluation in extensions (sofer,kenny)
2008-12-18 (bug fix)[2444274] panic in long commands from {*} (goth,porter)
---- Released 8.6b1, December 19, 2008 --- See ChangeLog for details ---
+--- Released 8.6b1, December 19, 2008
2008-12-27 [TIP 234] Tcl_Zlib* interface revisions (fellows)
*** INCOMPATIBILITY with interface of 8.6b1 ***
@@ -7954,7 +7950,7 @@ memory with buffer backup (ferrieux)
Many more Tcl built-in command errors now set an -errorcode.
---- Released 8.6b2, August 8, 2011 --- See ChangeLog for details ---
+--- Released 8.6b2, August 8, 2011
2011-07-02 (bug fix)[3349507] correct double(1[string repeat 0 23]) (kenny)
@@ -8115,7 +8111,7 @@ Many revisions to better support a Cygwin environment (nijtmans)
Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
---- Released 8.6b3, September 18, 2012 --- See ChangeLog for details ---
+--- Released 8.6b3, September 18, 2012
2012-09-20 (enhancement) full Unicode support (nijtmans)
=> dde 1.4.0
@@ -8162,7 +8158,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter)
---- Released 8.6.0, December 20, 2012 --- See ChangeLog for details ---
+--- Released 8.6.0, December 20, 2012
2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd)
@@ -8251,7 +8247,7 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows)
2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows)
-2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans)
+2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1F (nijtmans)
2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans)
@@ -8796,6 +8792,55 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich)
--- Released 8.6.7, August 9, 2017 --- https://core.tcl-lang.org/tcl/ for details
+Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7,
+plus the following, which focuses on the high-level feature changes
+in this changeset (new minor version) rather than bug fixes:
+
+2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter)
+
+2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans)
+
+2016-07-19 (bug)[0363f0] Partial array search ID reform (porter)
+
+2016-07-19 (feature removed) Tcl_ObjType "array search" unregistered (porter)
+ *** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("array search") ***
+
+2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max)
+
+2016-11-25 [array names -regexp] supports backrefs (goth)
+
+2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy)
+
+2017-01-04 (TIP 459) New subcommand [package files] (nijtmans)
+
+2017-01-16 threaded allocator initialization repair (vasiljevic,nijtmans)
+
+2017-01-30 Add to Win shell builtins: assoc ftype move (ashok)
+
+2017-03-31 TCL_MEM_DEBUG facilities better support 64-bit memory (nijtmans)
+
+2017-04-13 \u escaped content in msg files converted to true utf-8 (nijtmans)
+
+2017-05-18 (TIP 458) New epoll or kqueue notifiers are default (alborboz)
+
+2017-05-31 Purge build support for SunOS-4.* (stu)
+
+2017-06-22 (TIP 463) New option [regsub ... -command ...] (fellows)
+
+2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows)
+=> TclOO 1.2.0
+
+2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin)
+
+2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann)
+
+2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
+
+--- Released 8.7a1, September 8, 2017 --- https://core.tcl-lang.org/tcl/ for details
+
2017-08-10 [array names -regexp] supports backrefs (goth)
2017-08-10 Fix gcc build failures due to #pragma placement (cassoff,fellows)
@@ -8946,6 +8991,138 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich)
- Released 8.6.10, Nov 21, 2019 - details at https://core.tcl-lang.org/tcl/ -
+Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10,
+plus the following, which focuses on the high-level feature changes
+in this changeset (new minor version) rather than bug fixes:
+
+2017-11-01 (bug)[3c32a3] crash deleting class mixed into instance (coulter)
+
+2017-11-03 [TIP 345] eliminate the encoding 'identity' (porter)
+
+2017-11-04 (bug)[0d902e] [string first] on ASCII stored as Unicode (fellows)
+
+2017-11-17 [TIP 422] Mark all Tcl_*VA() routines deprecated. (nijtmans)
+
+2017-11-20 (support) Ended use of the obsolete values.h header (culler)
+
+2017-11-30 (bug)[8e1e31] [lsort] ordering of U+0000 (nijtmans)
+
+2017-12-07 [TIP 487] Terminate support for pre-XP Windows (nijtmans)
+
+2017-12-08 [TIP 477] Reform of nmake build (nadkarni)
+
+2017-12-20 (bug)[ba1419] Crash: complex ensemble delete, namespace-7.8 (coulter)
+
+2018-01-17 [TIP 485] Removal of many deprecated features (nijtmans)
+
+2018-01-27 (bug) Crash in [join $l $l], join-4.1 (porter)
+
+2018-02-06 [TIP 493] Cease Distribution of http 1.0 (porter)
+
+2018-02-06 [TIP 484] internal rep for native ints are all 64-bit (nijtmans)
+
+2018-02-14 [TIP 476] Scan/Printf consistency (nijtmans)
+
+2018-03-05 [TIP 351] [lsearch] striding
+
+2018-03-05 [TIPs 330,336] tighten access to Interp fields (porter)
+
+2018-03-12 [TIP 462] [::tcl::process]
+
+2018-03-12 [TIP 490] add oo support for msgcat => msgcat 1.7.0 (oehlmann)
+
+2018-03-12 [TIP 499] custom locale preference list (oehlmann)
+=> msgcat 1.7.0
+
+2018-03-20 [TIP 503] End CONST84 support for Tcl 8.3 (porter)
+
+2018-03-30 Refactored [lrange] (spjuth)
+
+2018-04-20 [TIP 389] Unicode beyond BMP (nijtmans)
+
+2018-04-20 [TIP 421] [array for]
+
+2018-05-11 [TIP 425] Windows panic callback use of UTF-8
+
+2018-05-17 [TIP 491] Phase out --disable-threads support
+
+2018-06-03 [TIP 500] TclOO Private Methods and Variables
+
+2018-07-26 (bug)[ba921a] [string cat] of bytearrays (coulter,porter)
+
+2018-09-02 [TIP 478] Many new features in TclOO (lester,fellows)
+
+2018-09-04 (bug)[540bed] [binary format w] from bignum (nijtmans)
+
+2018-09-12 [TIP 430] zipfs and embedded script library (woods)
+
+2018-09-26 [TIP 508] [array default] (bonnet,fellows)
+
+2018-09-27 [TIP 515] level value reform (nijtmans)
+
+2018-09-27 [TIP 516] More OO slot operations (fellows)
+
+2018-09-27 [TIP 426] [info cmdtype] (fellows)
+
+2018-09-28 [TIP 509] Cross platform reentrant mutex
+
+2018-10-08 [TIP 514] native integers are 64-bit
+
+2018-10-12 [TIP 502] index value reform (porter)
+
+2018-11-06 [TIP 406] http cookies (fellows)
+
+2018-11-06 [TIP 445] Tcl_ObjType utilities (migrate to Tcl 9) (porter)
+
+2018-11-06 [TIP 501] [string is dict]
+
+2018-11-06 [TIP 519] inline export/unexport option for [oo::define]
+
+2018-11-06 [TIP 523] [lpop]
+
+2018-11-06 [TIP 524] TclOO custom dialects
+
+2018-11-06 [TIP 506] Tcl_(Incr|Decr)RefCount macros -> functions (porter)
+
+2018-11-15 [TIP 512] No stub for Tcl_SetExitProc()
+
+2019-04-08 (bug)[45b9fa] crash in [try] (coulter)
+
+2019-04-14 [TIP 160] terminal and serial channel controls
+
+2019-04-14 [TIP 312] more types for Tcl_LinkVar
+
+2019-04-14 [TIP 367] [lremove]
+
+2019-04-14 [TIP 504] [string insert]
+
+2019-04-16 [TIP 342] [dict getwithdefault]
+
+2019-04-23 (bug)[67a5ea] make [chan postevent] asynchronous
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2019-05-25 [TIP 431] [file tempdir]
+
+2019-05-25 [TIP 383] [coroinject], [coroprobe]
+
+2019-05-31 [TIP 544] Tcl_GetIntForIndex()
+
+2019-06-12 Replace TclOffset() with offsetof()
+
+2019-06-15 [TIP 461] string compare operators for [expr]
+
+2019-06-16 [TIP 521] floating point classification functions for [expr]
+
+2019-06-20 (bug)[6bdadf] crash multi-arg traced [lappend] (fellows)
+
+2019-06-28 [TIP 547] New encodings utf-16, ucs-2
+
+2019-09-14 [TIP 414] Tcl_InitSubsystems()
+
+2019-09-14 [TIP 548] wchar_t conversion functions
+
+- Released 8.7a3, Nov 21, 2019 --- https://core.tcl-lang.org/tcl/ for details -
+
2019-12-03 (bug)[3cd9be] Corner case in surrogate handling (nijtmans)
2019-12-09 (new) Add tcltest::(Setup|Eval|Cleanup|)Test (coulter,sebres)
@@ -9051,7 +9228,7 @@ See RFC 2045
2020-09-17 (bug)[835c93] Support TIP 525 exit code for -singleproc 1 (nijtmans)
=> tcltest 2.5.3
-2020-09-25 (new) force -eofchar \032 when evaluating library scripts (nijtmans)
+2020-09-25 (new) force -eofchar \x1A when evaluating library scripts (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
2020-09-29 (bug)[0063cb] http::geturl -headers must be dict (oehlmann,nijtmans)
@@ -9075,6 +9252,84 @@ See RFC 2045
- Released 8.6.11, Dec 31, 2020 - details at https://core.tcl-lang.org/tcl/ -
+Changes to 8.7a5 include all changes to the 8.6 line through 8.6.11,
+plus the following, which focuses on the high-level feature changes
+in this changeset (new minor version) rather than bug fixes:
+
+2019-12-13 [TIP 538] Externalize libtommath
+
+2020-01-20 [TIP 542] Support for switchable Full Unicode support
+
+2020-01-21 [TIP 543] Eliminate `TCL_INTERP_DESTROYED` flag value
+
+2020-01-24 [TIP 559] Eliminate public routine `Tcl_FreeResult
+
+2020-01-31 (new) Implement 64-bit seek on Zip channels. (nijtmans)
+
+2020-02-28 [TIP 557] C++ support for Tcl
+
+2020-02-28 [TIP 562] Deprecate channel types 1-4
+
+2020-03-11 (bug)[234d6c] Segfault in [set l {}; lpop l] (sebres)
+
+2020-03-12 (bug) Crash in tests binary-79.[12] (porter)
+
+2020-03-13 [TIP 569] Eliminate Comments That Serve Lint
+
+2020-04-06 (bug)[dd010c] [string trim*] on astral characters (porter,nijtmans)
+
+2020-05-30 [TIP 551] Permit underscore in numerical literals in source code
+
+2020-07-03 [TIP 578] Death to TCL_DBGX
+
+2020-08-11 (bug)[e87000] Win32 crash in [fconfigure stdout] (werner,nijtmans)
+
+2020-09-06 (bug)[c1a376] deletion trace on imported ensemble (coulter)
+
+2020-09-13 [TIP 585] Promote the INDEX_TEMP_TABLE flag of Tcl_GetIndexFromObj*() to the public interface
+
+2020-09-15 (bug)[b5777d] crash in [string index abcd 0-0x10000000000000000]
+
+2020-09-19 [b9ecf3] revised stork mgmt [uplevel [list $cmd ...]] (coulter)
+
+2020-10-23 [TIP 587] Default utf-8 for source command
+
+2020-10-27 (bug)[11229b] test string-31.26.* (porter)
+
+2020-11-08 [TIP 582] Comments in Expressions
+
+2020-11-16 [TIP 586] C String Parsing Support for binary scan
+
+2020-12-07 [TIP 590] Recommend lowercase Package Names
+
+2021-01-06 Bump to tcltest 2.5.4
+
+2021-01-15 [TIP 481] `Tcl_GetStringFromObj()` with `size_t` length parameter
+
+2021-01-15 [TIP 592] End support: Windows XP, Server 2003, Vista, Server 2008
+
+2021-01-25 tzdata updated to Olson's tzdata2021a (nijtmans)
+
+2021-01-29 (bug)[113be1] zipfs on mac
+
+2021-03-15 [TIP 575] Switchable Tcl_UtfCharComplete()/Tcl_UtfNext()/Tcl_UtfPrev()
+
+2021-03-19 (new)[0221b9] Drop TCL_WINDOW_EVENTS from Tcl's [update idletasks]
+
+2021-03-30 (new)[4b4830] [chan truncate] for reflected channels
+
+2021-04-30 [TIP 597] "string is unicode" and better utf-8/utf-16/cesu-8 encodings
+
+2021-04-09 [TIP 598] export TclWinConvertError
+
+2021-05-15 (bug)[463b7a] segfault from Tcl_Unload (coulter)
+
+2021-05-15 (bug)[fb2a41] tclZipfs.c free all memory (coulter)
+
+2021-05-18 (bug)[688fcc,28027d] namespace teardown reform (coulter)
+
+- Released 8.7a5, Jun 18, 2021 --- https://core.tcl-lang.org/tcl/ for details -
+
2021-02-02 (new) support for MacOS Big Sur updates (nijtmans)
=> platform 1.0.17
diff --git a/compat/dirent.h b/compat/dirent.h
deleted file mode 100644
index fa6222a..0000000
--- a/compat/dirent.h
+++ /dev/null
@@ -1,21 +0,0 @@
-/*
- * dirent.h --
- *
- * This file is a replacement for <dirent.h> in systems that
- * support the old BSD-style <sys/dir.h> with a "struct direct".
- *
- * Copyright (c) 1991 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef _DIRENT
-#define _DIRENT
-
-#include <sys/dir.h>
-
-#define dirent direct
-
-#endif /* _DIRENT */
diff --git a/compat/dirent2.h b/compat/dirent2.h
deleted file mode 100644
index 5be08ba..0000000
--- a/compat/dirent2.h
+++ /dev/null
@@ -1,53 +0,0 @@
-/*
- * dirent.h --
- *
- * Declarations of a library of directory-reading procedures
- * in the POSIX style ("struct dirent").
- *
- * Copyright (c) 1991 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef _DIRENT
-#define _DIRENT
-
-/*
- * Dirent structure, which holds information about a single
- * directory entry.
- */
-
-#define MAXNAMLEN 255
-#define DIRBLKSIZ 512
-
-struct dirent {
- long d_ino; /* Inode number of entry */
- short d_reclen; /* Length of this record */
- short d_namlen; /* Length of string in d_name */
- char d_name[MAXNAMLEN + 1]; /* Name must be no longer than this */
-};
-
-/*
- * State that keeps track of the reading of a directory (clients
- * should never look inside this structure; the fields should
- * only be accessed by the library procedures).
- */
-
-typedef struct _dirdesc {
- int dd_fd;
- long dd_loc;
- long dd_size;
- char dd_buf[DIRBLKSIZ];
-} DIR;
-
-/*
- * Procedures defined for reading directories:
- */
-
-extern void closedir (DIR *dirp);
-extern DIR * opendir (char *name);
-extern struct dirent * readdir (DIR *dirp);
-
-#endif /* _DIRENT */
diff --git a/compat/fake-rfc2553.c b/compat/fake-rfc2553.c
index f308cd0..cfe4c39 100644
--- a/compat/fake-rfc2553.c
+++ b/compat/fake-rfc2553.c
@@ -73,6 +73,7 @@ int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
struct sockaddr_in *sin = (struct sockaddr_in *)sa;
struct hostent *hp;
char tmpserv[16];
+ (void)salen;
if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)
return (EAI_FAMILY);
@@ -153,7 +154,7 @@ addrinfo *malloc_ai(int port, u_long addr, const struct addrinfo *hints)
{
struct addrinfo *ai;
- ai = malloc(sizeof(*ai) + sizeof(struct sockaddr_in));
+ ai = (struct addrinfo *)malloc(sizeof(*ai) + sizeof(struct sockaddr_in));
if (ai == NULL)
return (NULL);
diff --git a/compat/float.h b/compat/float.h
deleted file mode 100644
index 411edbf..0000000
--- a/compat/float.h
+++ /dev/null
@@ -1,14 +0,0 @@
-/*
- * float.h --
- *
- * This is a dummy header file to #include in Tcl when there
- * is no float.h in /usr/include. Right now this file is empty:
- * Tcl contains #ifdefs to deal with the lack of definitions;
- * all it needs is for the #include statement to work.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
diff --git a/compat/memcmp.c b/compat/memcmp.c
deleted file mode 100644
index c4e25a8..0000000
--- a/compat/memcmp.c
+++ /dev/null
@@ -1,64 +0,0 @@
-/*
- * memcmp.c --
- *
- * Source code for the "memcmp" library routine.
- *
- * Copyright (c) 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.
- */
-
-#include "tclPort.h"
-
-/*
- * Here is the prototype just in case it is not included in tclPort.h.
- */
-
-int memcmp(const void *s1, const void *s2, size_t n);
-
-/*
- *----------------------------------------------------------------------
- *
- * memcmp --
- *
- * Compares two bytes sequences.
- *
- * Results:
- * Compares its arguments, looking at the first n bytes (each interpreted
- * as an unsigned char), and returns an integer less than, equal to, or
- * greater than 0, according as s1 is less than, equal to, or greater
- * than s2 when taken to be unsigned 8 bit numbers.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-memcmp(
- const void *s1, /* First string. */
- const void *s2, /* Second string. */
- size_t n) /* Length to compare. */
-{
- const unsigned char *ptr1 = (const unsigned char *) s1;
- const unsigned char *ptr2 = (const unsigned char *) s2;
-
- for ( ; n-- ; ptr1++, ptr2++) {
- unsigned char u1 = *ptr1, u2 = *ptr2;
-
- if (u1 != u2) {
- return (u1-u2);
- }
- }
- return 0;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/compat/mkstemp.c b/compat/mkstemp.c
index 6807414..feccfbb 100644
--- a/compat/mkstemp.c
+++ b/compat/mkstemp.c
@@ -13,6 +13,7 @@
#include <fcntl.h>
#include <stdlib.h>
#include <unistd.h>
+#include <string.h>
/*
*----------------------------------------------------------------------
@@ -32,19 +33,19 @@
int
mkstemp(
- char *template) /* Template for filename. */
+ char *tmpl) /* Template for filename. */
{
static const char alphanumerics[] =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
char *a, *b;
int fd, count, alphanumericsLen = strlen(alphanumerics); /* == 62 */
- a = template + strlen(template);
- while (a > template && *(a-1) == 'X') {
+ a = tmpl + strlen(tmpl);
+ while (a > tmpl && *(a-1) == 'X') {
a--;
}
- if (a == template) {
+ if (a == tmpl) {
errno = ENOENT;
return -1;
}
@@ -71,7 +72,7 @@ mkstemp(
* Template is now realized; try to open (with correct options).
*/
- fd = open(template, O_RDWR|O_CREAT|O_EXCL, 0600);
+ fd = open(tmpl, O_RDWR|O_CREAT|O_EXCL, 0600);
} while (fd == -1 && errno == EEXIST && --count > 0);
return fd;
diff --git a/compat/opendir.c b/compat/opendir.c
deleted file mode 100644
index 64aedaa..0000000
--- a/compat/opendir.c
+++ /dev/null
@@ -1,110 +0,0 @@
-/*
- * opendir.c --
- *
- * This file provides dirent-style directory-reading procedures for V7
- * Unix systems that don't have such procedures. The origin of this code
- * is unclear, but it seems to have come originally from Larry Wall.
- */
-
-#include "tclInt.h"
-
-#undef DIRSIZ
-#define DIRSIZ(dp) \
- ((sizeof(struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3))
-
-/*
- * open a directory.
- */
-
-DIR *
-opendir(
- char *name)
-{
- DIR *dirp;
- int fd;
- const char *myname;
-
- myname = ((*name == '\0') ? "." : name);
- if ((fd = open(myname, 0, 0)) == -1) {
- return NULL;
- }
- dirp = (DIR *) attemptckalloc(sizeof(DIR));
- if (dirp == NULL) {
- /* unreachable? */
- close(fd);
- return NULL;
- }
- dirp->dd_fd = fd;
- dirp->dd_loc = 0;
- return dirp;
-}
-
-/*
- * read an old style directory entry and present it as a new one
- */
-#ifndef pyr
-#define ODIRSIZ 14
-
-struct olddirect {
- ino_t od_ino;
- char od_name[ODIRSIZ];
-};
-#else /* a Pyramid in the ATT universe */
-#define ODIRSIZ 248
-
-struct olddirect {
- long od_ino;
- short od_fill1, od_fill2;
- char od_name[ODIRSIZ];
-};
-#endif
-
-/*
- * get next entry in a directory.
- */
-
-struct dirent *
-readdir(
- DIR *dirp)
-{
- struct olddirect *dp;
- static struct dirent dir;
-
- for (;;) {
- if (dirp->dd_loc == 0) {
- dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ);
- if (dirp->dd_size <= 0) {
- return NULL;
- }
- }
- if (dirp->dd_loc >= dirp->dd_size) {
- dirp->dd_loc = 0;
- continue;
- }
- dp = (struct olddirect *)(dirp->dd_buf + dirp->dd_loc);
- dirp->dd_loc += sizeof(struct olddirect);
- if (dp->od_ino == 0) {
- continue;
- }
- dir.d_ino = dp->od_ino;
- strncpy(dir.d_name, dp->od_name, ODIRSIZ);
- dir.d_name[ODIRSIZ] = '\0'; /* insure null termination */
- dir.d_namlen = strlen(dir.d_name);
- dir.d_reclen = DIRSIZ(&dir);
- return &dir;
- }
-}
-
-/*
- * close a directory.
- */
-
-void
-closedir(
- DIR *dirp)
-{
- close(dirp->dd_fd);
- dirp->dd_fd = -1;
- dirp->dd_loc = 0;
- ckfree((char *)dirp);
-}
diff --git a/compat/stdlib.h b/compat/stdlib.h
deleted file mode 100644
index 2f7eaf4..0000000
--- a/compat/stdlib.h
+++ /dev/null
@@ -1,39 +0,0 @@
-/*
- * stdlib.h --
- *
- * Declares facilities exported by the "stdlib" portion of the C library.
- * This file isn't complete in the ANSI-C sense; it only declares things
- * that are needed by Tcl. This file is needed even on many systems with
- * their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare
- * all the procedures needed here (such as strtol/strtoul).
- *
- * Copyright (c) 1991 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.
- */
-
-#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 */
diff --git a/compat/string.h b/compat/string.h
index 42be10c..aa889f2 100644
--- a/compat/string.h
+++ b/compat/string.h
@@ -21,19 +21,15 @@
#include <sys/types.h>
-#ifdef __APPLE__
extern void * memchr(const void *s, int c, size_t n);
-#else
-extern char * memchr(const void *s, int c, size_t n);
-#endif
extern int memcmp(const void *s1, const void *s2, size_t n);
-extern char * memcpy(void *t, const void *f, size_t n);
+extern void * memcpy(void *t, const void *f, size_t n);
#ifdef NO_MEMMOVE
#define memmove(d,s,n) (bcopy((s), (d), (n)))
#else
extern char * memmove(void *t, const void *f, size_t n);
#endif
-extern char * memset(void *s, int c, size_t n);
+extern void * memset(void *s, int c, size_t n);
extern int strcasecmp(const char *s1, const char *s2);
extern char * strcat(char *dst, const char *src);
diff --git a/compat/strstr.c b/compat/strstr.c
deleted file mode 100644
index 35386d0..0000000
--- a/compat/strstr.c
+++ /dev/null
@@ -1,70 +0,0 @@
-/*
- * strstr.c --
- *
- * Source code for the "strstr" library routine.
- *
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tcl.h"
-#ifndef NULL
-#define NULL 0
-#endif
-
-/*
- *----------------------------------------------------------------------
- *
- * strstr --
- *
- * Locate the first instance of a substring in a string.
- *
- * Results:
- * If string contains substring, the return value is the location of the
- * first matching instance of substring in string. If string doesn't
- * contain substring, the return value is 0. Matching is done on an exact
- * character-for-character basis with no wildcards or special characters.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-strstr(
- const char *string, /* String to search. */
- const char *substring) /* Substring to try to find in string. */
-{
- const char *a, *b;
-
- /*
- * First scan quickly through the two strings looking for a
- * single-character match. When it's found, then compare the rest of the
- * substring.
- */
-
- b = substring;
- if (*b == 0) {
- return (char *)string;
- }
- for ( ; *string != 0; string += 1) {
- if (*string != *b) {
- continue;
- }
- a = string;
- while (1) {
- if (*b == 0) {
- return (char *)string;
- }
- if (*a++ != *b++) {
- break;
- }
- }
- b = substring;
- }
- return NULL;
-}
diff --git a/compat/strtol.c b/compat/strtol.c
deleted file mode 100644
index a9866f4..0000000
--- a/compat/strtol.c
+++ /dev/null
@@ -1,77 +0,0 @@
-/*
- * strtol.c --
- *
- * Source code for the "strtol" library procedure.
- *
- * Copyright (c) 1988 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-/*
- *----------------------------------------------------------------------
- *
- * strtol --
- *
- * Convert an ASCII string into an integer.
- *
- * Results:
- * The return value is the integer equivalent of string. If endPtr is
- * non-NULL, then *endPtr is filled in with the character after the last
- * one that was part of the integer. If string doesn't contain a valid
- * integer value, then zero is returned and *endPtr is set to string.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-long int
-strtol(
- const char *string, /* String of ASCII digits, possibly preceded
- * by white space. For bases greater than 10,
- * either lower- or upper-case digits may be
- * used. */
- char **endPtr, /* Where to store address of terminating
- * character, or NULL. */
- int base) /* Base for conversion. Must be less than 37.
- * If 0, then the base is chosen from the
- * leading characters of string: "0x" means
- * hex, "0" means octal, anything else means
- * decimal. */
-{
- const char *p;
- long result;
-
- /*
- * Skip any leading blanks.
- */
-
- p = string;
- while (isspace(UCHAR(*p))) {
- p += 1;
- }
-
- /*
- * Check for a sign.
- */
-
- if (*p == '-') {
- p += 1;
- result = -(strtoul(p, endPtr, base));
- } else {
- if (*p == '+') {
- p += 1;
- }
- result = strtoul(p, endPtr, base);
- }
- if ((result == 0) && (endPtr != 0) && (*endPtr == p)) {
- *endPtr = (char *) string;
- }
- return result;
-}
diff --git a/compat/strtoul.c b/compat/strtoul.c
deleted file mode 100644
index af63036..0000000
--- a/compat/strtoul.c
+++ /dev/null
@@ -1,214 +0,0 @@
-/*
- * strtoul.c --
- *
- * Source code for the "strtoul" library procedure.
- *
- * Copyright (c) 1988 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-/*
- * The table below is used to convert from ASCII digits to a numerical
- * equivalent. It maps from '0' through 'z' to integers (100 for non-digit
- * characters).
- */
-
-static const char cvtIn[] = {
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */
- 100, 100, 100, 100, 100, 100, 100, /* punctuation */
- 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */
- 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
- 30, 31, 32, 33, 34, 35,
- 100, 100, 100, 100, 100, 100, /* punctuation */
- 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */
- 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
- 30, 31, 32, 33, 34, 35};
-
-/*
- *----------------------------------------------------------------------
- *
- * strtoul --
- *
- * Convert an ASCII string into an integer.
- *
- * Results:
- * The return value is the integer equivalent of string. If endPtr is
- * non-NULL, then *endPtr is filled in with the character after the last
- * one that was part of the integer. If string doesn't contain a valid
- * integer value, then zero is returned and *endPtr is set to string.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-unsigned long int
-strtoul(
- const char *string, /* String of ASCII digits, possibly preceded
- * by white space. For bases greater than 10,
- * either lower- or upper-case digits may be
- * used. */
- char **endPtr, /* Where to store address of terminating
- * character, or NULL. */
- int base) /* Base for conversion. Must be less than 37.
- * If 0, then the base is chosen from the
- * leading characters of string: "0x" means
- * hex, "0" means octal, anything else means
- * decimal. */
-{
- const char *p;
- unsigned long int result = 0;
- unsigned digit;
- int anyDigits = 0;
- int negative=0;
- int overflow=0;
-
- /*
- * Skip any leading blanks.
- */
-
- p = string;
- while (isspace(UCHAR(*p))) {
- p += 1;
- }
- if (*p == '-') {
- negative = 1;
- p += 1;
- } else {
- if (*p == '+') {
- p += 1;
- }
- }
-
- /*
- * If no base was provided, pick one from the leading characters of the
- * string.
- */
-
- if (base == 0) {
- if (*p == '0') {
- p += 1;
- if ((*p == 'x') || (*p == 'X')) {
- p += 1;
- base = 16;
- } else {
- /*
- * Must set anyDigits here, otherwise "0" produces a "no
- * digits" error.
- */
-
- anyDigits = 1;
- base = 8;
- }
- } else {
- base = 10;
- }
- } else if (base == 16) {
- /*
- * Skip a leading "0x" from hex numbers.
- */
-
- if ((p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
- p += 2;
- }
- }
-
- /*
- * Sorry this code is so messy, but speed seems important. Do different
- * things for base 8, 10, 16, and other.
- */
-
- if (base == 8) {
- unsigned long maxres = ULONG_MAX >> 3;
-
- for ( ; ; p += 1) {
- digit = *p - '0';
- if (digit > 7) {
- break;
- }
- if (result > maxres) { overflow = 1; }
- result = (result << 3);
- if (digit > (ULONG_MAX - result)) { overflow = 1; }
- result += digit;
- anyDigits = 1;
- }
- } else if (base == 10) {
- unsigned long maxres = ULONG_MAX / 10;
-
- for ( ; ; p += 1) {
- digit = *p - '0';
- if (digit > 9) {
- break;
- }
- if (result > maxres) { overflow = 1; }
- result *= 10;
- if (digit > (ULONG_MAX - result)) { overflow = 1; }
- result += digit;
- anyDigits = 1;
- }
- } else if (base == 16) {
- unsigned long maxres = ULONG_MAX >> 4;
-
- for ( ; ; p += 1) {
- digit = *p - '0';
- if (digit > ('z' - '0')) {
- break;
- }
- digit = cvtIn[digit];
- if (digit > 15) {
- break;
- }
- if (result > maxres) { overflow = 1; }
- result = (result << 4);
- if (digit > (ULONG_MAX - result)) { overflow = 1; }
- result += digit;
- anyDigits = 1;
- }
- } else if (base >= 2 && base <= 36) {
- unsigned long maxres = ULONG_MAX / base;
-
- for ( ; ; p += 1) {
- digit = *p - '0';
- if (digit > ('z' - '0')) {
- break;
- }
- digit = cvtIn[digit];
- if (digit >= ( (unsigned) base )) {
- break;
- }
- if (result > maxres) { overflow = 1; }
- result *= base;
- if (digit > (ULONG_MAX - result)) { overflow = 1; }
- result += digit;
- anyDigits = 1;
- }
- }
-
- /*
- * See if there were any digits at all.
- */
-
- if (!anyDigits) {
- p = string;
- }
-
- if (endPtr != 0) {
- /* unsafe, but required by the strtoul prototype */
- *endPtr = (char *) p;
- }
-
- if (overflow) {
- errno = ERANGE;
- return ULONG_MAX;
- }
- if (negative) {
- return -result;
- }
- return result;
-}
diff --git a/compat/unistd.h b/compat/unistd.h
deleted file mode 100644
index 1725590..0000000
--- a/compat/unistd.h
+++ /dev/null
@@ -1,76 +0,0 @@
-/*
- * unistd.h --
- *
- * Macros, constants and prototypes for Posix conformance.
- *
- * Copyright 1989 Regents of the University of California Permission to use,
- * copy, modify, and distribute this software and its documentation for any
- * purpose and without fee is hereby granted, provided that the above
- * copyright notice appear in all copies. The University of California makes
- * no representations about the suitability of this software for any purpose.
- * It is provided "as is" without express or implied warranty.
- */
-
-#ifndef _UNISTD
-#define _UNISTD
-
-#include <sys/types.h>
-
-#ifndef NULL
-# define NULL 0
-#endif
-
-/*
- * Strict POSIX stuff goes here. Extensions go down below, in the ifndef
- * _POSIX_SOURCE section.
- */
-
-extern void _exit(int status);
-extern int access(const char *path, int mode);
-extern int chdir(const char *path);
-extern int chown(const char *path, uid_t owner, gid_t group);
-extern int close(int fd);
-extern int dup(int oldfd);
-extern int dup2(int oldfd, int newfd);
-extern int execl(const char *path, ...);
-extern int execle(const char *path, ...);
-extern int execlp(const char *file, ...);
-extern int execv(const char *path, char *const argv[]);
-extern int execve(const char *path, char *const argv[], char *const *envp);
-extern int execvp(const char *file, char *const argv[]);
-extern pid_t fork(void);
-extern char * getcwd(char *buf, size_t size);
-extern gid_t getegid(void);
-extern uid_t geteuid(void);
-extern gid_t getgid(void);
-extern int getgroups(int bufSize, int *buffer);
-extern pid_t getpid(void);
-extern uid_t getuid(void);
-extern int isatty(int fd);
-extern long lseek(int fd, long offset, int whence);
-extern int pipe(int *fildes);
-extern int read(int fd, char *buf, size_t size);
-extern int setgid(gid_t group);
-extern int setuid(uid_t user);
-extern unsigned sleep(unsigned seconds);
-extern char * ttyname(int fd);
-extern int unlink(const char *path);
-extern int write(int fd, const char *buf, size_t size);
-
-#ifndef _POSIX_SOURCE
-extern char * crypt(const char *, const char *);
-extern int fchown(int fd, uid_t owner, gid_t group);
-extern int flock(int fd, int operation);
-extern int ftruncate(int fd, unsigned long length);
-extern int ioctl(int fd, int request, ...);
-extern int readlink(const char *path, char *buf, int bufsize);
-extern int setegid(gid_t group);
-extern int seteuid(uid_t user);
-extern int setreuid(int ruid, int euid);
-extern int symlink(const char *, const char *);
-extern int ttyslot(void);
-extern int truncate(const char *path, unsigned long length);
-extern int vfork(void);
-#endif /* _POSIX_SOURCE */
-
-#endif /* _UNISTD */
diff --git a/compat/waitpid.c b/compat/waitpid.c
index e41361b..ec03cab 100644
--- a/compat/waitpid.c
+++ b/compat/waitpid.c
@@ -100,7 +100,7 @@ waitpid(
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
- ckfree((char *) waitPtr);
+ ckfree(waitPtr);
return result;
}
diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll
index 8c98bad..0ea471e 100755
--- a/compat/zlib/win32/zlib1.dll
+++ b/compat/zlib/win32/zlib1.dll
Binary files differ
diff --git a/compat/zlib/win64/libz.dll.a b/compat/zlib/win64/libz.dll.a
index 8a2b373..6357809 100644
--- a/compat/zlib/win64/libz.dll.a
+++ b/compat/zlib/win64/libz.dll.a
Binary files differ
diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll
index 445313e..d25d995 100755
--- a/compat/zlib/win64/zlib1.dll
+++ b/compat/zlib/win64/zlib1.dll
Binary files differ
diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index 404382e..c71926b 100644
--- a/doc/AddErrInfo.3
+++ b/doc/AddErrInfo.3
@@ -119,7 +119,7 @@ retrieve the stack trace when script evaluation returns
\fBTCL_ERROR\fR, like so:
.PP
.CS
-int code = Tcl_Eval(interp, script);
+int code = Tcl_EvalEx(interp, script, -1, 0);
if (code == TCL_ERROR) {
Tcl_Obj *options = \fBTcl_GetReturnOptions\fR(interp, code);
Tcl_Obj *key = Tcl_NewStringObj("-errorinfo", -1);
@@ -247,6 +247,9 @@ record instead of a value. Otherwise, it is similar to
.PP
\fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that
instead of taking a variable number of arguments it takes an argument list.
+Interfaces using argument lists have been found to be nonportable in practice.
+This function is deprecated and will be removed in Tcl 9.0.
+
.PP
The procedure \fBTcl_GetErrorLine\fR is used to read the integer value
of the \fB\-errorline\fR return option without the overhead of a full
@@ -305,6 +308,22 @@ The global variables \fBerrorInfo\fR and
\fBerrorCode\fR are not modified by \fBTcl_ResetResult\fR
so they continue to hold a record of information about the
most recent error seen in an interpreter.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The result of \fBTcl_GetReturnOptions\fR will have at least one
+reference to it from the Tcl interpreter. If not using it immediately,
+you should use \fBTcl_IncrRefCount\fR to add your own reference.
+.PP
+The \fIoptions\fR argument to \fBTcl_SetReturnOptions\fR will have a
+reference added by the Tcl interpreter; it may safely be called with a
+zero-reference value.
+.PP
+\fBTcl_AppendObjToErrorInfo\fR only reads its \fIobjPtr\fR argument;
+it does not modify its reference count at all.
+.PP
+The \fIerrorObjPtr\fR argument to \fBTcl_SetObjErrorCode\fR will have a
+reference added by the Tcl interpreter; it may safely be called with a
+zero-reference value.
.SH "SEE ALSO"
Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3),
Tcl_SetErrno(3), errorCode(n), errorInfo(n)
diff --git a/doc/Async.3 b/doc/Async.3
index 347ba3d..e6ec5f8 100644
--- a/doc/Async.3
+++ b/doc/Async.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events
+Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncMarkFromSignal, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -17,11 +17,16 @@ Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady
Tcl_AsyncHandler
\fBTcl_AsyncCreate\fR(\fIproc, clientData\fR)
.sp
+void
\fBTcl_AsyncMark\fR(\fIasync\fR)
.sp
int
+\fBTcl_AsyncMarkFromSignal\fR(\fIasync\fR, \fIsigNumber\fR)
+.sp
+int
\fBTcl_AsyncInvoke\fR(\fIinterp, code\fR)
.sp
+void
\fBTcl_AsyncDelete\fR(\fIasync\fR)
.sp
int
@@ -34,6 +39,8 @@ Procedure to invoke to handle an asynchronous event.
One-word value to pass to \fIproc\fR.
.AP Tcl_AsyncHandler async in
Token for asynchronous event handler.
+.AP int sigNumber in
+POSIX signal number, when used in a signal context.
.AP Tcl_Interp *interp in
Tcl interpreter in which command was being evaluated when handler was
invoked, or NULL if handler was invoked when there was no interpreter
@@ -60,10 +67,11 @@ to a clean state, such as after the current Tcl command completes.
.PP
\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
are thread sensitive. They access and/or set a thread-specific data
-structure in the event of a core built with \fI\-\-enable\-threads\fR. The token
-created by \fBTcl_AsyncCreate\fR contains the needed thread information it
-was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield
-the origin thread into the asynchronous handler.
+structure in the event of a core built with \fI\-\-enable\-threads\fR.
+The token created by \fBTcl_AsyncCreate\fR contains the needed thread
+information it was called from so that calling \fBTcl_AsyncMarkFromSignal\fR
+or \fBTcl_AsyncMark\fR with this token will only yield the origin
+thread into the asynchronous handler.
.PP
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
@@ -72,13 +80,16 @@ any occurrences of the asynchronous event that it is intended
to handle (it is not safe to create a handler at the time of
an event).
When an asynchronous event occurs the code that detects the event
-(such as a signal handler) should call \fBTcl_AsyncMark\fR with the
-token for the handler.
-\fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it
-will not invoke the handler immediately.
-Tcl will call the \fIproc\fR associated with the handler later, when
-the world is in a safe state, and \fIproc\fR can then carry out
-the actions associated with the asynchronous event.
+(such as a POSIX signal handler) should call \fBTcl_AsyncMarkFromSignal\fR
+with the token for the handler and the POSIX signal number. The
+return value of this function is true, when the handler will be
+marked, false otherwise.
+For non-signal contexts, \fBTcl_AsyncMark\fR serves the same purpose.
+\fBTcl_AsyncMarkFromSignal\fR and \fBTcl_AsyncMark\fR will mark
+the handler as ready to execute, but will not invoke the handler
+immediately. Tcl will call the \fIproc\fR associated with the
+handler later, when the world is in a safe state, and \fIproc\fR
+can then carry out the actions associated with the asynchronous event.
\fIProc\fR should have arguments and result that match the
type \fBTcl_AsyncProc\fR:
.PP
diff --git a/doc/BoolObj.3 b/doc/BoolObj.3
index 795c08a..71580af 100644
--- a/doc/BoolObj.3
+++ b/doc/BoolObj.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj
+Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj, Tcl_GetBoolFromObj \- store/retrieve boolean value in a Tcl_Obj
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -20,7 +20,10 @@ Tcl_Obj *
\fBTcl_SetBooleanObj\fR(\fIobjPtr, intValue\fR)
.sp
int
-\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, intPtr\fR)
+\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR)
+.sp
+int
+\fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. charPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp intValue in/out
.AP int intValue in
@@ -32,9 +35,16 @@ retrieve a boolean value.
If a boolean value cannot be retrieved,
an error message is left in the interpreter's result value
unless \fIinterp\fR is NULL.
-.AP int *intPtr out
+.AP "bool \&| int" *boolPtr out
Points to place where \fBTcl_GetBooleanFromObj\fR
stores the boolean value (0 or 1) obtained from \fIobjPtr\fR.
+.AP char *charPtr out
+Points to place where \fBTcl_GetBoolFromObj\fR
+stores the boolean value (0 or 1) obtained from \fIobjPtr\fR.
+.AP int flags in
+0 or TCL_NULL_OK. If TCL_NULL_OK
+is used, then the empty string or NULL will result in \fBTcl_GetBoolFromObj\fR
+return TCL_OK, the *charPtr filled with the value \fB'\exFF'\fR;
.BE
.SH DESCRIPTION
@@ -61,13 +71,13 @@ any former value stored in \fI*objPtr\fR.
from the value stored in \fI*objPtr\fR.
If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR,
then the recognized boolean value is written at the address given
-by \fIintPtr\fR.
+by \fIboolPtr\fR.
If \fIobjPtr\fR holds any value recognized as
a number by Tcl, then if that value is zero a 0 is written at
-the address given by \fIintPtr\fR and if that
-value is non-zero a 1 is written at the address given by \fIintPtr\fR.
+the address given by \fIboolPtr\fR and if that
+value is non-zero a 1 is written at the address given by \fIboolPtr\fR.
In all cases where a value is written at the address given
-by \fIintPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR.
+by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR.
If the value of \fIobjPtr\fR does not meet any of the conditions
above, then \fBTCL_ERROR\fR is returned and an error message is
left in the interpreter's result unless \fIinterp\fR is NULL.
@@ -76,6 +86,11 @@ fields of \fI*objPtr\fR so that future calls to
\fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be
performed more efficiently.
.PP
+\fBTcl_GetBoolFromObj\fR functions almost the same as
+\fBTcl_GetBooleanFromObj\fR, but it has an additional parameter
+\fBflags\fR, which can be used to specify whether the empty
+string or NULL is accepted as valid.
+.PP
Note that the routines \fBTcl_GetBooleanFromObj\fR and
\fBTcl_GetBoolean\fR are not functional equivalents.
The set of values for which \fBTcl_GetBooleanFromObj\fR
@@ -88,6 +103,18 @@ will lead to a \fBTCL_OK\fR return (and the boolean value 1),
while the same value passed to \fBTcl_GetBoolean\fR will lead to
a \fBTCL_ERROR\fR return.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewBooleanObj\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_SetBooleanObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument, but does require that the object be unshared.
+.PP
+\fBTcl_GetBooleanFromObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument; it only reads. Note however that this function
+may set the interpreter result; if that is the only place that
+is holding a reference to the object, it will be deleted.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_IsShared, Tcl_GetBoolean
diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3
index ff0b4e1..8ddc28c 100644
--- a/doc/ByteArrObj.3
+++ b/doc/ByteArrObj.3
@@ -8,84 +8,180 @@
.so man.macros
.BS
.SH NAME
-Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes
+Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetBytesFromObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate a Tcl value as an array of bytes
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
-\fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR)
+\fBTcl_NewByteArrayObj\fR(\fIbytes, numBytes\fR)
.sp
void
-\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR)
+\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, numBytes\fR)
.sp
+.VS TIP568
unsigned char *
-\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR)
+\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, numBytesPtr\fR)
+.VE TIP568
.sp
unsigned char *
-\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR)
+\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, numBytesPtr\fR)
+.sp
+unsigned char *
+\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR)
.SH ARGUMENTS
-.AS "const unsigned char" *lengthPtr in/out
+.AS "const unsigned char" *numBytesPtr in/out
.AP "const unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array value. May be NULL
-even if \fIlength\fR is non-zero.
-.AP int length in
-The length of the array of bytes. It must be >= 0.
+even if \fInumBytes\fR is non-zero.
+.AP int numBytes in
+The number of bytes in the array. It must be >= 0.
.AP Tcl_Obj *objPtr in/out
-For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to
-byte-array type. For \fBTcl_GetByteArrayFromObj\fR and
-\fBTcl_SetByteArrayLength\fR, this points to the value from which to get
-the byte-array value; if \fIobjPtr\fR does not already point to a byte-array
-value, it will be converted to one.
-.AP int *lengthPtr out
-If non-NULL, filled with the length of the array of bytes in the value.
+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 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 procedures are used to create, modify, and read Tcl byte-array values
-from C code. Byte-array values are typically used to hold the
-results of binary IO operations or data structures created with the
-\fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a
-string. Conceptually, a string is an array of Unicode characters, while a
-byte-array is an array of 8-bit quantities with no implicit meaning.
-Accessor functions are provided to get the string representation of a
-byte-array or to convert an arbitrary value to a byte-array. Obtaining the
+These routines are used to create, modify, store, transfer, and retrieve
+arbitrary binary data in Tcl values. Specifically, data that can be
+represented as a sequence of arbitrary byte values is supported.
+This includes data read from binary channels, values created by the
+\fBbinary\fR command, encrypted data, or other information representable as
+a finite byte sequence.
+.PP
+A byte is an 8-bit quantity with no inherent meaning. When the 8 bits are
+interpreted as an integer value, the range of possible values is (0-255).
+The C type best suited to store a byte is the \fBunsigned char\fR.
+An \fBunsigned char\fR array of size \fIN\fR stores an aribtrary binary
+value of size \fIN\fR bytes. We call this representation a byte-array.
+Here we document the routines that allow us to operate on Tcl values as
+byte-arrays.
+.PP
+All Tcl values must correspond to a string representation.
+When a byte-array value must be processed as a string, the sequence
+of \fIN\fR bytes is transformed into the corresponding sequence
+of \fIN\fR characters, where each byte value transforms to the same
+character codepoint value in the range (U+0000 - U+00FF). Obtaining the
string representation of a byte-array value (by calling
-\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a
-one-to-one mapping between the bytes in the internal representation and the
-UTF-8 characters in the string representation.
+\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual
+Modified UTF-8 encoding.
+.PP
+\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR
+create a new value or overwrite an existing unshared value, respectively,
+to hold a byte-array value of \fInumBytes\fR bytes. When a caller
+passes a non-NULL value of \fIbytes\fR, it must point to memory from
+which \fInumBytes\fR bytes can be read. These routines
+allocate \fInumBytes\fR bytes of memory, copy \fInumBytes\fR
+bytes from \fIbytes\fR into it, and keep the result in the internal
+representation of the new or overwritten value.
+When the caller passes a NULL value of \fIbytes\fR, the data copying
+step is skipped, and the bytes stored in the value are undefined.
+A \fIbytes\fR value of NULL is useful only when the caller will arrange
+to write known contents into the byte-array through a pointer retrieved
+by a call to one of the routines explained below. \fBTcl_NewByteArrayObj\fR
+returns a pointer to the created value with a reference count of zero.
+\fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents
+of the unshared \fIobjPtr\fR as appropriate, and keeps its reference
+count (0 or 1) unchanged. The value produced by these routines has no
+string representation. Any memory allocation failure may cause a panic.
+Note that the type of the \fInumBytes\fR argument is \fBint\fR; consequently
+the largest byte-array value that can be produced by these routines is one
+holding \fBINT_MAX\fR bytes. Note also that the string representation of
+any Tcl value is limited to \fBINT_MAX\fR bytes, so caution should be
+taken with any byte-array of more than \fBINT_MAX / 2\fR bytes.
+.PP
+\fBTcl_GetBytesFromObj\fR performs the opposite function of
+\fBTcl_SetByteArrayObj\fR, providing access to read a byte-array from
+a Tcl value that was previously written into it. When \fIobjPtr\fR
+is a value previously produced by \fBTcl_NewByteArrayObj\fR or
+\fBTcl_SetByteArrayObj\fR, then \fBTcl_GetBytesFromObj\fR returns
+a pointer to the byte-array kept in the value's internal representation.
+If the caller provides a non-NULL value for \fInumBytesPtr\fR, it must
+point to memory where \fBTcl_GetBytesFromObj\fR can write the number
+of bytes in the value's internal byte-array. With both pieces of
+information, the caller is able to retrieve any information about the
+contents of that byte-array that it seeks. When \fIobjPtr\fR does
+not already contain an internal byte-array, \fBTcl_GetBytesFromObj\fR
+will try to create one from the value's string representation. Any
+string value that does not include any character codepoints outside
+the range (U+0000 - U+00FF) will successfully translate to a unique
+byte-array value. With the created byte-array, the routine returns
+as before. For any string representation which does contain
+a forbidden character codepoint, the conversion fails, and
+\fBTcl_GetBytesFromObj\fR returns NULL to signal that failure. On
+failure, nothing will be written to \fInumBytesPtr\fR, and if
+the \fIinterp\fR argument is non-NULL, then error messages and
+codes are left in it recording the error.
+.PP
+\fBTcl_GetByteArrayFromObj\fR performs nearly the same function as
+\fBTcl_GetBytesFromObj\fR. They differ only in the circumstance when
+a byte-array internal value must be created by transformation of
+a string representation, and that string representation contains a
+character with codepoint greater than U+00FF. Instead of failing
+the conversion, \fBTcl_GetByteArrayFromObj\fR will use the 8 least
+significant bits of each codepoint to produce a valid byte value
+from any character codepoint value. In any other circumstance,
+\fBTcl_GetByteArrayFromObj\fR performs just as \fBTcl_GetBytesFromObj\fR
+does. Since the conversion cannot fail, \fBTcl_GetByteArrayFromObj\fR
+has no need for an \fIinterp\fR argument to record any errors and
+the caller can assume \fBTcl_GetByteArrayFromObj\fR does not return NULL.
+.PP
+\fBTcl_GetByteArrayFromObj\fR must be used with caution. Because of the
+truncation on conversion, the byte-array made available to the caller
+cannot reliably complete a round-trip back to the original string
+representation. This creates opportunities for bugs due to blindness
+to differences in values. This routine exists in this form primarily
+for compatibility with codebases written for earlier releases of Tcl.
+It is expected this routine will incompatibly change in Tcl 9 so that
+it also signals failed conversions with a NULL return.
+.PP
+On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR
+return a pointer into the internal representation of a \fBTcl_Obj\fR.
+That pointer must not be freed by the caller, and should not be retained
+for use beyond the known time the internal representation of the value
+has not been disturbed. The pointer may be used to overwrite the byte
+contents of the internal representation, so long as the value is unshared
+and any string representation is invalidated.
+.PP
+On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR
+write the number of bytes in the byte-array value of \fIobjPtr\fR
+to the space pointed to by \fInumBytesPtr\fR.
+.PP
+\fBTcl_SetByteArrayLength\fR enables a caller to change the size of a
+byte-array in the internal representation of an unshared \fIobjPtr\fR to
+become \fInumBytes\fR bytes. This is most often useful after the
+bytes of the internal byte-array have been directly overwritten and it
+has been discovered that the required size differs from the first
+estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns
+a pointer to the resized byte-array. Because resizing the byte-array
+changes the internal representation, \fBTcl_SetByteArrayLength\fR
+also invalidates any string representation in \fIobjPtr\fR. If resizing
+grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR
+does not already possess an internal byte-array, one is produced in the
+same way that \fBTcl_GetByteArrayFromObj\fR does, with all the cautions
+that go along with that.
+.SH "REFERENCE COUNT MANAGEMENT"
.PP
-\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will
-create a new value of byte-array type or modify an existing value to have a
-byte-array type. Both of these procedures set the value's type to be
-byte-array and set the value's internal representation to a copy of the
-array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a
-pointer to a newly allocated value with a reference count of zero.
-\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if
-the value is not already a byte-array value, frees any old internal
-representation. If \fIbytes\fR is NULL then the new byte array contains
-arbitrary values.
+\fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
.PP
-\fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and
-returns a pointer to the value's new internal representation as an array of
-bytes. The length of this array is stored in \fIlengthPtr\fR if
-\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by
-the value and should not be freed. The contents of the array may be
-modified by the caller only if the value is not shared and the caller
-invalidates the string representation.
+\fBTcl_SetByteArrayObj\fR and \fBTcl_SetByteArrayLength\fR do not modify the
+reference count of their \fIobjPtr\fR arguments, but do require that the
+object be unshared.
.PP
-\fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type
-and changes the length of the value's internal representation as an
-array of bytes. If \fIlength\fR is greater than the space currently
-allocated for the array, the array is reallocated to the new length; the
-newly allocated bytes at the end of the array have arbitrary values. If
-\fIlength\fR is less than the space currently allocated for the array,
-the length of array is reduced to the new length. The return value is a
-pointer to the value's new array of bytes.
+\fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR do not modify
+the reference count of \fIobjPtr\fR; they only read.
.SH "SEE ALSO"
Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount
.SH KEYWORDS
-value, binary data, byte array, utf, unicode, internationalization
+value, binary data, byte array, utf, unicode
diff --git a/doc/Cancel.3 b/doc/Cancel.3
index ff2a9b4..027fb09 100644
--- a/doc/Cancel.3
+++ b/doc/Cancel.3
@@ -67,6 +67,14 @@ other procedures. If an error is returned and this bit is set in
result, where it can be retrieved with \fBTcl_GetObjResult\fR or
\fBTcl_GetStringResult\fR. If this flag bit is not set then no error
message is left and the interpreter's result will not be modified.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_CancelEval\fR always decrements the reference count of its
+\fIresultObjPtr\fR argument (if that is non-NULL). It is expected to
+be usually called with an object with zero reference count. If the
+object is shared with some other location (including the Tcl
+evaluation stack) it should have its reference count incremented
+before calling this function.
.SH "SEE ALSO"
interp(n), Tcl_Eval(3),
TIP 285
diff --git a/doc/Class.3 b/doc/Class.3
index 57203d5..c89c5f4 100644
--- a/doc/Class.3
+++ b/doc/Class.3
@@ -55,6 +55,14 @@ Tcl_ObjectMapMethodNameProc
\fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR)
.sp
\fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR)
+.sp
+.VS "TIP 605"
+Tcl_Class
+\fBTcl_GetClassOfObject\fR(\fIobject\fR)
+.sp
+Tcl_Obj *
+\fBTcl_GetObjectClassName\fR(\fIinterp\fR, \fIobject\fR)
+.VE "TIP 605"
.SH ARGUMENTS
.AS ClientData metadata in/out
.AP Tcl_Interp *interp in/out
@@ -114,6 +122,13 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR
is a shared reference. You can also get whether the object has been marked for
deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the
object has begun); this can be useful during the processing of methods.
+.VS "TIP 605"
+The class of an object can be retrieved with \fBTcl_GetClassOfObject\fR, and
+the name of the class of an object with \fBTcl_GetObjectClassName\fR; note
+that these two \fImay\fR return NULL during deletion of an object (this is
+transient, and only occurs when the object is a long way through being
+deleted).
+.VE "TIP 605"
.PP
Instances of classes are created using \fBTcl_NewObjectInstance\fR, which
creates an object from any class (and which is internally called by both
@@ -241,6 +256,29 @@ NULL if the whole chain is to be processed (the argument itself is never
NULL); this variable may be updated by the callback. The \fImethodNameObj\fR
parameter gives an unshared object containing the name of the method being
invoked, as provided by the user; this object may be updated by the callback.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIobjPtr\fR argument to \fBTcl_GetObjectFromObj\fR will not have its
+reference count manipulated, but this function may modify the interpreter
+result (to report any error) so interpreter results should not be fed into
+this without an additional reference being used.
+.PP
+The result of \fBTcl_GetObjectName\fR is a value that is owned by the object
+that is regenerated when this function is first called after the object is
+renamed. If the value is to be retained at all, the caller should increment
+the reference count.
+.PP
+The first \fIobjc\fR values in the \fIobjv\fR argument to
+\fBTcl_NewObjectInstance\fR are the arguments to pass to the constructor. They
+must have a reference count of at least 1, and may have their reference counts
+changed during the running of the constructor. Constructors may modify the
+interpreter result, which consequently means that interpreter results should
+not be used as arguments without an additional reference being taken.
+.PP
+The \fImethodNameObj\fR argument to a Tcl_ObjectMapMethodNameProc
+implementation will be a value with a reference count of at least 1 where at
+least one reference is not held by the interpreter result. It is expected that
+method name mappers will only read their \fImethodNameObj\fR arguments.
.SH "SEE ALSO"
Method(3), oo::class(n), oo::copy(n), oo::define(n), oo::object(n)
.SH KEYWORDS
diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3
index a642d08..77a3bc2 100644
--- a/doc/CrtAlias.3
+++ b/doc/CrtAlias.3
@@ -19,30 +19,24 @@ int
int
\fBTcl_MakeSafe\fR(\fIinterp\fR)
.sp
-.VS "TIP 581"
Tcl_Interp *
\fBTcl_CreateChild\fR(\fIinterp, name, isSafe\fR)
-.VE "TIP 581"
.sp
Tcl_Interp *
\fBTcl_CreateSlave\fR(\fIinterp, name, isSafe\fR)
.sp
-.VS "TIP 581"
-Tcl_Interp *
-\fBTcl_GetChild\fR(\fIinterp, name\fR)
-.VE "TIP 581"
-.sp
Tcl_Interp *
\fBTcl_GetSlave\fR(\fIinterp, name\fR)
.sp
-.VS "TIP 581"
Tcl_Interp *
-\fBTcl_GetParent\fR(\fIinterp\fR)
-.VE "TIP 581"
+\fBTcl_GetChild\fR(\fIinterp, name\fR)
.sp
Tcl_Interp *
\fBTcl_GetMaster\fR(\fIinterp\fR)
.sp
+Tcl_Interp *
+\fBTcl_GetParent\fR(\fIinterp\fR)
+.sp
int
\fBTcl_GetInterpPath\fR(\fIinterp, childInterp\fR)
.sp
@@ -136,8 +130,8 @@ interpreter. The return value for those procedures that return an \fBint\fR
is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned
then the interpreter's result contains an error message.
.PP
-\fBTcl_CreateSlave\fR creates a new interpreter as a child of \fIinterp\fR.
-It also creates a child command named \fIchildName\fR in \fIinterp\fR which
+\fBTcl_CreateChild\fR creates a new interpreter as a child of \fIinterp\fR.
+It also creates a child command named \fIname\fR in \fIinterp\fR which
allows \fIinterp\fR to manipulate the new child.
If \fIisSafe\fR is zero, the command creates a trusted child in which Tcl
code has access to all the Tcl commands.
@@ -148,9 +142,7 @@ child in which Tcl code has access only to set of Tcl commands defined as
see the manual entry for the Tcl \fBinterp\fR command for details.
If the creation of the new child interpreter failed, \fBNULL\fR is returned.
.PP
-.VS "TIP 581"
-\fBTcl_CreateChild\fR is a synonym for \fBTcl_CreateSlave\fR.
-.VE "TIP 581"
+\fBTcl_CreateSlave\fR is a synonym for \fBTcl_CreateChild\fR.
.PP
\fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is
.QW safe
@@ -166,24 +158,21 @@ from \fIinterp\fR. However, it cannot know what parts of an extension
or application are safe and does not make any attempt to remove those
parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR.
Callers will want to take care with their use of \fBTcl_MakeSafe\fR
-to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR
+to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR
may be a better choice, since it creates interpreters in a known-safe state.
+\fBTcl_MakeSafe\fR is deprecated and will be removed in Tcl 9.0.
.PP
-\fBTcl_GetSlave\fR returns a pointer to a child interpreter of
-\fIinterp\fR. The child interpreter is identified by \fIchildName\fR.
+\fBTcl_GetChild\fR returns a pointer to a child interpreter of
+\fIinterp\fR. The child interpreter is identified by \fIname\fR.
If no such child interpreter exists, \fBNULL\fR is returned.
.PP
-.VS "TIP 581"
-\fBTcl_GetChild\fR is a synonym for \fBTcl_GetSlave\fR.
-.VE "TIP 581"
+\fBTcl_GetSlave\fR is a synonym for \fBTcl_GetChild\fR.
.PP
-\fBTcl_GetMaster\fR returns a pointer to the master interpreter of
-\fIinterp\fR. If \fIinterp\fR has no master (it is a
+\fBTcl_GetParent\fR returns a pointer to the parent interpreter of
+\fIinterp\fR. If \fIinterp\fR has no parent (it is a
top-level interpreter) then \fBNULL\fR is returned.
.PP
-.VS "TIP 581"
-\fBTcl_GetParent\fR is a synonym for \fBTcl_GetMaster\fR.
-.VE "TIP 581"
+\fBTcl_GetMaster\fR is a synonym for \fBTcl_GetParent\fR.
.PP
\fBTcl_GetInterpPath\fR stores in the result of \fIinterp\fR
the relative path between \fIinterp\fR and \fIchildInterp\fR;
@@ -201,7 +190,7 @@ This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if
it fails; in that case, an error message is left in the value result
of \fIchildInterp\fR.
Note that there are no restrictions on the ancestry relationship (as
-created by \fBTcl_CreateSlave\fR) between \fIchildInterp\fR and
+created by \fBTcl_CreateChild\fR) between \fIchildInterp\fR and
\fItargetInterp\fR. Any two interpreters can be used, without any
restrictions on how they are related.
.PP
@@ -255,8 +244,16 @@ any script evaluation mechanism will fail.
.PP
For a description of the Tcl interface to multiple interpreters, see
\fIinterp(n)\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_CreateAliasObj\fR increments the reference counts of the values
+in its \fIobjv\fR argument. (That reference lasts the same length of
+time as the owning alias.)
+.PP
+\fBTcl_GetAliasObj\fR returns (via its \fIobjvPtr\fR argument) a
+pointer to values that it holds a reference to.
.SH "SEE ALSO"
-interp
+interp(n)
.SH KEYWORDS
alias, command, exposed commands, hidden commands, interpreter, invoke,
diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3
index 0092cfb..1496631 100644
--- a/doc/CrtChannel.3
+++ b/doc/CrtChannel.3
@@ -35,6 +35,11 @@ Tcl_ThreadId
int
\fBTcl_GetChannelMode\fR(\fIchannel\fR)
.sp
+.VS 8.7
+int
+\fBTcl_RemoveChannelMode\fR(\fIinterp, channel, mode\fR)
+.VE 8.7
+.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
@@ -243,6 +248,16 @@ events to the correct event queue even for a multi-threaded core.
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
+.VS 8.7
+.PP
+\fBTcl_RemoveChannelMode\fR removes an access privilege from the
+channel, either \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR, and returns
+a regular Tcl result code, \fBTCL_OK\fR, or \fBTCL_ERROR\fR. The
+function throws an error if either an invalid mode is specified or the
+result of the removal would be an inaccessible channel. In that case
+an error message is left in the interp argument, if not NULL.
+.VE 8.7
+.PP
\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
allocated to store input or output in \fIchannel\fR. If the value was not set
by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then
@@ -600,9 +615,9 @@ in preference to the \fIseekProc\fR, but both must be defined if the
following prototype:
.PP
.CS
-typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR(
+typedef long long \fBTcl_DriverWideSeekProc\fR(
ClientData \fIinstanceData\fR,
- Tcl_WideInt \fIoffset\fR,
+ long long \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
@@ -824,7 +839,7 @@ length. It can be NULL.
.CS
typedef int \fBTcl_DriverTruncateProc\fR(
ClientData \fIinstanceData\fR,
- Tcl_WideInt \fIlength\fR);
+ long long \fIlength\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3
index 1d49158..aacb868 100644
--- a/doc/CrtInterp.3
+++ b/doc/CrtInterp.3
@@ -22,10 +22,8 @@ Tcl_Interp *
int
\fBTcl_InterpDeleted\fR(\fIinterp\fR)
.sp
-.VS 8.6
int
\fBTcl_InterpActive\fR(\fIinterp\fR)
-.VE 8.6
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
@@ -70,14 +68,12 @@ deleted and when the whole interpreter is being deleted. In the former case
the callback may recreate the data being deleted, but this would lead to an
infinite loop if the interpreter were being deleted.
.PP
-.VS 8.6
\fBTcl_InterpActive\fR is useful for determining whether there is any
execution of scripts ongoing in an interpreter, which is a useful piece of
information when Tcl is embedded in a garbage-collected environment and it
becomes necessary to determine whether the interpreter is a candidate for
deletion. The function returns a true value if the interpreter has at least
one active execution running inside it, and a false value otherwise.
-.VE 8.6
.SH "INTERPRETERS AND MEMORY MANAGEMENT"
.PP
\fBTcl_DeleteInterp\fR can be called at any time on an interpreter that may
@@ -138,12 +134,10 @@ All uses of interpreters in Tcl and Tk have already been protected.
Extension writers should ensure that their code also properly protects any
additional interpreters used, as described above.
.PP
-.VS 8.6
Note that the protection mechanisms do not work well with conventional garbage
collection systems. When in such a managed environment, \fBTcl_InterpActive\fR
should be used to determine when an interpreter is a candidate for deletion
due to inactivity.
-.VE 8.6
.SH "SEE ALSO"
Tcl_Preserve(3), Tcl_Release(3)
.SH KEYWORDS
diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3
index acceb5b..bb96fc9 100644
--- a/doc/CrtMathFnc.3
+++ b/doc/CrtMathFnc.3
@@ -156,6 +156,10 @@ pointed to by \fIargTypesPointer\fR.
\fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all
the math functions defined in the interpreter whose name matches
\fIpattern\fR. The returned value has a reference count of zero.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_ListMathFuncs\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
.SH "SEE ALSO"
expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3)
.SH KEYWORDS
diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3
index 6025c68..bb63937 100644
--- a/doc/CrtObjCmd.3
+++ b/doc/CrtObjCmd.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
+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
@@ -16,6 +16,9 @@ Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetComm
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
@@ -42,6 +45,7 @@ void
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
+.sp
.SH ARGUMENTS
.AS Tcl_CmdDeleteProc *deleteProc in/out
.AP Tcl_Interp *interp in
@@ -51,6 +55,9 @@ 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 ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in
@@ -65,6 +72,9 @@ Pointer to structure containing various information about a
Tcl command.
.AP Tcl_Obj *objPtr in
Value containing the name of a Tcl command.
+.AP "const char" *typeName in
+Indicates the name of the type of command implementation associated
+with a particular \fIproc\fR, or NULL to break the association.
.BE
.SH DESCRIPTION
.PP
@@ -170,6 +180,17 @@ typedef void \fBTcl_CmdDeleteProc\fR(
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(
+ ClientData \fIclientData\fR,
+ Tcl_Interp *\fIinterp\fR,
+ Tcl_Size \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.
@@ -296,6 +317,22 @@ is appended to the value specified by \fIobjPtr\fR.
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.
+Also, when the \fIproc\fR is called, the interpreter result is
+guaranteed to be an empty string value with a reference count of 1.
+.PP
+\fBTcl_GetCommandFullName\fR does not modify the reference count of its
+\fIobjPtr\fR argument, but does require that the object be unshared.
+.PP
+\fBTcl_GetCommandFromObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument; it only reads.
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3)
.SH KEYWORDS
diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3
index f1f1d30..519f348 100644
--- a/doc/CrtTrace.3
+++ b/doc/CrtTrace.3
@@ -10,7 +10,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
+Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_CreateObjTrace2, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -21,6 +21,9 @@ Tcl_Trace
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
@@ -38,11 +41,14 @@ 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 ClientData clientData in
-Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR.
+.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
@@ -66,7 +72,7 @@ interpreter.
.PP
.CS
typedef int \fBTcl_CmdObjTraceProc\fR(
- \fBClientData\fR \fIclientData\fR,
+ \fBvoid *\fR \fIclientData\fR,
\fBTcl_Interp\fR* \fIinterp\fR,
int \fIlevel\fR,
const char *\fIcommand\fR,
@@ -75,6 +81,20 @@ typedef int \fBTcl_CmdObjTraceProc\fR(
\fBTcl_Obj\fR *const \fIobjv\fR[]);
.CE
.PP
+\fIobjProc2\fR should have arguments and result that match the type,
+\fBTcl_CmdObjTraceProc2\fR:
+.PP
+.CS
+typedef int \fBTcl_CmdObjTraceProc2\fR(
+ \fBvoid *\fR \fIclientData\fR,
+ \fBTcl_Interp\fR* \fIinterp\fR,
+ Tcl_Size \fIlevel\fR,
+ const char *\fIcommand\fR,
+ \fBTcl_Command\fR \fIcommandToken\fR,
+ Tcl_Size \fIobjc\fR,
+ \fBTcl_Obj\fR *const \fIobjv\fR[]);
+.CE
+.PP
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIClientData\fR typically points to an application-specific data
@@ -140,7 +160,7 @@ When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
.PP
.CS
typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
- \fBClientData\fR \fIclientData\fR);
+ \fBvoid *\fR \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter will be the same as the
@@ -156,12 +176,12 @@ match the type \fBTcl_CmdTraceProc\fR:
.PP
.CS
typedef void \fBTcl_CmdTraceProc\fR(
- ClientData \fIclientData\fR,
+ void *\fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIlevel\fR,
char *\fIcommand\fR,
Tcl_CmdProc *\fIcmdProc\fR,
- ClientData \fIcmdClientData\fR,
+ void *\fIcmdClientData\fR,
int \fIargc\fR,
const char *\fIargv\fR[]);
.CE
@@ -183,5 +203,14 @@ There is no way to be notified when the trace created by
\fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR
associated with a call to \fBTcl_CreateTrace\fR to abort execution of
\fIcommand\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+When the \fIproc\fR passed to \fBTcl_CreateObjTrace\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.
+.SH "SEE ALSO"
+trace(n)
.SH KEYWORDS
command, create, delete, interpreter, trace
diff --git a/doc/DString.3 b/doc/DString.3
index 00f1b8a..33dd297 100644
--- a/doc/DString.3
+++ b/doc/DString.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
+Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult, Tcl_DStringToObj \- manipulate dynamic strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -41,6 +41,10 @@ char *
\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR)
.sp
\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR)
+.sp
+Tcl_Obj *
+\fBTcl_DStringToObj\fR(\fIdsPtr\fR)
+.sp
.SH ARGUMENTS
.AS Tcl_DString newLength in/out
.AP Tcl_DString *dsPtr in/out
@@ -142,12 +146,25 @@ a pointer from \fIdsPtr\fR to the interpreter's result.
This saves the cost of allocating new memory and copying the string.
\fBTcl_DStringResult\fR also reinitializes the dynamic string to
an empty string.
+Since the dynamic string is reinitialized, there is no need to
+further call \fBTcl_DStringFree\fR on it and it can be reused without
+calling \fBTcl_DStringInit\fR.
.PP
\fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR.
It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and
it clears \fIinterp\fR's result.
If possible it does this by moving a pointer rather than by copying
the string.
+.PP
+\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of
+the dynamic string given by \fIdsPtr\fR. It does this by moving
+a pointer from \fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR
+and reinitializing to dynamic string to an empty string.
+This saves the cost of allocating new memory and copying the string.
+Since the dynamic string is reinitialized, there is no need to
+further call \fBTcl_DStringFree\fR on it and it can be reused without
+calling \fBTcl_DStringInit\fR.
+The returned \fBTcl_Obj\fR has a reference count of 0.
.SH KEYWORDS
append, dynamic string, free, result
diff --git a/doc/DictObj.3 b/doc/DictObj.3
index 2c111c4..0b4c1ca 100644
--- a/doc/DictObj.3
+++ b/doc/DictObj.3
@@ -190,6 +190,73 @@ path as this is easy to construct from repeated use of
dictionaries are created for non-terminal keys where they do not
already exist. With \fBTcl_DictObjRemoveKeyList\fR, all non-terminal
keys must exist and have dictionaries as their values.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewDictObj\fR always returns a zero-reference object, much like
+\fBTcl_NewObj\fR.
+.PP
+\fBTcl_DictObjPut\fR does not modify the reference count of its \fIdictPtr\fR
+argument, but does require that the object be unshared. If
+\fBTcl_DictObjPut\fR returns \fBTCL_ERROR\fR it does not manipulate any
+reference counts; but if it returns \fBTCL_OK\fR then it definitely increments
+the reference count of \fIvaluePtr\fR and may increment the reference count of
+\fIkeyPtr\fR; the latter case happens exactly when the key did not previously
+exist in the dictionary. Note however that this function may set the
+interpreter result; if that is the only place that is holding a reference to
+an object, it will be deleted.
+.PP
+\fBTcl_DictObjGet\fR only reads from its \fIdictPtr\fR and \fIkeyPtr\fR
+arguments, and does not manipulate their reference counts at all. If the
+\fIvaluePtrPtr\fR argument is not set to NULL (and the function doesn't return
+\fBTCL_ERROR\fR), it will be set to a value with a reference count of at least
+1, with a reference owned by the dictionary. Note however that this function
+may set the interpreter result; if that is the only place that is holding a
+reference to an object, it will be deleted.
+.PP
+\fBTcl_DictObjRemove\fR does not modify the reference count of its
+\fIdictPtr\fR argument, but does require that the object be unshared. It does
+not manipulate the reference count of its \fIkeyPtr\fR argument at all. Note
+however that this function may set the interpreter result; if that is the only
+place that is holding a reference to an object, it will be deleted.
+.PP
+\fBTcl_DictObjSize\fR does not modify the reference count of its \fIdictPtr\fR
+argument; it only reads. Note however that this function may set the
+interpreter result; if that is the only place that is holding a reference to
+the dictionary object, it will be deleted.
+.PP
+\fBTcl_DictObjFirst\fR does not modify the reference count of its
+\fIdictPtr\fR argument; it only reads. The variables given by the
+\fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR arguments (if not NULL) will be updated
+to contain references to the relevant values in the dictionary; their
+reference counts will be at least 1 (due to the dictionary holding a reference
+to them). It may also manipulate internal references; these are not exposed to
+user code, but require a matching \fBTcl_DictObjDone\fR call. Note however
+that this function may set the interpreter result; if that is the only place
+that is holding a reference to the dictionary object, it will be deleted.
+.PP
+Similarly for \fBTcl_DictObjNext\fR; the variables given by the
+\fIkeyPtrPtr\fR and \fIvaluePtrPtr\fR arguments (if not NULL) will be updated
+to contain references to the relevant values in the dictionary; their
+reference counts will be at least 1 (due to the dictionary holding a reference
+to them).
+.PP
+\fBTcl_DictObjDone\fR does not manipulate (user-visible) reference counts.
+.PP
+\fBTcl_DictObjPutKeyList\fR is similar to \fBTcl_DictObjPut\fR; it does not
+modify the reference count of its \fIdictPtr\fR argument, but does require
+that the object be unshared. It may increment the reference count of any value
+passed in the \fIkeyv\fR argument, and will increment the reference count of
+the \fIvaluePtr\fR argument on success. It is recommended that values passed
+via \fIkeyv\fR and \fIvaluePtr\fR do not have zero reference counts. Note
+however that this function may set the interpreter result; if that is the only
+place that is holding a reference to an object, it will be deleted.
+.PP
+\fBTcl_DictObjRemoveKeyList\fR is similar to \fBTcl_DictObjRemove\fR; it does
+not modify the reference count of its \fIdictPtr\fR argument, but does require
+that the object be unshared, and does not modify the reference counts of any
+of the values passed in the \fIkeyv\fR argument. Note however that this
+function may set the interpreter result; if that is the only place that is
+holding a reference to an object, it will be deleted.
.SH EXAMPLE
Using the dictionary iteration interface to search determine if there
is a key that maps to itself:
diff --git a/doc/DoubleObj.3 b/doc/DoubleObj.3
index 85e4de5..c70f5d1 100644
--- a/doc/DoubleObj.3
+++ b/doc/DoubleObj.3
@@ -58,6 +58,18 @@ and if \fIinterp\fR is non-NULL, an error message is left in \fIinterp\fR.
The \fBTcl_ObjType\fR of \fIobjPtr\fR may be changed to make subsequent
calls to \fBTcl_GetDoubleFromObj\fR more efficient.
'\" TODO: add discussion of treatment of NaN value
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewDoubleObj\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_SetDoubleObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument, but does require that the object be unshared.
+.PP
+\fBTcl_GetDoubleFromObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument; it only reads. Note however that this function
+may set the interpreter result; if that is the only place that
+is holding a reference to the object, it will be deleted.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
diff --git a/doc/Encoding.3 b/doc/Encoding.3
index 79fca0f..c357ecd 100644
--- a/doc/Encoding.3
+++ b/doc/Encoding.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings
+Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtfDStringEx, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternalDStringEx, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -25,10 +25,16 @@ int
char *
\fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
+int
+\fBTcl_ExternalToUtfDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
+.sp
char *
\fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR)
.sp
int
+\fBTcl_UtfToExternalDStringEx\fR(\fIinterp, encoding, src, srcLen, flags, dstPtr, errorIdxPtr\fR)
+.sp
+int
\fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr,
dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR)
.sp
@@ -46,6 +52,9 @@ const char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
int
+\fBTcl_GetEncodingNulLength\fR(\fIencoding\fR)
+.sp
+int
\fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR)
.sp
const char *
@@ -96,7 +105,7 @@ encoding-specific length of the string is used.
Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted
result will be stored.
.AP int flags in
-Various flag bits OR-ed together.
+This is a bit mask passed in to control the operation of the encoding functions.
\fBTCL_ENCODING_START\fR signifies that the
source buffer is the first block in a (potentially multi-block) input
stream, telling the conversion routine to reset to an initial state and
@@ -104,11 +113,15 @@ perform any initialization that needs to occur before the first byte is
converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last
block in a (potentially multi-block) input stream, telling the conversion
routine to perform any finalization that needs to occur after the last
-byte is converted and then to reset to an initial state.
-\fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should
-return immediately upon reading a source character that does not exist in
-the target encoding; otherwise a default fallback character will
-automatically be substituted.
+byte is converted and then to reset to an initial state. The
+\fBTCL_PROFILE_*\fR bits defined in the \fBPROFILES\fR section below
+control the encoding profile to be used for dealing with invalid data or
+other errors in the encoding transform.
+\fBTCL_ENCODING_STOPONERROR\fR is present for backward compatibility with
+Tcl 8.6 and forces the encoding profile to \fBstrict\fR.
+
+Some flags bits may not be usable with some functions as noted in the
+function descriptions below.
.AP Tcl_EncodingState *statePtr in/out
Used when converting a (generally long or indefinite length) byte stream
in a piece-by-piece fashion. The conversion routine stores its current
@@ -134,6 +147,9 @@ buffer as a result of the conversion. May be NULL.
.AP int *dstCharsPtr out
Filled with the number of characters that correspond to the number of bytes
stored in the output buffer. May be NULL.
+.AP int *errorIdxPtr out
+Filled with the index of the byte or character that caused the encoding transform
+to fail. May be NULL.
.AP Tcl_DString *bufPtr out
Storage for the prescribed system encoding name.
.AP "const Tcl_EncodingType" *typePtr in
@@ -208,6 +224,27 @@ When converting, if any of the characters in the source buffer cannot be
represented in the target encoding, a default fallback character will be
used. The return value is a pointer to the value stored in the DString.
.PP
+\fBTcl_ExternalToUtfDStringEx\fR is a more flexible version of older
+\fBTcl_ExternalToUtfDString\fR function. It takes three additional parameters,
+\fBinterp\fR, \fBflags\fR and \fBerrorIdxPtr\fR. The \fBflags\fR parameter may
+be used to specify the profile to be used for the transform. The
+\fBTCL_ENCODING_START\fR and \fBTCL_ENCODING_END\fR bits in \fBflags\fR are
+ignored as the function assumes the entire source string to be decoded is passed
+into the function. On success, the function returns \fBTCL_OK\fR with the
+converted string stored in \fB*dstPtr\fR. For errors \fIother than conversion
+errors\fR, such as invalid flags, the function returns \fBTCL_ERROR\fR with an error
+message in \fBinterp\fR if it is not NULL.
+For conversion errors, \fBTcl_ExternalToUtfDStringEx\fR returns one
+of the \fBTCL_CONVERT_*\fR errors listed below for \fBTcl_ExternalToUtf\fR.
+When one of these conversion errors is returned, an error message is
+stored in \fBinterp\fR only if \fBerrorIdxPtr\fR is NULL. Otherwise, no error message
+is stored as the function expects the caller is interested the decoded data
+up to that point and not treating this as an immediate error condition.
+The index of the error location is stored in \fB*errorIdxPtr\fR.
+.PP
+The caller must call \fBTcl_DStringFree\fR to free up the \fB*dstPtr\fR resources
+irrespective of the return value from the function.
+.PP
\fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified
\fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the
source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR.
@@ -229,12 +266,12 @@ the unconverted bytes that remained in \fIsrc\fR plus some further bytes
from the source stream to properly convert the formerly split-up multibyte
sequence.
.IP \fBTCL_CONVERT_SYNTAX\fR 29
-The source buffer contained an invalid character sequence. This may occur
+The source buffer contained an invalid byte or character sequence. This may occur
if the input stream has been damaged or if the input encoding method was
misidentified.
.IP \fBTCL_CONVERT_UNKNOWN\fR 29
The source buffer contained a character that could not be represented in
-the target encoding and \fBTCL_ENCODING_STOPONERROR\fR was specified.
+the target encoding.
.RE
.LP
\fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8
@@ -246,6 +283,15 @@ characters in the source buffer cannot be represented in the target
encoding, a default fallback character will be used. The return value is
a pointer to the value stored in the DString.
.PP
+\fBTcl_UtfToExternalDStringEx\fR is an enhanced version of
+\fBTcl_UtfToExternalDString\fR that transforms UTF-8 encoded source data to a specified
+\fIencoding\fR. Except for the direction of the transform, the parameters and
+return values are identical to those of \fBTcl_ExternalToUtfDStringEx\fR. See
+that function above for details about the same.
+
+Irrespective of the return code from the function, the caller must free
+resources associated with \fB*dstPtr\fR when the function returns.
+.PP
\fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into
the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from
the source buffer and up to \fIdstLen\fR converted bytes are stored in
@@ -255,11 +301,17 @@ is filled with the corresponding number of bytes that were stored in
\fIdst\fR. The return values are the same as the return values for
\fBTcl_ExternalToUtf\fR.
.PP
-\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are
-Windows-only convenience
-functions for converting between UTF-8 and Windows strings
-based on the TCHAR type which is by convention
-a Unicode character on Windows NT.
+\fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are Windows-only
+convenience functions for converting between UTF-8 and Windows strings
+based on the TCHAR type which is by convention a Unicode character on
+Windows NT. Those functions are deprecated. You can use
+\fBTcl_UtfToWCharDString\fR resp. \fBTcl_WCharToUtfDString\fR as replacement.
+If you want compatibility with earlier Tcl releases than 8.7, use
+\fBTcl_UtfToUniCharDString\fR resp. \fBTcl_UniCharToUtfDString\fR as
+replacement, and make sure you compile your extension with -DTCL_UTF_MAX=3.
+Beware: Those replacement functions don't initialize their Tcl_DString (you'll
+have to do that yourself), and \fBTcl_UniCharToUtfDString\fR from Tcl 8.6
+doesn't accept -1 as length parameter.
.PP
\fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR.
Given an \fIencoding\fR, the return value is the \fIname\fR argument that
@@ -267,6 +319,9 @@ was used to create the encoding. The string returned by
\fBTcl_GetEncodingName\fR is only guaranteed to persist until the
\fIencoding\fR is deleted. The caller must not modify this string.
.PP
+\fBTcl_GetEncodingNulLength\fR returns the length of the terminating
+nul byte sequence for strings in the specified encoding.
+.PP
\fBTcl_SetSystemEncoding\fR sets the default encoding that should be used
whenever the user passes a NULL value for the \fIencoding\fR argument to
any of the other encoding functions. If \fIname\fR is NULL, the system
@@ -314,7 +369,7 @@ typedef struct Tcl_EncodingType {
Tcl_EncodingConvertProc *\fItoUtfProc\fR;
Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
Tcl_EncodingFreeProc *\fIfreeProc\fR;
- ClientData \fIclientData\fR;
+ void *\fIclientData\fR;
int \fInullSize\fR;
} \fBTcl_EncodingType\fR;
.CE
@@ -345,7 +400,7 @@ type \fBTcl_EncodingConvertProc\fR:
.PP
.CS
typedef int \fBTcl_EncodingConvertProc\fR(
- ClientData \fIclientData\fR,
+ void *\fIclientData\fR,
const char *\fIsrc\fR,
int \fIsrcLen\fR,
int \fIflags\fR,
@@ -377,7 +432,7 @@ The callback procedure \fIfreeProc\fR, if non-NULL, should match the type
.PP
.CS
typedef void \fBTcl_EncodingFreeProc\fR(
- ClientData \fIclientData\fR);
+ void *\fIclientData\fR);
.CE
.PP
This \fIfreeProc\fR function is called when the encoding is deleted. The
@@ -524,13 +579,13 @@ encoding:
E
init {}
final {}
-iso8859-1 \ex1b(B
-jis0201 \ex1b(J
-jis0208 \ex1b$@
-jis0208 \ex1b$B
-jis0212 \ex1b$(D
-gb2312 \ex1b$A
-ksc5601 \ex1b$(C
+iso8859-1 \ex1B(B
+jis0201 \ex1B(J
+jis0208 \ex1B$@
+jis0208 \ex1B$B
+jis0212 \ex1B$(D
+gb2312 \ex1B$A
+ksc5601 \ex1B$(C
.CE
.PP
In the file, the first column represents an option and the second column
@@ -542,7 +597,7 @@ marks that encoding. Tcl syntax is used for the values; in the above
example, for instance,
.QW \fB{}\fR
represents the empty string and
-.QW \fB\ex1b\fR
+.QW \fB\ex1B\fR
represents character 27.
.PP
When \fBTcl_GetEncoding\fR encounters an encoding \fIname\fR that has not
@@ -550,5 +605,28 @@ been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR
from the \fBencoding\fR subdirectory of each directory that Tcl searches
for its script library. If the encoding file exists, but is
malformed, an error message will be left in \fIinterp\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_GetEncodingFromObj\fR does not modify the reference count of its
+\fIobjPtr\fR argument; it only reads. Note however that this function may set
+the interpreter result; if that is the only place that is holding a reference
+to the object, it will be deleted.
+.PP
+\fBTcl_GetEncodingSearchPath\fR returns an object with a reference count of at
+least 1.
+.SH "PROFILES"
+Encoding profiles define the manner in which errors in the encoding transforms
+are handled by the encoding functions. An application can specify the profile
+to be used by OR-ing the \fBflags\fR parameter passed to the function
+with at most one of \fBTCL_ENCODING_PROFILE_TCL8\fR,
+\fBTCL_ENCODING_PROFILE_STRICT\fR or \fBTCL_ENCODING_PROFILE_REPLACE\fR.
+These correspond to the \fBtcl8\fR, \fBstrict\fR and \fBreplace\fR profiles
+respectively. If none are specified, a version-dependent default profile is used.
+For Tcl 8.7, the default profile is \fBtcl8\fR.
+.PP
+For details about profiles, see the \fBPROFILES\fR section in
+the documentation of the \fBencoding\fR command.
+.SH "SEE ALSO"
+encoding(n)
.SH KEYWORDS
utf, encoding, convert
diff --git a/doc/Ensemble.3 b/doc/Ensemble.3
index 93aa458..71a53ac 100644
--- a/doc/Ensemble.3
+++ b/doc/Ensemble.3
@@ -36,13 +36,11 @@ int
int
\fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR)
.sp
-.VS 8.6
int
\fBTcl_GetEnsembleParameterList\fR(\fIinterp, token, listObjPtr\fR)
.sp
int
\fBTcl_SetEnsembleParameterList\fR(\fIinterp, token, listObj\fR)
-.VE 8.6
.sp
int
\fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR)
@@ -163,7 +161,6 @@ All command names in prefixes set via \fBTcl_SetEnsembleMappingDict\fR
must be fully qualified.
.TP
\fBformal pre-subcommand parameter list\fR (read-write)
-.VS 8.6
A list of formal parameter names (the names only being used when generating
error messages) that come at invocation of the ensemble between the name of
the ensemble and the subcommand argument. NULL (the default) is equivalent to
@@ -174,7 +171,6 @@ respectively. The result of both of those functions is a Tcl result code
ensemble) and the
dictionary obtained from \fBTcl_GetEnsembleParameterList\fR should always be
treated as immutable even if it is unshared.
-.VE 8.6
.TP
\fBsubcommand list\fR (read-write)
.
@@ -213,6 +209,27 @@ namespace whose list of exported commands is used if both the mapping
dictionary and the subcommand list properties are NULL. May be read
using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code
(\fBTCL_OK\fR, or \fBTCL_ERROR\fR if the token does not refer to an ensemble).
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_FindEnsemble\fR does not modify the reference count of its
+\fIcmdNameObj\fR argument; it only reads. Note however that this function may
+set the interpreter result; if that is the only place that is holding a
+reference to the object, it will be deleted.
+.PP
+The ensemble property getters (\fBTcl_GetEnsembleMappingDict\fR,
+\fBTcl_GetEnsembleParameterList\fR, \fBTcl_GetEnsembleSubcommandList\fR, and
+\fBTcl_GetEnsembleUnknownHandler\fR) do not manipulate the reference count of
+the values they provide out; if those are non-NULL, they will have a reference
+count of at least 1. Note that these functions may set the interpreter
+result.
+.PP
+The ensemble property setters (\fBTcl_SetEnsembleMappingDict\fR,
+\fBTcl_SetEnsembleParameterList\fR, \fBTcl_SetEnsembleSubcommandList\fR, and
+\fBTcl_SetEnsembleUnknownHandler\fR) will increment the reference count of the
+new value of the property they are given if they succeed (and decrement the
+reference count of the old value of the property, if relevant). If the
+property setters return \fBTCL_ERROR\fR, the reference count of the Tcl_Obj
+argument is left unchanged.
.SH "SEE ALSO"
namespace(n), Tcl_DeleteCommandFromToken(3)
.SH KEYWORDS
diff --git a/doc/Eval.3 b/doc/Eval.3
index f5cd87f..95bd883 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -99,13 +99,11 @@ its contents as a Tcl script. It returns the same information as
If the file could not be read then a Tcl error is returned to describe
why the file could not be read.
The eofchar for files is
-.QW \e32
+.QW \ex1A
(^Z) for all platforms. If you require a
.QW ^Z
in code for string comparison, you can use
-.QW \e032
-or
-.QW \eu001a ,
+.QW \ex1A ,
which will be safely substituted by the Tcl interpreter into
.QW ^Z .
.PP
@@ -150,13 +148,14 @@ equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below).
of any length, concatenates them into a single string,
then calls \fBTcl_Eval\fR to execute that string as a Tcl command.
It returns the result of the command and also modifies
-\fIinterp->result\fR in the same way as \fBTcl_Eval\fR.
+the interpreter result in the same way as \fBTcl_Eval\fR.
The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end
of arguments.
.PP
\fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that
instead of taking a variable number of arguments it takes an argument
-list. \fBTcl_VarEvalVA\fR is now deprecated.
+list. Interfaces using argument lists have been found to be nonportable
+in practice. This function is deprecated and will be removed in Tcl 9.0.
.SH "FLAG BITS"
.PP
@@ -206,6 +205,20 @@ the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was
invoked in an inappropriate place.
This means that top-level applications should never see a return code
from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_EvalObjEx\fR and \fBTcl_GlobalEvalObj\fR both increment and
+decrement the reference count of their \fIobjPtr\fR argument; you must
+not pass them any value with a reference count of zero. They also
+manipulate the interpreter result; you must not count on the
+interpreter result to hold the reference count of any value over
+these calls.
+.PP
+\fBTcl_EvalObjv\fR may increment and decrement the reference count of
+any value passed via its \fIobjv\fR argument; you must not pass any
+value with a reference count of zero. This function also manipulates
+the interpreter result; you must not count on the interpreter result
+to hold the reference count of any value over this call.
.SH KEYWORDS
execute, file, global, result, script, value
diff --git a/doc/Exit.3 b/doc/Exit.3
index 9a04db3..a52b2e1 100644
--- a/doc/Exit.3
+++ b/doc/Exit.3
@@ -134,6 +134,9 @@ finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an
appropriate time. The argument passed to \fIproc\fR when it is
invoked will be the exit status code (as passed to \fBTcl_Exit\fR)
cast to a ClientData value.
+.PP
+\fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH "SEE ALSO"
exit(n)
.SH KEYWORDS
diff --git a/doc/ExprLongObj.3 b/doc/ExprLongObj.3
index 837e0a8..59413e1 100644
--- a/doc/ExprLongObj.3
+++ b/doc/ExprLongObj.3
@@ -98,6 +98,15 @@ containing the expression's value at \fI*resultPtrPtr\fR.
In this case, the caller is responsible for calling
\fBTcl_DecrRefCount\fR to decrement the value's reference count
when it is finished with the value.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR,
+\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR all increment and
+decrement the reference count of their \fIobjPtr\fR arguments; you
+must not pass them any value with a reference count of zero. They also
+manipulate the interpreter result; you must not count on the
+interpreter result to hold the reference count of any value over these
+calls.
.SH "SEE ALSO"
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString, Tcl_GetObjResult
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 7ac93c8..cc19ea8 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -45,7 +45,7 @@ int
\fBTcl_FSDeleteFile\fR(\fIpathPtr\fR)
.sp
int
-\fBTcl_FSRemoveDirectory\fR(\fIpathPtr, int recursive, errorPtr\fR)
+\fBTcl_FSRemoveDirectory\fR(\fIpathPtr, recursive, errorPtr\fR)
.sp
int
\fBTcl_FSRenameFile\fR(\fIsrcPathPtr, destPathPtr\fR)
@@ -63,10 +63,8 @@ int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
loadHandlePtr, unloadProcPtr\fR)
.sp
-.VS 8.6
int
\fBTcl_FSUnloadFile\fR(\fIinterp, loadHandle\fR)
-.VE 8.6
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, resultPtr, pathPtr, pattern, types\fR)
@@ -81,10 +79,10 @@ int
\fBTcl_FSUtime\fR(\fIpathPtr, tval\fR)
.sp
int
-\fBTcl_FSFileAttrsGet\fR(\fIinterp, int index, pathPtr, objPtrRef\fR)
+\fBTcl_FSFileAttrsGet\fR(\fIinterp, index, pathPtr, objPtrRef\fR)
.sp
int
-\fBTcl_FSFileAttrsSet\fR(\fIinterp, int index, pathPtr, Tcl_Obj *objPtr\fR)
+\fBTcl_FSFileAttrsSet\fR(\fIinterp, index, pathPtr, objPtr\fR)
.sp
const char *const *
\fBTcl_FSFileAttrStrings\fR(\fIpathPtr, objPtrRef\fR)
@@ -146,17 +144,16 @@ Tcl_Obj *
Tcl_StatBuf *
\fBTcl_AllocStatBuf\fR()
.sp
-.VS 8.6
-Tcl_WideInt
+long long
\fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR)
.sp
unsigned
\fBTcl_GetBlockSizeFromStat\fR(\fIstatPtr\fR)
.sp
-Tcl_WideUInt
+unsigned long long
\fBTcl_GetBlocksFromStat\fR(\fIstatPtr\fR)
.sp
-Tcl_WideInt
+long long
\fBTcl_GetChangeTimeFromStat\fR(\fIstatPtr\fR)
.sp
int
@@ -177,15 +174,14 @@ int
unsigned
\fBTcl_GetModeFromStat\fR(\fIstatPtr\fR)
.sp
-Tcl_WideInt
+long long
\fBTcl_GetModificationTimeFromStat\fR(\fIstatPtr\fR)
.sp
-Tcl_WideUInt
+unsigned long long
\fBTcl_GetSizeFromStat\fR(\fIstatPtr\fR)
.sp
int
\fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR)
-.VE 8.6
.SH ARGUMENTS
.AS Tcl_GlobTypeData **srcPathPtr out
.AP "const Tcl_Filesystem" *fsPtr in
@@ -201,6 +197,8 @@ rename operation.
.AP Tcl_Obj *destPathPtr in
As for \fIpathPtr\fR, but used for the destination filename for a copy or
rename operation.
+.AP int recursive in
+Whether to remove subdirectories and their contents as well.
.AP "const char" *encodingName in
The encoding of the data stored in the
file identified by \fIpathPtr\fR and to be evaluated.
@@ -228,6 +226,10 @@ be joined together. If negative, 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.
.AP Tcl_Obj **objPtrRef out
Filled with a value containing the result of the operation.
.AP Tcl_Obj *resultPtr out
@@ -245,9 +247,9 @@ The structure that contains the result of a stat or lstat operation.
Name of a procedure to look up in the file's symbol table
.AP "const char" *sym2 in
Name of a procedure to look up in the file's symbol table
-.AP Tcl_PackageInitProc **proc1Ptr out
+.AP Tcl_LibraryInitProc **proc1Ptr out
Filled with the init function for this code.
-.AP Tcl_PackageInitProc **proc2Ptr out
+.AP Tcl_LibraryInitProc **proc2Ptr out
Filled with the safe-init function for this code.
.AP ClientData *clientDataPtr out
Filled with the clientData value to pass to this code's unload
@@ -418,23 +420,21 @@ caller (with a reference count of 0).
the encoding identified by \fIencodingName\fR and evaluates
its contents as a Tcl script. It returns the same information as
\fBTcl_EvalObjEx\fR.
-If \fIencodingName\fR is NULL, the system encoding is used for
+If \fIencodingName\fR is NULL, the utf-8 encoding is used for
reading the file contents.
If the file could not be read then a Tcl error is returned to describe
why the file could not be read.
The eofchar for files is
-.QW \e32
+.QW \ex1A
(^Z) for all platforms.
If you require a
.QW ^Z
in code for string comparison, you can use
-.QW \e032
-or
-.QW \eu001a ,
+.QW \ex1A ,
which will be safely substituted by the Tcl interpreter into
.QW ^Z .
\fBTcl_FSEvalFile\fR is a simpler version of
-\fBTcl_FSEvalFileEx\fR that always uses the system encoding
+\fBTcl_FSEvalFileEx\fR that always uses the utf-8 encoding
when reading the file.
.PP
\fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and
@@ -444,20 +444,16 @@ belongs will be called. If that filesystem does not implement this
function (most virtual filesystems will not, because of OS limitations
in dynamically loading binary code), Tcl will attempt to copy the file
to a temporary directory and load that temporary file.
-.VS 8.6
\fBTcl_FSUnloadFile\fR reverses the operation, asking for the library
indicated by the \fIloadHandle\fR to be removed from the process. Note that,
unlike with the \fBunload\fR command, this does not give the library any
opportunity to clean up.
-.VE 8.6
.PP
Both the above functions return a standard Tcl completion code. If an error
occurs, an error message is left in the \fIinterp\fR's result.
.PP
-.VS 8.6
The token provided via the variable indicated by \fIloadHandlePtr\fR may be
used with \fBTcl_FindSymbol\fR.
-.VE 8.6
.PP
\fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a
directory for all files which match a given pattern. The appropriate
@@ -653,7 +649,7 @@ filesystem object.
It returns 1 if the paths are equal, and 0 if they are different. If
either path is NULL, 0 is always returned.
.PP
-\fBTcl_FSGetNormalizedPath\fR this important function attempts to extract
+\fBTcl_FSGetNormalizedPath\fR attempts to extract
from the given Tcl_Obj a unique normalized path representation, whose
string value can be used as a unique identifier for the file.
.PP
@@ -795,7 +791,6 @@ may be deallocated by being passed to \fBckfree\fR). This allows extensions to
invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the
size of the buffer. That in turn depends on the flags used to build Tcl.
.PP
-.VS 8.6
The portable fields of a \fITcl_StatBuf\fR may be read using the following
functions, each of which returns the value of the corresponding field listed
in the table below. Note that on some platforms there may be other fields in
@@ -819,7 +814,6 @@ for a full description of these fields.
\fBTcl_GetBlocksFromStat\fR st_blocks
\fBTcl_GetBlockSizeFromStat\fR st_blksize
.DE
-.VE 8.6
.SH "THE VIRTUAL FILESYSTEM API"
.PP
A filesystem provides a \fBTcl_Filesystem\fR structure that contains
@@ -1638,6 +1632,158 @@ typedef int \fBTcl_FSChdirProc\fR(
The \fBTcl_FSChdirProc\fR changes the applications current working
directory to the value specified in \fIpathPtr\fR. The function returns
-1 on error or 0 on success.
+.SH "REFERENCE COUNT MANAGEMENT"
+.SS "PUBLIC API CALLS"
+.PP
+For all of these functions, \fIpathPtr\fR (including the \fIsrcPathPtr\fR and
+\fIdestPathPtr\fR arguments to \fBTcl_FSCopyFile\fR,
+\fBTcl_FSCopyDirectory\fR, and \fBTcl_FSRenameFile\fR, the \fIfirstPtr\fR and
+\fIsecondPtr\fR arguments to \fBTcl_FSEqualPaths\fR, and the \fIlinkNamePtr\fR
+and \fItoPtr\fR arguments to \fBTcl_FSLink\fR) must not be a zero reference
+count value; references may be retained in internal caches even for
+theoretically read-only operations. These functions may also manipulate the
+interpreter result (if they take and are given a non-NULL \fIinterp\fR
+argument); you must not count on the interpreter result to hold the reference
+count of any argument value over these calls and should manage your own
+references there. However, references held by the arguments to a Tcl command
+\fIare\fR suitable for reference count management purposes for the duration of
+the implementation of that command.
+.PP
+The \fIerrorPtr\fR argument to \fBTcl_FSCopyDirectory\fR and
+\fBTcl_FSRemoveDirectory\fR is, when an object is set into it at all, set to
+an object with a non-zero reference count that should be passed to
+\fBTcl_DecrRefCount\fR when no longer needed.
+.PP
+\fBTcl_FSListVolumes\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_FSLink\fR always returns a non-zero-reference object when it is
+asked to read; you must call \fBTcl_DecrRefCount\fR on the object
+once you no longer need it.
+.PP
+\fBTcl_FSGetCwd\fR always returns a non-zero-reference object; you
+must call \fBTcl_DecrRefCount\fR on the object once you no longer need
+it.
+.PP
+\fBTcl_FSPathSeparator\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_FSJoinPath\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR. Its \fIlistObj\fR argument can have any reference
+count; it is only read by this function.
+.PP
+\fBTcl_FSSplitPath\fR always returns a zero-reference object, much
+like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_FSGetNormalizedPath\fR returns an object with a non-zero
+reference count where Tcl is the owner. You should increment its
+reference count if you want to retain it, but do not need to if you
+are just using the value immediately.
+.PP
+\fBTcl_FSJoinToPath\fR always returns a zero-reference object, much like
+\fBTcl_NewObj\fR. Its \fIbasePtr\fR argument follows the rules above for
+\fIpathPtr\fR, as do the values in the \fIobjv\fR argument.
+.PP
+\fBTcl_FSGetTranslatedPath\fR returns a non-zero-reference object (or
+NULL in the error case); you must call \fBTcl_DecrRefCount\fR on the
+object once you no longer need it.
+.PP
+\fBTcl_FSNewNativePath\fR always returns a zero-reference object (or
+NULL), much like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_FSFileSystemInfo\fR always returns a zero-reference object (or
+NULL), much like \fBTcl_NewObj\fR.
+.PP
+The \fIobjPtr\fR and \fIobjPtrRef\fR arguments to \fBTcl_FSFileAttrsGet\fR,
+\fBTcl_FSFileAttrsSet\fR and \fBTcl_FSFileAttrStrings\fR are conventional Tcl
+values; the \fIobjPtr\fR argument will be read but not retained, and the
+\fIobjPtrRef\fR argument will have (on success) a zero-reference value written
+into it (as with \fBTcl_NewObj\fR). \fBTcl_FSFileAttrsGet\fR and
+\fBTcl_FSFileAttrsSet\fR may also manipulate the interpreter result.
+.PP
+The \fIresultPtr\fR argument to \fBTcl_FSMatchInDirectory\fR will not have its
+reference count manipulated, but it should have a reference count of no more
+than 1, and should not be the current interpreter result (as the function may
+overwrite that on error).
+.SS "VIRTUAL FILESYSTEM INTERFACE"
+.PP
+For all virtual filesystem implementation functions, any \fIpathPtr\fR
+arguments should not have their reference counts manipulated. If they take an
+\fIinterp\fR argument, they may set an error message in that, but must not
+manipulate the \fIpathPtr\fR afterwards. Aside from that:
+.TP
+\fIinternalToNormalizedProc\fR
+.
+This should return a zero-reference count value, as if allocated with
+\fBTcl_NewObj\fR.
+.TP
+\fInormalizePathProc\fR
+.
+Unlike with other API implementation functions, the \fIpathPtr\fR argument
+here is guaranteed to be an unshared object that should be updated. Its
+reference count should not be modified.
+.TP
+\fIfilesystemPathTypeProc\fR
+.
+The return value (if non-NULL) either has a reference count of zero or needs
+to be maintained (on a per-thread basis) by the filesystem. Tcl will increment
+the reference count of the value if it wishes to retain it.
+.TP
+\fIfilesystemSeparatorProc\fR
+.
+The return value should be a value with reference count of zero.
+.TP
+\fImatchInDirectoryProc\fR
+.
+The \fIresultPtr\fR argument should be assumed to hold a list that can be
+appended to (i.e., that has a reference count no greater than 1). No reference
+to it should be retained.
+.TP
+\fIlinkProc\fR
+.
+If \fItoPtr\fR is NULL, this should return a value with reference count 1 that
+has just been allocated and passed to \fBTcl_IncrRefCount\fR. If \fItoPtr\fR
+is not NULL, it should be returned on success.
+.TP
+\fIlistVolumesProc\fR
+.
+The result value should be a list (if non-NULL); it will have its reference
+count decremented once (with \fBTcl_DecrRefCount\fR) by Tcl once done.
+.TP
+\fIfileAttrStringsProc\fR
+.
+If the result is NULL, the \fIobjPtrRef\fR should have a list value written to
+it; that list will have its reference count both incremented (with
+\fBTcl_IncrRefCount\fR) and decremented (with \fBTcl_DecrRefCount\fR).
+.TP
+\fIfileAttrsGetProc\fR
+.
+The \fIobjPtrRef\fR argument should have (on non-error return) a zero
+reference count value written to it (allocated as if with \fBTcl_NewObj\fR).
+.TP
+\fIfileAttrsSetProc\fR
+.
+The \fIobjPtr\fR argument should either just be read or its reference count
+incremented to retain it.
+.TP
+\fIremoveDirectoryProc\fR
+.
+If an error is being reported, the problem filename reported via
+\fIerrorPtr\fR should be newly allocated (as if with \fBTcl_NewObj\fR) and
+have a reference count of 1 (i.e., have been passed to
+\fBTcl_IncrRefCount\fR).
+.TP
+\fIcopyDirectoryProc\fR
+.
+If an error is being reported, the problem filename reported via
+\fIerrorPtr\fR should be newly allocated (as if with \fBTcl_NewObj\fR) and
+have a reference count of 1 (i.e., have been passed to
+\fBTcl_IncrRefCount\fR).
+.TP
+\fIgetCwdProc\fR
+.
+The result will be passed to \fBTcl_DecrRefCount\fR by the implementation of
+\fBTcl_FSGetCwd\fR after it has been normalized.
.SH "SEE ALSO"
cd(n), file(n), filename(n), load(n), open(n), pwd(n), source(n), unload(n)
.SH KEYWORDS
diff --git a/doc/FindExec.3 b/doc/FindExec.3
index 1fd57db..6156382 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -13,7 +13,7 @@ Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of th
.nf
\fB#include <tcl.h>\fR
.sp
-void
+const char *
\fBTcl_FindExecutable\fR(\fIargv0\fR)
.sp
const char *
@@ -35,6 +35,9 @@ Tcl. For example, it is needed on some platforms in the
implementation of the \fBload\fR command.
It is also returned by the \fBinfo nameofexecutable\fR command.
.PP
+The result of \fBTcl_FindExecutable\fR is the full Tcl version with build
+information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR).
+.PP
On UNIX platforms this procedure is typically invoked as the very
first thing in the application's main program; it must be passed
\fIargv[0]\fR as its argument. It is important not to change the
@@ -58,6 +61,8 @@ internal full path name of the executable file as computed by
equivalent to the \fBinfo nameofexecutable\fR command. NULL
is returned if the internal full path name has not been
computed or unknown.
-
+.PP
+\fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
.SH KEYWORDS
binary, executable file
diff --git a/doc/GetIndex.3 b/doc/GetIndex.3
index 17a31d4..176b0b2 100644
--- a/doc/GetIndex.3
+++ b/doc/GetIndex.3
@@ -27,19 +27,22 @@ Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
.AP Tcl_Obj *objPtr in/out
The string value of this value is used to search through \fItablePtr\fR.
-The internal representation is modified to hold the index of the matching
+If the \fBTCL_INDEX_TEMP_TABLE\fR flag is not specified,
+the internal representation is modified to hold the index of the matching
table entry.
.AP "const char *const" *tablePtr in
An array of null-terminated strings. The end of the array is marked
by a NULL string pointer.
-Note that references to the \fItablePtr\fR may be retained in the
+Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified,
+references to the \fItablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array.
.AP "const void" *structTablePtr in
An array of arbitrary type, typically some \fBstruct\fR type.
The first member of the structure must be a null-terminated string.
The size of the structure is given by \fIoffset\fR.
-Note that references to the \fIstructTablePtr\fR may be retained in the
+Note that, unless the \fBTCL_INDEX_TEMP_TABLE\fR flag is specified,
+references to the \fIstructTablePtr\fR may be retained in the
internal representation of \fIobjPtr\fR, so this should represent the
address of a statically-allocated array of structures.
.AP int offset in
@@ -50,10 +53,13 @@ Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
OR-ed combination of bits providing additional information for
-operation. The only bit that is currently defined is \fBTCL_EXACT\fR.
-.AP int *indexPtr out
-The index of the string in \fItablePtr\fR that matches the value of
-\fIobjPtr\fR is returned here.
+operation. The only bits that are currently defined are \fBTCL_EXACT\fR
+, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_NULL_OK\fR.
+.AP enum|char|short|int|long *indexPtr out
+If not (int *)NULL, the index of the string in \fItablePtr\fR that
+matches the value of \fIobjPtr\fR is returned here. The variable can
+be any integer type, signed or unsigned, char, short, long or
+long long. It can also be an enum.
.BE
.SH DESCRIPTION
.PP
@@ -66,8 +72,8 @@ the strings in \fItablePtr\fR to find a match. A match occurs if
\fItablePtr\fR, or if it is a non-empty unique abbreviation
for exactly one of the strings in \fItablePtr\fR and the
\fBTCL_EXACT\fR flag was not specified; in either case
-the index of the matching entry is stored at \fI*indexPtr\fR
-and \fBTCL_OK\fR is returned.
+\fBTCL_OK\fR is returned. If \fIindexPtr\fR is not NULL the index
+of the matching entry is stored at \fI*indexPtr\fR.
.PP
If there is no matching entry,
\fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's
@@ -76,7 +82,8 @@ error message to indicate what was being looked up. For example,
if \fImsg\fR is \fBoption\fR the error message will have a form like
.QW "\fBbad option \N'34'firt\N'34': must be first, second, or third\fR" .
.PP
-If \fBTcl_GetIndexFromObj\fR completes successfully it modifies the
+If the \fBTCL_INDEX_TEMP_TABLE\fR was not specified, when
+\fBTcl_GetIndexFromObj\fR completes successfully it modifies the
internal representation of \fIobjPtr\fR to hold the address of
the table and the index of the matching entry. If \fBTcl_GetIndexFromObj\fR
is invoked again with the same \fIobjPtr\fR and \fItablePtr\fR
@@ -84,7 +91,11 @@ arguments (e.g. during a reinvocation of a Tcl command), it returns
the matching index immediately without having to redo the lookup
operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between
-invocations. If the value of \fIobjPtr\fR is the empty string,
+invocations. This caching mechanism can be disallowed by specifying
+the \fBTCL_INDEX_TEMP_TABLE\fR flag.
+If the \fBTCL_NULL_OK\fR flag was specified, objPtr is allowed
+to be NULL or the empty string. The resulting index is -1.
+Otherwise, if the value of \fIobjPtr\fR is the empty string,
\fBTcl_GetIndexFromObj\fR will treat it as a non-matching value
and return \fBTCL_ERROR\fR.
.PP
@@ -98,6 +109,12 @@ array of characters at \fItablePtr\fR+\fIoffset\fR bytes, etc.)
This is particularly useful when processing things like
\fBTk_ConfigurationSpec\fR, whose string keys are in the same place in
each of several array elements.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_GetIndexFromObj\fR and \fBTcl_GetIndexFromObjStruct\fR do not modify
+the reference count of their \fIobjPtr\fR arguments; they only read. Note
+however that these functions may set the interpreter result; if that is the
+only place that is holding a reference to the object, it will be deleted.
.SH "SEE ALSO"
prefix(n), Tcl_WrongNumArgs(3)
.SH KEYWORDS
diff --git a/doc/GetInt.3 b/doc/GetInt.3
index 1e49528..f15c12d 100644
--- a/doc/GetInt.3
+++ b/doc/GetInt.3
@@ -22,6 +22,9 @@ int
.sp
int
\fBTcl_GetBoolean\fR(\fIinterp, src, intPtr\fR)
+.sp
+int
+\fBTcl_GetBool\fR(\fIinterp, src, flags, charPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *doublePtr out
.AP Tcl_Interp *interp in
@@ -33,6 +36,12 @@ Points to place to store integer value converted from \fIsrc\fR.
.AP double *doublePtr out
Points to place to store double-precision floating-point
value converted from \fIsrc\fR.
+.AP char *charPtr out
+Points to place to store boolean value (0 or 1) value converted from \fIsrc\fR.
+.AP int flags in
+0 or TCL_NULL_OK. If TCL_NULL_OK
+is used, then the empty string or NULL will result in \fBTcl_GetBool\fR
+return TCL_OK, the *charPtr filled with the value \fB'\exFF'\fR;
.BE
.SH DESCRIPTION
@@ -55,6 +64,9 @@ after the optional white space and sign are
.QW \fB0x\fR
then \fIsrc\fR is expected to be in hexadecimal form; otherwise,
if the first such characters are
+.QW \fB0d\fR
+then \fIsrc\fR is expected to be in decimal form; otherwise,
+if the first such characters are
.QW \fB0o\fR
then \fIsrc\fR is expected to be in octal form; otherwise,
if the first such characters are
@@ -63,8 +75,8 @@ then \fIsrc\fR is expected to be in binary form; otherwise,
if the first such character is
.QW \fB0\fR
then \fIsrc\fR
-is expected to be in octal form; otherwise, \fIsrc\fR is
-expected to be in decimal form.
+is expected to be in octal form; otherwise, \fIsrc\fR
+is expected to be in decimal form.
.PP
\fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point
number, which is: white space; a sign; a sequence of digits; a
@@ -94,6 +106,10 @@ If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR,
then 1 is stored at \fI*intPtr\fR.
Any of these values may be abbreviated, and upper-case spellings
are also acceptable.
+.PP
+\fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR,
+but it has an additional parameter \fBflags\fR, which can be used
+to specify whether the empty string or NULL is accepted as valid.
.SH KEYWORDS
boolean, conversion, double, floating-point, integer
diff --git a/doc/Hash.3 b/doc/Hash.3
index 4dc3623..0532390 100644
--- a/doc/Hash.3
+++ b/doc/Hash.3
@@ -281,7 +281,7 @@ The \fIhashKeyProc\fR member contains the address of a function called to
calculate a hash value for the key.
.PP
.CS
-typedef unsigned int \fBTcl_HashKeyProc\fR(
+typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR(
Tcl_HashTable *\fItablePtr\fR,
void *\fIkeyPtr\fR);
.CE
@@ -330,5 +330,19 @@ typedef void \fBTcl_FreeHashEntryProc\fR(
If this is NULL then \fBTcl_Free\fR is used to free the space for the entry.
Tcl_Obj* keys use this function to decrement the reference count on the
value.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+When a hash table is created with \fBTcl_InitCustomHashTable\fR, the
+\fBTcl_CreateHashEntry\fR function will increment the reference count of its
+\fIkey\fR argument when it creates a key (but not if there is an existing
+matching key). The reference count of the key will be decremented when the
+corresponding hash entry is deleted, whether with \fBTcl_DeleteHashEntry\fR or
+with \fBTcl_DeleteHashTable\fR. The \fBTcl_GetHashKey\fR function will return
+the key without further modifying its reference count.
+.PP
+Custom hash tables that use a Tcl_Obj* as key will generally need to do
+something similar in their \fIallocEntryProc\fR.
+.SH "SEE ALSO"
+Dict(3)
.SH KEYWORDS
hash table, key, lookup, search, value
diff --git a/doc/Init.3 b/doc/Init.3
index d9fc2e1..cf17a37 100644
--- a/doc/Init.3
+++ b/doc/Init.3
@@ -2,7 +2,7 @@
'\" Copyright (c) 1998-2000 Scriptics Corporation.
'\" All rights reserved.
'\"
-.TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures"
+.TH Tcl_Init 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
@@ -13,10 +13,15 @@ Tcl_Init \- find and source initialization script
.sp
int
\fBTcl_Init\fR(\fIinterp\fR)
+.sp
+const char *
+\fBTcl_SetPreInitScript\fR(\fIscriptPtr\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp
.AP Tcl_Interp *interp in
Interpreter to initialize.
+.AP "const char" *scriptPtr in
+Address of the initialization script.
.BE
.SH DESCRIPTION
@@ -26,6 +31,13 @@ Interpreter to initialize.
path.
.PP
\fBTcl_Init\fR is typically called from \fBTcl_AppInit\fR procedures.
+.PP
+\fBTcl_SetPreInitScript\fR registers the pre-initialization script and
+returns the former (now replaced) script pointer.
+A value of \fINULL\fR may be passed to not register any script.
+The pre-initialization script is executed by \fBTcl_Init\fR before accessing
+the file system. The purpose is to typically prepare a custom file system
+(like an embedded zip-file) to be activated before the search.
.SH "SEE ALSO"
Tcl_AppInit, Tcl_Main
diff --git a/doc/InitStubs.3 b/doc/InitStubs.3
index fbb3f56..4423666 100644
--- a/doc/InitStubs.3
+++ b/doc/InitStubs.3
@@ -23,11 +23,11 @@ Tcl interpreter handle.
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
-Non-zero means that only the particular version specified by
+1 means that only the particular version specified by
\fIversion\fR is acceptable.
-Zero means that versions newer than \fIversion\fR are also
+0 means that versions newer than \fIversion\fR are also
acceptable as long as they have the same major version number
-as \fIversion\fR.
+as \fIversion\fR. Other bits have no effect.
.BE
.SH INTRODUCTION
.PP
diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3
new file mode 100644
index 0000000..0d09a41
--- /dev/null
+++ b/doc/InitSubSyst.3
@@ -0,0 +1,34 @@
+'\"
+'\" Copyright (c) 2018 Tcl Core Team
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.so man.macros
+.TH Tcl_InitSubsystems 3 8.7 Tcl "Tcl Library Procedures"
+.BS
+.SH NAME
+Tcl_InitSubsystems \- initialize the Tcl library.
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+const char *
+\fBTcl_InitSubsystems\fR(\fIvoid\fR)
+.SH DESCRIPTION
+.PP
+The \fBTcl_InitSubsystems\fR procedure initializes the Tcl
+library. This procedure is typically invoked as the very
+first thing in the application's main program.
+.PP
+The result of \fBTcl_InitSubsystems\fR is the full Tcl version with build
+information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR).
+.PP
+\fBTcl_InitSubsystems\fR is very similar in use to
+\fBTcl_FindExecutable\fR. It can be used when Tcl is
+used as utility library, no other encodings than utf8,
+iso8859-1 or utf-16 are used, and no interest exists in the
+value of \fBinfo nameofexecutable\fR. The system encoding will not
+be extracted from the environment, but falls back to iso8859-1.
+.SH KEYWORDS
+binary, executable file
diff --git a/doc/IntObj.3 b/doc/IntObj.3
index 2acb446..18d867e 100644
--- a/doc/IntObj.3
+++ b/doc/IntObj.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
+Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetWideUIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -32,11 +32,17 @@ int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
+\fBTcl_GetIntForIndex\fR(\fIinterp, objPtr, endValue, intPtr\fR)
+.sp
+int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
.sp
int
\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
.sp
+int
+\fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR)
+.sp
.sp
\fB#include <tclTomMath.h>\fR
.sp
@@ -55,6 +61,8 @@ int
\fBTcl_InitBignumFromDouble\fR(\fIinterp, doubleValue, bigValue\fR)
.SH ARGUMENTS
.AS Tcl_WideInt doubleValue in/out
+.AP int endValue in
+\fBTcl_GetIntForIndex\fR will return this when the input value is "end".
.AP int intValue in
Integer value used to initialize or set a Tcl value.
.AP long longValue in
@@ -77,6 +85,8 @@ Points to place to store the integer value retrieved from \fIobjPtr\fR.
Points to place to store the long integer value retrieved from \fIobjPtr\fR.
.AP Tcl_WideInt *widePtr out
Points to place to store the wide integer value retrieved from \fIobjPtr\fR.
+.AP Tcl_WideUInt *uwidePtr out
+Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR.
.AP mp_int *bigValue in/out
Points to a multi-precision integer structure declared by the LibTomMath
library.
@@ -97,7 +107,7 @@ are provided by the C language standard. The \fBTcl_WideInt\fR type is a
typedef defined to be whatever signed integral type covers at least the
64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending
on the platform and the C compiler, the actual type might be
-\fBlong int\fR, \fBlong long int\fR, \fB__int64\fR, or something else.
+\fBlong long int\fR, or something else.
The \fBmp_int\fR type is a multiple-precision integer type defined
by the LibTomMath multiple-precision integer library.
.PP
@@ -115,6 +125,16 @@ violates Tcl's copy-on-write policy. Any existing string representation
or internal representation in the unshared Tcl value will be freed
as a consequence of setting the new value.
.PP
+The \fBTcl_GetIntForIndex\fR routine attempts to retrieve an index
+value from the Tcl value \fIobjPtr\fR. If the attempt succeeds,
+then \fBTCL_OK\fR is returned, and the value is written to the
+storage provided by the caller. The attempt might fail if
+\fIobjPtr\fR does not hold an index value. If the attempt fails,
+then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL,
+an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR
+of \fIobjPtr\fR may be changed to make subsequent calls to the
+same routine more efficient.
+.PP
The \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and
\fBTcl_TakeBignumFromObj\fR routines attempt to retrieve an integral
@@ -145,6 +165,27 @@ If anything later in the caller requires
The \fBTcl_InitBignumFromDouble\fR routine is a utility procedure
that extracts the integer part of \fIdoubleValue\fR and stores that
integer value in the \fBmp_int\fR value \fIbigValue\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and
+\fBTcl_NewBignumObj\fR always return a zero-reference object, much like
+\fBTcl_NewObj\fR.
+.PP
+\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, \fBTcl_SetWideIntObj\fR, and
+\fBTcl_SetBignumObj\fR do not modify the reference count of their \fIobjPtr\fR
+arguments, but do require that the object be unshared.
+.PP
+\fBTcl_GetIntFromObj\fR, \fBTcl_GetIntForIndex\fR, \fBTcl_GetLongFromObj\fR,
+\fBTcl_GetWideIntFromObj\fR, \fBTcl_GetBignumFromObj\fR, and
+\fBTcl_TakeBignumFromObj\fR do not modify the reference count of their
+\fIobjPtr\fR arguments; they only read. Note however that this function may
+set the interpreter result; if that is the only place that is holding a
+reference to the object, it will be deleted. Also note that if
+\fBTcl_TakeBignumFromObj\fR is given an unshared value, the value of that
+object may be modified; it is intended to be used when the value is
+.QW consumed
+by the operation at this point.
+
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
diff --git a/doc/Interp.3 b/doc/Interp.3
index 731007b..c1b9803 100644
--- a/doc/Interp.3
+++ b/doc/Interp.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures"
+.TH Tcl_Interp 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
@@ -15,9 +15,9 @@ Tcl_Interp \- client-visible fields of interpreter structures
\fB#include <tcl.h>\fR
.sp
typedef struct {
- char *\fIresult\fR;
- Tcl_FreeProc *\fIfreeProc\fR;
- int \fIerrorLine\fR;
+ char *\fIresult\fR; /* NO LONGER AVAILABLE */
+ Tcl_FreeProc *\fIfreeProc\fR; /* NO LONGER AVAILABLE */
+ int \fIerrorLine\fR; /* NO LONGER AVAILABLE */
} \fBTcl_Interp\fR;
typedef void \fBTcl_FreeProc\fR(
@@ -25,110 +25,17 @@ typedef void \fBTcl_FreeProc\fR(
.BE
.SH DESCRIPTION
.PP
-The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp
+The \fBTcl_CreateInterp\fR procedure returns a pointer to a \fBTcl_Interp\fR
structure. Callers of \fBTcl_CreateInterp\fR should use this pointer
as an opaque token, suitable for nothing other than passing back to
-other routines in the Tcl interface. Accessing fields directly through
-the pointer as described below is no longer supported. The supported
-public routines \fBTcl_SetResult\fR, \fBTcl_GetResult\fR,
-\fBTcl_SetErrorLine\fR, \fBTcl_GetErrorLine\fR must be used instead.
-.PP
-For legacy programs and extensions no longer being maintained, compiles
-against the Tcl 8.6 header files are only possible with the compiler
-directives
-.CS
-#define USE_INTERP_RESULT
-.CE
-and/or
-.CS
-#define USE_INTERP_ERRORLINE
-.CE
-depending on which fields of the \fBTcl_Interp\fR struct are accessed.
-These directives may be embedded in code or supplied via compiler options.
-.PP
-The \fIresult\fR and \fIfreeProc\fR fields are used to return
-results or error messages from commands.
-This information is returned by command procedures back to \fBTcl_Eval\fR,
-and by \fBTcl_Eval\fR back to its callers.
-The \fIresult\fR field points to the string that represents the
-result or error message, and the \fIfreeProc\fR field tells how
-to dispose of the storage for the string when it is not needed anymore.
-The easiest way for command procedures to manipulate these
-fields is to call procedures like \fBTcl_SetResult\fR
-or \fBTcl_AppendResult\fR; they
-will hide all the details of managing the fields.
-The description below is for those procedures that manipulate the
-fields directly.
-.PP
-Whenever a command procedure returns, it must ensure
-that the \fIresult\fR field of its interpreter points to the string
-being returned by the command.
-The \fIresult\fR field must always point to a valid string.
-If a command wishes to return no result then \fIinterp->result\fR
-should point to an empty string.
-Normally, results are assumed to be statically allocated,
-which means that the contents will not change before the next time
-\fBTcl_Eval\fR is called or some other command procedure is invoked.
-In this case, the \fIfreeProc\fR field must be zero.
-Alternatively, a command procedure may dynamically
-allocate its return value (e.g. using \fBTcl_Alloc\fR)
-and store a pointer to it in \fIinterp->result\fR.
-In this case, the command procedure must also set \fIinterp->freeProc\fR
-to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR
-if the storage was allocated directly by Tcl or by a call to
-\fBTcl_Alloc\fR.
-If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
-to free the space pointed to by \fIinterp->result\fR before it
-invokes the next command.
-If a client procedure overwrites \fIinterp->result\fR when
-\fIinterp->freeProc\fR is non-zero, then it is responsible for calling
-\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR
-macro should be used for this purpose).
-.PP
-\fIFreeProc\fR should have arguments and result that match the
-\fBTcl_FreeProc\fR declaration above: it receives a single
-argument which is a pointer to the result value to free.
-In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever
-used for \fIfreeProc\fR.
-However, an application may store a different procedure address
-in \fIfreeProc\fR in order to use an alternate memory allocator
-or in order to do other cleanup when the result memory is freed.
-.PP
-As part of processing each command, \fBTcl_Eval\fR initializes
-\fIinterp->result\fR
-and \fIinterp->freeProc\fR just before calling the command procedure for
-the command. The \fIfreeProc\fR field will be initialized to zero,
-and \fIinterp->result\fR will point to an empty string. Commands that
-do not return any value can simply leave the fields alone.
-Furthermore, the empty string pointed to by \fIresult\fR is actually
-part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200).
-If a command wishes to return a short string, it can simply copy
-it to the area pointed to by \fIinterp->result\fR. Or, it can use
-the sprintf procedure to generate a short result string at the location
-pointed to by \fIinterp->result\fR.
-.PP
-It is a general convention in Tcl-based applications that the result
-of an interpreter is normally in the initialized state described
-in the previous paragraph.
-Procedures that manipulate an interpreter's result (e.g. by
-returning an error) will generally assume that the result
-has been initialized when the procedure is called.
-If such a procedure is to be called after the result has been
-changed, then \fBTcl_ResetResult\fR should be called first to
-reset the result to its initialized state. The direct use of
-\fIinterp->result\fR is strongly deprecated (see \fBTcl_SetResult\fR).
-.PP
-The \fIerrorLine\fR
-field is valid only after \fBTcl_Eval\fR returns
-a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR
-field identifies the line number of the command being executed when
-the error occurred. The line numbers are relative to the command
-being executed: 1 means the first line of the command passed to
-\fBTcl_Eval\fR, 2 means the second line, and so on.
-The \fIerrorLine\fR field is typically used in conjunction with
-\fBTcl_AddErrorInfo\fR to report information about where an error
-occurred.
-\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR.
+other routines in the Tcl interface from the same thread that called
+\fBTcl_CreateInterp\fR. The \fBTcl_Interp\fR struct no longer has any
+supported client-visible fields. Supported public routines such as
+\fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR,
+\fBTcl_GetErrorLine\fR must be used instead.
+.PP
+Any legacy programs and extensions trying to access the fields above
+in their source code will need conversion to compile for Tcl 8.7 and later.
.SH KEYWORDS
-free, initialized, interpreter, malloc, result
+interpreter, result
diff --git a/doc/LinkVar.3 b/doc/LinkVar.3
index c80d30d..f5e97b4 100644
--- a/doc/LinkVar.3
+++ b/doc/LinkVar.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
+Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -17,27 +17,52 @@ Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variab
int
\fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR)
.sp
+.VS "TIP 312"
+int
+\fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR)
+.VE "TIP 312"
+.sp
\fBTcl_UnlinkVar\fR(\fIinterp, varName\fR)
.sp
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
-.AS Tcl_Interp writable
+.AS Tcl_Interp varName in
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP "const char" *varName in
Name of global variable.
-.AP char *addr in
+.AP void *addr in
Address of C variable that is to be linked to \fIvarName\fR.
+.sp
+.VS "TIP 312"
+In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage
+for the array in the variable.
+.VE "TIP 312"
.AP int type in
-Type of C variable. Must be one of \fBTCL_LINK_INT\fR,
+Type of C variable for \fBTcl_LinkVar\fR or type of array element for
+\fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR,
\fBTCL_LINK_UINT\fR, \fBTCL_LINK_CHAR\fR, \fBTCL_LINK_UCHAR\fR,
\fBTCL_LINK_SHORT\fR, \fBTCL_LINK_USHORT\fR, \fBTCL_LINK_LONG\fR,
\fBTCL_LINK_ULONG\fR, \fBTCL_LINK_WIDE_INT\fR,
-\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR,
-\fBTCL_LINK_DOUBLE\fR, \fBTCL_LINK_BOOLEAN\fR, or
-\fBTCL_LINK_STRING\fR, optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR
-to make Tcl variable read-only.
+\fBTCL_LINK_WIDE_UINT\fR, \fBTCL_LINK_FLOAT\fR, \fBTCL_LINK_DOUBLE\fR,
+\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 int size in
+.VS "TIP 312"
+The number of elements in the C array. Must be greater than zero.
+.VE "TIP 312"
.BE
.SH DESCRIPTION
.PP
@@ -52,130 +77,177 @@ while setting up the link (e.g. because \fIvarName\fR is the
name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result
contains an error message.
.PP
+.VS "TIP 312"
+\fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by
+the \fIsize\fR argument). When asked to allocate the backing C array
+storage (via the \fIaddr\fR argument being NULL), it writes the
+address that it allocated to the Tcl interpreter result.
+.VE "TIP 312"
+.PP
The \fItype\fR argument specifies the type of the C variable,
+or the type of the elements of the C array,
and must have one of the following values, optionally OR'ed with
\fBTCL_LINK_READ_ONLY\fR:
.TP
\fBTCL_LINK_INT\fR
-The C variable is of type \fBint\fR.
+.
+The C variable, or each element of the C array, is of type \fBint\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors. Incomplete integer representations (like the empty
-string, '+', '-' or the hex/octal/binary prefix) are accepted
+string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted
as if they are valid too.
.TP
\fBTCL_LINK_UINT\fR
-The C variable is of type \fBunsigned int\fR.
+.
+The C variable, or each element of the C array, is of type \fBunsigned int\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the
platform's defined range for the \fBunsigned int\fR type; attempts to
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/binary
+representations (like the empty string, '+', '-' or the hex/octal/decimal/binary
prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_CHAR\fR
-The C variable is of type \fBchar\fR.
+.
+The C variable, or each element of the C array, is of type \fBchar\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the
\fBchar\fR datatype; attempts to write non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors. Incomplete
integer representations (like the empty string, '+', '-' or the
-hex/octal/binary prefix) are accepted as if they are valid too.
+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_CHARS\fR instead.
+.VE "TIP 312"
+.RE
+.TP
+\fBTCL_LINK_CHARS\fR
+.VS "TIP 312"
+The C array is of type \fBchar *\fR and is mapped into Tcl as a string.
+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
\fBTCL_LINK_UCHAR\fR
-The C variable is of type \fBunsigned char\fR.
+.
+The C variable, or each element of the C array, is of type \fBunsigned char\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetIntFromObj\fR and in the
platform's defined range for the \fBunsigned char\fR type; attempts to
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/binary
+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
\fBTCL_LINK_SHORT\fR
-The C variable is of type \fBshort\fR.
+.
+The C variable, or each element of the C array, is of type \fBshort\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the
\fBshort\fR datatype; attempts to write non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors. Incomplete
integer representations (like the empty string, '+', '-' or the
-hex/octal/binary prefix) are accepted as if they are valid too.
+hex/octal/decimal/binary prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_USHORT\fR
-The C variable is of type \fBunsigned short\fR.
+.
+The C variable, or each element of the C array, is of type \fBunsigned short\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetIntFromObj\fR and in the
platform's defined range for the \fBunsigned short\fR type; attempts to
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/binary
+representations (like the empty string, '+', '-' or the hex/octal/decimal/binary
prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_LONG\fR
-The C variable is of type \fBlong\fR.
+.
+The C variable, or each element of the C array, is of type \fBlong\fR.
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write
non-integer or out-of-range
values into \fIvarName\fR will be rejected with Tcl errors. Incomplete
integer representations (like the empty string, '+', '-' or the
-hex/octal/binary prefix) are accepted as if they are valid too.
+hex/octal/decimal/binary prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_ULONG\fR
-The C variable is of type \fBunsigned long\fR.
+.
+The C variable, or each element of the C array, is of type \fBunsigned long\fR.
Any value written into the Tcl variable must have a proper unsigned
integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the
platform's defined range for the \fBunsigned long\fR type; attempts to
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/binary
+representations (like the empty string, '+', '-' or the hex/octal/decimal/binary
prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_DOUBLE\fR
-The C variable is of type \fBdouble\fR.
+.
+The C variable, or each element of the C array, is of type \fBdouble\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write
non-real values into \fIvarName\fR will be rejected with
Tcl errors. Incomplete integer or real representations (like the
-empty string, '.', '+', '-' or the hex/octal/binary prefix) are
+empty string, '.', '+', '-' or the hex/octal/decimal/binary prefix) are
accepted as if they are valid too.
.TP
\fBTCL_LINK_FLOAT\fR
-The C variable is of type \fBfloat\fR.
+.
+The C variable, or each element of the C array, is of type \fBfloat\fR.
Any value written into the Tcl variable must have a proper real
form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the
range acceptable for a \fBfloat\fR; attempts to
write non-real values (or values outside the range) into
\fIvarName\fR will be rejected with Tcl errors. Incomplete integer
or real representations (like the empty string, '.', '+', '-' or
-the hex/octal/binary prefix) are accepted as if they are valid too.
+the hex/octal/decimal/binary prefix) are accepted as if they are valid too.
.TP
\fBTCL_LINK_WIDE_INT\fR
-The C variable is of type \fBTcl_WideInt\fR (which is an integer type
+.
+The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR
+(which is an integer type
at least 64-bits wide on all platforms that can support it.)
Any value written into the Tcl variable must have a proper integer
form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors. Incomplete integer representations (like the empty
-string, '+', '-' or the hex/octal/binary prefix) are accepted
+string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted
as if they are valid too.
.TP
\fBTCL_LINK_WIDE_UINT\fR
-The C variable is of type \fBTcl_WideUInt\fR (which is an unsigned
-integer type at least 64-bits wide on all platforms that can support
-it.)
+.
+The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR
+(which is an unsigned integer type at least 64-bits wide on all platforms that
+can support it.)
Any value written into the Tcl variable must have a proper unsigned
-integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be
-cast to unsigned);
-.\" FIXME! Use bignums instead.
+wideinteger form acceptable to \fBTcl_GetWideUIntFromObj\fR;
attempts to write non-integer values into \fIvarName\fR will be
rejected with Tcl errors. Incomplete integer representations (like
-the empty string, '+', '-' or the hex/octal/binary prefix) are accepted
+the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted
as if they are valid too.
.TP
\fBTCL_LINK_BOOLEAN\fR
-The C variable is of type \fBint\fR.
+.
+The C variable, or each element of the C array, is of type \fBint\fR.
If its value is zero then it will read from Tcl as
.QW 0 ;
otherwise it will read from Tcl as
@@ -188,6 +260,7 @@ non-boolean values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_STRING\fR
+.
The C variable is of type \fBchar *\fR.
If its value is not NULL then it must be a pointer to a string
allocated with \fBTcl_Alloc\fR or \fBckalloc\fR.
@@ -197,6 +270,7 @@ new value.
If the C variable contains a NULL pointer then the Tcl variable
will read as
.QW NULL .
+This is only supported by \fBTcl_LinkVar\fR.
.PP
If the \fBTCL_LINK_READ_ONLY\fR flag is present in \fItype\fR then the
variable will be read-only from Tcl, so that its value can only be
diff --git a/doc/ListObj.3 b/doc/ListObj.3
index f282039..c5c1dc7 100644
--- a/doc/ListObj.3
+++ b/doc/ListObj.3
@@ -246,6 +246,31 @@ with a NULL \fIobjvPtr\fR:
result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count,
0, NULL);
.CE
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewListObj\fR always returns a zero-reference object, much like
+\fBTcl_NewObj\fR. If a non-NULL \fIobjv\fR argument is given, the reference
+counts of the first \fIobjc\fR values in that array are incremented.
+.PP
+\fBTcl_SetListObj\fR does not modify the reference count of its \fIobjPtr\fR
+argument, but does require that the object be unshared. The reference counts
+of the first \fIobjc\fR values in the \fIobjv\fR array are incremented.
+.PP
+\fBTcl_ListObjGetElements\fR, \fBTcl_ListObjIndex\fR, and
+\fBTcl_ListObjLength\fR do not modify the reference count of their
+\fIlistPtr\fR arguments; they only read. Note however that these three
+functions may set the interpreter result; if that is the only place that is
+holding a reference to the object, it will be deleted.
+.PP
+\fBTcl_ListObjAppendList\fR, \fBTcl_ListObjAppendElement\fR, and
+\fBTcl_ListObjReplace\fR require an unshared \fIlistPtr\fR argument.
+\fBTcl_ListObjAppendList\fR only reads its \fIelemListPtr\fR argument.
+\fBTcl_ListObjAppendElement\fR increments the reference count of its
+\fIobjPtr\fR on success. \fBTcl_ListObjReplace\fR increments the reference
+count of the first \fIobjc\fR values in the \fIobjv\fR array on success. Note
+however that all these three functions may set the interpreter result on
+failure; if that is the only place that is holding a reference to the object,
+it will be deleted.
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3)
.SH KEYWORDS
diff --git a/doc/Load.3 b/doc/Load.3
index 1d0d738..4533510 100644
--- a/doc/Load.3
+++ b/doc/Load.3
@@ -60,6 +60,10 @@ be unloaded with \fBTcl_FSUnloadFile\fR.
the symbol cannot be found, it returns NULL and sets an error message in the
given \fIinterp\fR (if that is non-NULL). Note that it is unsafe to use this
operation on a handle that has been passed to \fBTcl_FSUnloadFile\fR.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The reference count of the \fIpathPtr\fR argument to \fBTcl_LoadFile\fR may be
+incremented. As such, it should not be given a zero reference count value.
.SH "SEE ALSO"
Tcl_FSLoadFile(3), Tcl_FSUnloadFile(3), load(n), unload(n)
.SH KEYWORDS
diff --git a/doc/Method.3 b/doc/Method.3
index 225da00..577cd54 100644
--- a/doc/Method.3
+++ b/doc/Method.3
@@ -9,18 +9,18 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
+Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
.SH SYNOPSIS
.nf
\fB#include <tclOO.h>\fR
.sp
Tcl_Method
-\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic,
- methodTypePtr, clientData\fR)
+\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr,
+ clientData\fR)
.sp
Tcl_Method
-\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic,
- methodTypePtr, clientData\fR)
+\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr,
+ clientData\fR)
.sp
\fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR)
.sp
@@ -35,8 +35,13 @@ Tcl_Object
Tcl_Obj *
\fBTcl_MethodName\fR(\fImethod\fR)
.sp
+.VS TIP500
int
\fBTcl_MethodIsPublic\fR(\fImethod\fR)
+.VE TIP500
+.sp
+int
+\fBTcl_MethodIsPrivate\fR(\fImethod\fR)
.sp
int
\fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR)
@@ -66,10 +71,15 @@ The class to create the method in.
.AP Tcl_Obj *nameObj in
The name of the method to create. Should not be NULL unless creating
constructors or destructors.
-.AP int isPublic in
-A flag saying what the visibility of the method is. The only supported public
-values of this flag are 0 for a non-exported method, and 1 for an exported
-method.
+.AP int flags in
+A flag saying (currently) what the visibility of the method is. The supported
+public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1
+for backward compatibility) for an exported method,
+\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward
+compatibility) for a non-exported method,
+.VS TIP500
+and \fBTCL_OO_METHOD_PRIVATE\fR for a private method.
+.VE TIP500
.AP Tcl_MethodType *methodTypePtr in
A description of the type of the method to create, or the type of method to
compare against.
@@ -105,8 +115,12 @@ Given a method, the entity that declared it can be found using
attached to (or NULL if the method is not attached to any class) and
\fBTcl_MethodDeclarerObject\fR which returns the object that the method is
attached to (or NULL if the method is not attached to an object). The name of
-the method can be retrieved with \fBTcl_MethodName\fR and whether the method
-is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method
+the method can be retrieved with \fBTcl_MethodName\fR, whether the method
+is exported is retrieved with \fBTcl_MethodIsPublic\fR,
+.VS TIP500
+and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR.
+.VE TIP500
+The type of the method
can also be introspected upon to a limited degree; the function
\fBTcl_MethodIsType\fR returns whether a method is of a particular type,
assigning the per-method \fIclientData\fR to the variable pointed to by
@@ -117,8 +131,12 @@ Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR,
which
create a method attached to a class or an object respectively. In both cases,
the \fInameObj\fR argument gives the name of the method to create, the
-\fIisPublic\fR argument states whether the method should be exported
-initially, the \fImethodTypePtr\fR argument describes the implementation of
+\fIflags\fR argument states whether the method should be exported
+initially
+.VS TIP500
+or be marked as a private method,
+.VE TIP500
+the \fImethodTypePtr\fR argument describes the implementation of
the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR
argument gives some implementation-specific data that is passed on to the
implementation of the method when it is called.
@@ -240,8 +258,32 @@ also return TCL_ERROR; it should return TCL_OK otherwise.
The \fIoldClientData\fR field to a Tcl_CloneProc gives the value from the
method being copied from, and the \fInewClientDataPtr\fR field will point to
a variable in which to write the value for the method being copied to.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fInameObj\fR argument to \fBTcl_NewMethod\fR and
+\fBTcl_NewInstanceMethod\fR (when non-NULL) will have its reference count
+incremented if there is no existing method with that name in that
+class/object.
+.PP
+The result of \fBTcl_MethodName\fR is a value with a reference count of at
+least one. It should not be modified without first duplicating it (with
+\fBTcl_DuplicateObj\fR).
+.PP
+The values in the first \fIobjc\fR values of the \fIobjv\fR argument to
+\fBTcl_ObjectContextInvokeNext\fR are assumed to have a reference count of at
+least 1; the containing array is assumed to endure until the next method
+implementation (see \fBnext\fR) returns. Be aware that methods may
+\fByield\fR; if any post-call actions are desired (e.g., decrementing the
+reference count of values passed in here), they must be scheduled with
+\fBTcl_NRAddCallback\fR.
+.PP
+The \fIcallProc\fR of the \fBTcl_MethodType\fR structure takes values of at
+least reference count 1 in its \fIobjv\fR argument. It may add its own
+references, but must not decrement the reference count below that level; the
+caller of the method will decrement the reference count once the method
+returns properly (and the reference will be held if the method \fByield\fRs).
.SH "SEE ALSO"
-Class(3), oo::class(n), oo::define(n), oo::object(n)
+Class(3), NRE(3), oo::class(n), oo::define(n), oo::object(n)
.SH KEYWORDS
constructor, method, object
diff --git a/doc/NRE.3 b/doc/NRE.3
index 28576ba..f76938a 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts.
+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
@@ -18,10 +18,17 @@ 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
@@ -47,8 +54,15 @@ 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 ClientData clientData in
Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR
and \fIobjProc\fR.
@@ -104,6 +118,9 @@ 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
@@ -227,6 +244,25 @@ int
Any function comprising a routine can push other functions, making it possible
implement looping and sequencing constructs using the function stack.
.PP
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The first \fIobjc\fR values in the \fIobjv\fR array passed to the functions
+\fBTcl_NRCallObjProc\fR, \fBTcl_NREvalObjv\fR, and \fBTcl_NRCmdSwap\fR should
+have a reference count of at least 1; they may have additional references
+taken during the execution.
+.PP
+The \fIobjPtr\fR argument to \fBTcl_NREvalObj\fR and \fBTcl_NRExprObj\fR
+should have a reference count of at least 1, and may have additional
+references taken to it during execution.
+.PP
+The \fIresultObj\fR argument to \fBTcl_NRExprObj\fR should be an unshared
+object.
+.PP
+Use \fBTcl_NRAddCallback\fR to schedule any required final decrementing of the
+reference counts of arguments to any of the other functions on this page, as
+with any other post-processing step in the non-recursive execution engine.
+.PP
+The
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
diff --git a/doc/Namespace.3 b/doc/Namespace.3
index a971ddb..a7e8502 100644
--- a/doc/Namespace.3
+++ b/doc/Namespace.3
@@ -159,6 +159,18 @@ for the namespace, or NULL if none is set.
\fBTcl_SetNamespaceUnknownHandler\fR sets the unknown command handler for
the namespace. If \fIhandlerPtr\fR is NULL, then the handler is reset to
its default.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIobjPtr\fR argument to \fBTcl_AppendExportList\fR should be an
+unshared object, as it will be modified by this function. The
+reference count of \fIobjPtr\fR will not be altered.
+.PP
+\fBTcl_GetNamespaceUnknownHandler\fR returns a possibly shared value.
+Its reference count should be incremented if the value is to be
+retained.
+.PP
+The \fIhandlerPtr\fR argument to \fBTcl_SetNamespaceUnknownHandler\fR
+will have its reference count incremented if it is a non-empty list.
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_ListObjAppendList(3), Tcl_SetVar(3)
.SH KEYWORDS
diff --git a/doc/Notifier.3 b/doc/Notifier.3
index 16f9f8d..7cb02f6 100644
--- a/doc/Notifier.3
+++ b/doc/Notifier.3
@@ -90,9 +90,10 @@ 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 or \fBckalloc\fR.
-.AP Tcl_QueuePosition position in
+.AP int position in
Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR,
-\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\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
@@ -103,7 +104,7 @@ passed to \fBTcl_DoOneEvent\fR.
.AP int mode in
Indicates whether events should be serviced by \fBTcl_ServiceAll\fR.
Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR.
-.AP Tcl_NotifierProcs* notifierProcPtr in
+.AP const Tcl_NotifierProcs* notifierProcPtr in
Structure of function pointers describing notifier procedures that are
to replace the ones installed in the executable. See
\fBREPLACING THE NOTIFIER\fR for details.
@@ -132,22 +133,17 @@ higher-level software that they have occurred. The procedures
and \fBTcl_SetMaxBlockTime\fR, \fBTcl_QueueEvent\fR, and
\fBTcl_DeleteEvents\fR are used primarily by event sources.
.IP [2]
-The event queue: for non-threaded applications,
-there is a single queue for the whole application,
-containing events that have been detected but not yet serviced. Event
-sources place events onto the queue so that they may be processed in
-order at appropriate times during the event loop. The event queue
-guarantees a fair discipline of event handling, so that no event
-source can starve the others. It also allows events to be saved for
-servicing at a future time. Threaded applications work in a
-similar manner, except that there is a separate event queue for
-each thread containing a Tcl interpreter.
+The event queue: there is a single queue for each thread containing
+a Tcl interpreter, containing events that have been detected but not
+yet serviced. Event sources place events onto the queue so that they
+may be processed in order at appropriate times during the event loop.
+The event queue guarantees a fair discipline of event handling, so that
+no event source can starve the others. It also allows events to be
+saved for servicing at a future time.
\fBTcl_QueueEvent\fR is used (primarily
-by event sources) to add events to the event queue and
+by event sources) to add events to the current thread's event queue and
\fBTcl_DeleteEvents\fR is used to remove events from the queue without
-processing them. In a threaded application, \fBTcl_QueueEvent\fR adds
-an event to the current thread's queue, and \fBTcl_ThreadQueueEvent\fR
-adds an event to a queue in a specific thread.
+processing them.
.IP [3]
The event loop: in order to detect and process events, the application
enters a loop that waits for events to occur, places them on the event
@@ -345,14 +341,14 @@ 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 24
+.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 24
+.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 24
+.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.
@@ -360,6 +356,10 @@ 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
@@ -403,11 +403,7 @@ the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR)
before calling \fBTcl_QueueEvent\fR, but it
will be freed by \fBTcl_ServiceEvent\fR, not by the event source.
.PP
-Threaded applications work in a
-similar manner, except that there is a separate event queue for
-each thread containing a Tcl interpreter.
-Calling \fBTcl_QueueEvent\fR in a multithreaded application adds
-an event to the current thread's queue.
+Calling \fBTcl_QueueEvent\fR adds an event to the current thread's queue.
To add an event to another thread's queue, use \fBTcl_ThreadQueueEvent\fR.
\fBTcl_ThreadQueueEvent\fR accepts as an argument a Tcl_ThreadId argument,
which uniquely identifies a thread in a Tcl application. To obtain the
@@ -498,8 +494,7 @@ under Unix it happens when \fBTcl_WaitForEvent\fR would have waited
forever because there were no active event sources and the timeout was
infinite.
.PP
-\fBTcl_AlertNotifier\fR is used in multithreaded applications to allow
-any thread to
+\fBTcl_AlertNotifier\fR is used to allow any thread to
.QW "wake up"
the notifier to alert it to new events on its
queue. \fBTcl_AlertNotifier\fR requires as an argument the notifier
diff --git a/doc/Number.3 b/doc/Number.3
new file mode 100644
index 0000000..4642c10
--- /dev/null
+++ b/doc/Number.3
@@ -0,0 +1,123 @@
+'\"
+'\" Contribution from Don Porter, NIST, 2022. (not subject to US copyright)
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH Tcl_GetNumber 3 8.7 Tcl "Tcl Library Procedures"
+.so man.macros
+.BS
+.SH NAME
+Tcl_GetNumber, Tcl_GetNumberFromObj \- get numeric value from Tcl value
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+\fB#include <tclTomMath.h>\fR
+.sp
+int
+\fBTcl_GetNumber\fR(\fIinterp, bytes, numBytes, clientDataPtr, typePtr\fR)
+.sp
+int
+\fBTcl_GetNumberFromObj\fR(\fIinterp, objPtr, clientDataPtr, typePtr\fR)
+.SH ARGUMENTS
+.AS Tcl_Interp clientDataPtr out
+.AP Tcl_Interp *interp out
+When non-NULL, error information is recorded here when the value is not
+in any of the numeric formats recognized by Tcl.
+.AP "const char" *bytes in
+Points to first byte of the string value to be examined.
+.AP int numBytes in
+The number of bytes, starting at \fIbytes\fR, that should be examined.
+If the value \fBTCL_INDEX_NONE\fR is provided, then all bytes should
+be examined until the first \fBNUL\fR byte terminates examination.
+.AP "void *" *clientDataPtr out
+Points to space where a pointer value may be written through which a numeric
+value is available to read.
+.AP int *typePtr out
+Points to space where a value may be written reporting what type of
+numeric storage is available to read.
+.AP Tcl_Obj *objPtr in
+A Tcl value to be examined.
+.BE
+.SH DESCRIPTION
+.PP
+These procedures enable callers to retrieve a numeric value from a
+Tcl value in a numeric format recognized by Tcl.
+.PP
+Tcl recognizes many values as numbers. Several examples include:
+\fB"0"\fR, \fB" +1"\fR, \fB"-2 "\fR, \fB" 3 "\fR, \fB"0xdad1"\fR, \fB"0d09"\fR,
+\fB"1_000_000"\fR, \fB"4.0"\fR, \fB"1e-7"\fR, \fB"NaN"\fR, or \fB"Inf"\fR.
+When built-in Tcl commands act on these values as numbers, they are converted
+to a numeric representation for efficient handling in C code. Tcl makes
+use of three C types to store these representations: \fBdouble\fR,
+\fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBdouble\fR type is provided by the
+C language standard. The \fBTcl_WideInt\fR type is declared in the Tcl
+header file, \fBtcl.h\fR, and is equivalent to the C standard type
+\fBlong long\fR on most platforms. The \fBmp_int\fR type is declared in the
+header file \fBtclTomMath.h\fR, and implemented by the LibTomMath
+multiple-precision integer library, included with Tcl.
+.PP
+The routines \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR perform
+the same function. They differ only in how the arguments present the Tcl
+value to be examined. \fBTcl_GetNumber\fR accepts a counted string
+value in the arguments \fIbytes\fR and \fInumBytes\fR (or a
+\fBNUL\fR-terminated string value when \fInumBytes\fR is
+\fBTCL_INDEX_NONE\fR). \fBTcl_GetNumberFromObj\fR accepts the Tcl value
+in \fIobjPtr\fR.
+.PP
+Both routines examine the Tcl value and determine whether Tcl recognizes
+it as a number. If not, both routines return \fBTCL_ERROR\fR and (when
+\fIinterp\fR is not NULL) record an error message and error code
+in \fIinterp\fR.
+.PP
+If Tcl does recognize the examined value as a number, both routines return
+\fBTCL_OK\fR, and use the pointer arguments \fIclientDataPtr\fR
+and \fItypePtr\fR (which may not be NULL) to report information the
+caller can use to retrieve the numeric representation. Both routines
+write to *\fIclientDataPtr\fR a pointer to the internal storage location
+where Tcl holds the converted numeric value.
+.PP
+When the converted numeric value is stored as a \fBdouble\fR,
+a call to math library routine \fBisnan\fR determines whether that
+value is not a number (NaN). If so, both \fBTcl_GetNumber\fR and
+\fBTcl_GetNumberFromObj\fR write the value \fBTCL_NUMBER_NAN\fR
+to *\fItypePtr\fR. If not, both routines write the value
+\fBTCL_NUMBER_DOUBLE\fR to *\fItypePtr\fR. These routines report
+different type values in these cases because \fBTcl_GetDoubleFromObj\fR
+raises an error on NaN values. For both reported type values,
+the storage pointer may be cast to type \fBconst double *\fR and
+the \fBdouble\fR numeric value may be read through it.
+.PP
+When the converted numeric value is stored as a \fBTcl_WideInt\fR,
+both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the
+value \fBTCL_NUMBER_INT\fR to *\fItypePtr\fR.
+The storage pointer may be cast to type \fBconst Tcl_WideInt *\fR and
+the \fBTcl_WideInt\fR numeric value may be read through it.
+.PP
+When the converted numeric value is stored as an \fBmp_int\fR,
+both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the
+value \fBTCL_NUMBER_BIG\fR to *\fItypePtr\fR.
+The storage pointer may be cast to type \fBconst mp_int *\fR and
+the \fBmp_int\fR numeric value may be read through it.
+.PP
+Future releases of Tcl might expand or revise the recognition of
+values as numbers. If additional storage representations are
+adopted, these routines will add new values to be written to
+*\fItypePtr\fR to identify them. Callers should consider how
+they should react to unknown values written to *\fItypePtr\fR.
+.PP
+When callers of these routines read numeric values through the
+reported storage pointer, they are accessing memory that belongs
+to the Tcl library. The Tcl library has the power to overwrite
+or free this memory. The storage pointer reported by a call to
+\fBTcl_GetNumber\fR or \fBTcl_GetNumberFromObj\fR should not be
+used after the same thread has possibly returned control to the
+Tcl library. If longer term access to the numeric value is needed,
+it should be copied into memory controlled by the caller. Callers
+must not attempt to write through or free the storage pointer.
+.SH "SEE ALSO"
+Tcl_GetDouble, Tcl_GetDoubleFromObj, Tcl_GetWideIntFromObj
+.SH KEYWORDS
+double, double value, double type, integer, integer value, integer type,
+internal representation, value, value type, string representation
diff --git a/doc/Object.3 b/doc/Object.3
index eadd041..2099552 100644
--- a/doc/Object.3
+++ b/doc/Object.3
@@ -283,7 +283,12 @@ to reduce storage requirements.
Reference counting is used to determine when a value is
no longer needed and can safely be freed.
A value just created by \fBTcl_NewObj\fR or \fBTcl_NewStringObj\fR
-has \fIrefCount\fR 0.
+has \fIrefCount\fR 0, meaning that the object can often be given to a function
+like \fBTcl_SetObjResult\fR, \fBTcl_ListObjAppendElement\fR, or
+\fBTcl_DictObjPut\fR (as a value) without explicit reference management, all
+of which are common use cases. (The latter two require that the the target
+list or dictionary be well-formed, but that is often easy to arrange when the
+value is being initially constructed.)
The macro \fBTcl_IncrRefCount\fR increments the reference count
when a new reference to the value is created.
The macro \fBTcl_DecrRefCount\fR decrements the count
diff --git a/doc/ObjectType.3 b/doc/ObjectType.3
index 67f5174..7e3cc12 100644
--- a/doc/ObjectType.3
+++ b/doc/ObjectType.3
@@ -248,6 +248,28 @@ The \fIfreeIntRepProc\fR implementation must not access the
uses of that field during value deletion. The defined tasks for
the \fIfreeIntRepProc\fR have no need to consult the \fIbytes\fR
member.
+.PP
+Note that if a subsidiary value has its reference count reduced to zero
+during the running of a \fIfreeIntRepProc\fR, that value may be not freed
+immediately, in order to limit stack usage. However, the value will be freed
+before the outermost current \fBTcl_DecrRefCount\fR returns.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared
+value; this function will not modify the reference count of that value, but
+will modify its contents. If \fIobjPtr\fR is not (interpretable as) a list,
+this function will set the interpreter result and produce an error; using an
+unshared empty value is strongly recommended.
+.PP
+The \fIobjPtr\fR argument to \fBTcl_ConvertToType\fR can have any non-zero
+reference count; this function will not modify the reference count, but may
+write to the interpreter result on error so values that originate from there
+should have an additional reference made before calling this.
+.PP
+None of the callback functions in the \fBTcl_ObjType\fR structure should
+modify the reference count of their arguments, but if the values contain
+subsidiary values (e.g., the elements of a list or the keys of a dictionary)
+then those subsidiary values may have their reference counts modified.
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3)
.SH KEYWORDS
diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3
index cff2210..85100fc 100644
--- a/doc/OpenFileChnl.3
+++ b/doc/OpenFileChnl.3
@@ -92,10 +92,10 @@ int
int
\fBTcl_OutputBuffered\fR(\fIchannel\fR)
.sp
-Tcl_WideInt
+long long
\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR)
.sp
-Tcl_WideInt
+long long
\fBTcl_Tell\fR(\fIchannel\fR)
.sp
int
@@ -190,7 +190,7 @@ A buffer containing the bytes to output to the channel.
.AP int bytesToWrite in
The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and
output to the channel.
-.AP Tcl_WideInt offset in
+.AP "long long" offset in
How far to move the access point in the channel at which the next input or
output operation will be applied, measured in bytes from the position
given by \fIseekMode\fR. May be either positive or negative.
@@ -198,7 +198,7 @@ given by \fIseekMode\fR. May be either positive or negative.
Relative to which point to seek; used with \fIoffset\fR to calculate the new
access point for the channel. Legal values are \fBSEEK_SET\fR,
\fBSEEK_CUR\fR, and \fBSEEK_END\fR.
-.AP Tcl_WideInt length in
+.AP "long long" length in
The (non-negative) length to truncate the channel the channel to.
.AP "const char" *optionName in
The name of an option applicable to this channel, such as \fB\-blocking\fR.
@@ -406,19 +406,21 @@ to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation. The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the
-return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that
-can be retrieved with \fBTcl_GetErrno\fR.
+return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error
+code that can be retrieved with \fBTcl_GetErrno\fR. If an encoding error happens
+while the channel is in blocking mode with -profile strict, the characters
+retrieved until the encoding error happened will be stored in \fIreadObjPtr\fR.
.PP
-Setting \fIcharsToRead\fR to \fB\-1\fR will cause the command to read
+Setting \fIcharsToRead\fR to TCL_INDEX_NONE will cause the command to read
all characters currently available (non-blocking) or everything until
eof (blocking mode).
.PP
The return value may be smaller than the value to read, indicating that less
data than requested was available. This is called a \fIshort read\fR. In
blocking mode, this can only happen on an end-of-file. In nonblocking mode,
-a short read can also occur if there is not enough input currently
-available: \fBTcl_ReadChars\fR returns a short count rather than waiting
-for more data.
+a short read can also occur if an encoding error is encountered (with -profile
+strict) or if there is not enough input currently available:
+\fBTcl_ReadChars\fR returns a short count rather than waiting for more data.
.PP
If the channel is in blocking mode, a return value of zero indicates an
end-of-file condition. If the channel is in nonblocking mode, a return
@@ -471,14 +473,14 @@ character(s) are read and discarded.
.PP
If a line was successfully read, the return value is greater than or equal
to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an
-error occurs, \fBTcl_GetsObj\fR returns \-1 and records a POSIX error code
+error occurs, \fBTcl_GetsObj\fR returns TCL_INDEX_NONE and records a POSIX error code
that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also
-returns \-1 if the end of the file is reached; the \fBTcl_Eof\fR procedure
+returns TCL_INDEX_NONE if the end of the file is reached; the \fBTcl_Eof\fR procedure
can be used to distinguish an error from an end-of-file condition.
.PP
-If the channel is in nonblocking mode, the return value can also be \-1 if
-no data was available or the data that was available did not contain an
-end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR
+If the channel is in nonblocking mode, the return value can also be TCL_INDEX_NONE
+if no data was available or the data that was available did not contain an
+end-of-line character. When TCL_INDEX_NONE is returned, the \fBTcl_InputBlocked\fR
procedure may be invoked to determine if the channel is blocked because
of input unavailability.
.PP
@@ -496,7 +498,7 @@ head of the queue. If \fIchannel\fR has a
.QW sticky
EOF set, no data will be
added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or
-\-1 if an error occurs.
+TCL_INDEX_NONE if an error occurs.
.SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE"
.PP
\fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at
@@ -513,10 +515,10 @@ to appear as soon as a complete line is accepted for output, set the
\fB\-buffering\fR option on the channel to \fBline\fR mode.
.PP
The return value of \fBTcl_WriteChars\fR is a count of how many bytes were
-accepted for output to the channel. This is either greater than zero to
-indicate success or \-1 to indicate that an error occurred. If an error
-occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be
-retrieved with \fBTcl_GetErrno\fR.
+accepted for output to the channel. This is either TCL_INDEX_NONE to
+indicate that an error occurred or another number greater than
+zero to indicate success. If an error occurs, \fBTcl_WriteChars\fR records
+a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR.
.PP
Newline characters in the output data are translated to platform-specific
end-of-line sequences according to the \fB\-translation\fR option for the
@@ -641,6 +643,24 @@ the channel was created with \fBTcl_OpenFileChannel\fR,
\fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other
channel types may return a different type of handle on Windows
platforms.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIreadObjPtr\fR argument to \fBTcl_ReadChars\fR must be an unshared
+value; it will be modified by this function. Using the interpreter result for
+this purpose is \fIstrongly\fR not recommended; the preferred pattern is to
+use a new value from \fBTcl_NewObj\fR to receive the data and only to pass it
+to \fBTcl_SetObjResult\fR if this function succeeds.
+.PP
+The \fIlineObjPtr\fR argument to \fBTcl_GetsObj\fR must be an unshared value;
+it will be modified by this function. Using the interpreter result for this
+purpose is \fIstrongly\fR not recommended; the preferred pattern is to use a
+new value from \fBTcl_NewObj\fR to receive the data and only to pass it to
+\fBTcl_SetObjResult\fR if this function succeeds.
+.PP
+The \fIwriteObjPtr\fR argument to \fBTcl_WriteObj\fR should be a value with
+any reference count. This function will not modify the reference count. Using
+the interpreter result without adding an additional reference to it is not
+recommended.
.SH "SEE ALSO"
DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3)
.SH KEYWORDS
diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3
index 4a7dc1e..e72556a 100644
--- a/doc/OpenTcp.3
+++ b/doc/OpenTcp.3
@@ -4,12 +4,12 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures"
+.TH Tcl_OpenTcpClient 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets
+Tcl_OpenTcpClient, Tcl_MakeTcpClientChannel, Tcl_OpenTcpServer, Tcl_OpenTcpServerEx \- procedures to open channels using TCP sockets
.SH SYNOPSIS
.nf
\fB#include <tcl.h> \fR
@@ -23,6 +23,9 @@ Tcl_Channel
Tcl_Channel
\fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR)
.sp
+Tcl_Channel
+\fBTcl_OpenTcpServerEx\fR(\fIinterp, service, myaddr, flags, backlog, proc, clientData\fR)
+.sp
.SH ARGUMENTS
.AS Tcl_TcpAcceptProc clientData
.AP Tcl_Interp *interp in
@@ -30,6 +33,9 @@ Tcl interpreter to use for error reporting. If non-NULL and an
error occurs, an error message is left in the interpreter's result.
.AP int port in
A port number to connect to as a client or to listen on as a server.
+.AP "const char" *service in
+A string specifying the port number to connect to as a client or to listen on as
+ a server.
.AP "const char" *host in
A string specifying a host name or address for the remote end of the connection.
.AP int myport in
@@ -41,6 +47,11 @@ for the local end of the connection. If NULL, a default interface is
chosen.
.AP int async in
If nonzero, the client socket is connected asynchronously to the server.
+.AP int backlog in
+Length of OS listen backlog queue. Use -1 for default value.
+.AP "unsigned int" flags in
+ORed combination of \fBTCL_TCPSERVER_*\fR flags that specify additional
+informations about the socket being created.
.AP ClientData sock in
Platform-specific handle for client TCP socket.
.AP Tcl_TcpAcceptProc *proc in
@@ -158,6 +169,14 @@ register it, use \fBTcl_RegisterChannel\fR.
If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
+.SS TCL_OPENTCPSERVEREX
+.PP
+\fBTcl_OpenTcpServerEx\fR behaviour is identical to \fBTcl_OpenTcpServer\fR but
+gives more flexibility to the user by providing a mean to further customize some
+aspects of the socket via the \fIflags\fR parameter. Available
+flags (dependent on platform) are
+\fITCL_TCPSERVER_REUSEADDR\fR
+\fITCL_TCPSERVER_REUSEPORT\fR
.SH "PLATFORM ISSUES"
.PP
On Unix platforms, the socket handle is a Unix file descriptor as
diff --git a/doc/Panic.3 b/doc/Panic.3
index 5f4763f..5abe1dd 100644
--- a/doc/Panic.3
+++ b/doc/Panic.3
@@ -7,7 +7,7 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc \- report fatal error and abort
+Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -18,9 +18,12 @@ void
void
\fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR)
.sp
-void
+const char *
\fBTcl_SetPanicProc\fR(\fIpanicProc\fR)
.sp
+void
+\fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR)
+.sp
.SH ARGUMENTS
.AS Tcl_PanicProc *panicProc
.AP "const char*" format in
@@ -54,6 +57,14 @@ message is sent to the debugger instead. If the windows executable
does not have a stderr channel (e.g. \fBwish.exe\fR), then a
system dialog box is used to display the panic message.
.PP
+If your application doesn't use \fBTcl_Main\fR or \fBTk_Main\fR
+and you want to implicitly use the stderr channel of your
+application's C runtime (instead of the stderr channel of the
+C runtime used by Tcl), you can call \fBTcl_SetPanicProc\fR
+with \fBTcl_ConsolePanic\fR as its argument. On platforms which
+only have one C runtime (almost all platforms except Windows)
+\fBTcl_ConsolePanic\fR is equivalent to NULL.
+.PP
\fBTcl_SetPanicProc\fR may be used to modify the behavior of
\fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the
type \fBTcl_PanicProc\fR:
@@ -71,10 +82,16 @@ making calls into the Tcl library, or into other libraries that may
call the Tcl library, since the original call to \fBTcl_Panic\fR
indicates the Tcl library is not in a state of reliable operation.
.PP
+The result of \fBTcl_SetPanicProc\fR is the full Tcl version with build
+information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR).
+.PP
The typical use of \fBTcl_SetPanicProc\fR arranges for the error message
to be displayed or reported in a manner more suitable for the
application or the platform.
.PP
+\fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
+.PP
Although the primary callers of \fBTcl_Panic\fR are the procedures of
the Tcl library, \fBTcl_Panic\fR is a public function and may be called
by any extension or application that wishes to abort the process and
@@ -82,7 +99,9 @@ have a panic message displayed the same way that panic messages from Tcl
will be displayed.
.PP
\fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of
-taking a variable number of arguments it takes an argument list.
+taking a variable number of arguments it takes an argument list. Interfaces
+using argument lists have been found to be nonportable in practice. This
+function is deprecated and will be removed in Tcl 9.0.
.SH "SEE ALSO"
abort(3), printf(3), exec(n), format(n)
.SH KEYWORDS
diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3
index def55de..f29f161 100644
--- a/doc/ParseArgs.3
+++ b/doc/ParseArgs.3
@@ -189,6 +189,12 @@ will be stored at \fIdstPtr\fR; the string inside will have a lifetime linked
to the lifetime of the string representation of the argument value that it
came from, and so should be copied if it needs to be retained. The
\fIsrcPtr\fR and \fIclientData\fR fields are ignored.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The values in the \fIobjv\fR argument to \fBTcl_ParseArgsObjv\fR will not have
+their reference counts modified by this function. The interpreter result may
+be modified on error; the values passed should not be the interpreter result
+with no further reference added.
.SH "SEE ALSO"
Tcl_GetIndexFromObj(3), Tcl_Main(3), Tcl_CreateObjCommand(3)
.SH KEYWORDS
diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3
index 40a0818..03b97f7 100644
--- a/doc/ParseCmd.3
+++ b/doc/ParseCmd.3
@@ -191,6 +191,7 @@ code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR,
some other integer value originating in an extension.
In addition, a result value or error message is left in \fIinterp\fR's
result; it can be retrieved using \fBTcl_GetObjResult\fR.
+.SS "DEPRECATED FUNCTIONS"
.PP
\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in
the return convention used: it returns the result in a new Tcl_Obj.
@@ -463,5 +464,12 @@ There are additional fields in the Tcl_Parse structure after the
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR; they should not be
referenced by code outside of these procedures.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The result of \fBTcl_EvalTokens\fR is an unshared value with a reference count
+of 1; the caller of that function should call \fBTcl_DecrRefCount\fR on the
+result value to dispose of it. (The equivalent with
+\fBTcl_EvalTokenStandard\fR is just the interpreter result, which can be
+retrieved with \fBTcl_GetObjResult\fR.)
.SH KEYWORDS
backslash substitution, braces, command, expression, parse, token, variable substitution
diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3
index 71f3acf..77e73f1 100644
--- a/doc/PkgRequire.3
+++ b/doc/PkgRequire.3
@@ -91,7 +91,11 @@ functions.
\fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling
multiple requirements. The other forms are present for backward
compatibility and translate their invocations to this form.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The requirements values given (in the \fIobjv\fR argument) to
+\fBTcl_PkgRequireProc\fR must have non-zero reference counts.
.SH KEYWORDS
package, present, provide, require, version
.SH "SEE ALSO"
-package(n), Tcl_StaticPackage(3)
+package(n), Tcl_StaticLibrary(3)
diff --git a/doc/RecEvalObj.3 b/doc/RecEvalObj.3
index 1b0f292..e68f4b5 100644
--- a/doc/RecEvalObj.3
+++ b/doc/RecEvalObj.3
@@ -32,8 +32,6 @@ the command at global level instead of the current stack level.
.PP
\fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event
on the history list and then execute it using \fBTcl_EvalObjEx\fR
-(or \fBTcl_GlobalEvalObj\fR if the \fBTCL_EVAL_GLOBAL\fR bit is set
-in \fIflags\fR).
It returns a completion code such as \fBTCL_OK\fR just like \fBTcl_EvalObjEx\fR,
as well as a result value containing additional information
(a result value or error message)
@@ -46,6 +44,12 @@ allow the user to re-issue recently invoked commands.
If the \fIflags\fR argument contains the \fBTCL_NO_EVAL\fR bit then
the command is recorded without being evaluated.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The reference count of the \fIcmdPtr\fR argument to \fBTcl_RecordAndEvalObj\fR
+must be at least 1. This function will modify the interpreter result; do not
+use an existing result as \fIcmdPtr\fR directly without incrementing its
+reference count.
.SH "SEE ALSO"
Tcl_EvalObjEx, Tcl_GetObjResult
diff --git a/doc/RegConfig.3 b/doc/RegConfig.3
index d73e3d7..ef46ba5 100644
--- a/doc/RegConfig.3
+++ b/doc/RegConfig.3
@@ -28,7 +28,7 @@ configuration as ASCII string. This means that this information is in
UTF-8 too. Must not be NULL.
.AP "const Tcl_Config" *configuration in
Refers to an array of Tcl_Config entries containing the information
-embedded in the binary library. Must not be NULL. The end of the array
+embedded in the library. Must not be NULL. The end of the array
is signaled by either a key identical to NULL, or a key referring to
the empty string.
.AP "const char" *valEncoding in
@@ -40,10 +40,10 @@ too. Must not be NULL.
.PP
The function described here has its base in TIP 59 and provides
extensions with support for the embedding of configuration
-information into their binary library and the generation of a
+information into their library and the generation of a
Tcl-level interface for querying this information.
.PP
-To embed configuration information into their binary library an
+To embed configuration information into their library an
extension has to define a non-volatile array of Tcl_Config entries in
one if its source files and then call \fBTcl_RegisterConfig\fR to
register that information.
@@ -108,4 +108,4 @@ typedef struct Tcl_Config {
.\" No cross references yet.
.\" .SH "SEE ALSO"
.SH KEYWORDS
-embedding, configuration, binary library
+embedding, configuration, library
diff --git a/doc/RegExp.3 b/doc/RegExp.3
index 1d578bb..40429c9 100644
--- a/doc/RegExp.3
+++ b/doc/RegExp.3
@@ -377,6 +377,22 @@ If no match was found, then it indicates the earliest point at which a
match might occur if additional text is appended to the string. If it
is no match is possible even with further text, this field will be set
to \-1.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fItextObj\fR and \fIpatObj\fR arguments to \fBTcl_RegExpMatchObj\fR must
+have reference counts of at least 1. Note however that this function may set
+the interpreter result; neither argument should be the direct interpreter
+result without an additional reference being taken.
+.PP
+The \fIpatObj\fR argument to \fBTcl_GetRegExpFromObj\fR must have a reference
+count of at least 1. Note however that this function may set the interpreter
+result; the argument should not be the direct interpreter result without an
+additional reference being taken.
+.PP
+The \fItextObj\fR argument to \fBTcl_RegExpExecObj\fR must have a reference
+count of at least 1. Note however that this function may set the interpreter
+result; the argument should not be the direct interpreter result without an
+additional reference being taken.
.SH "SEE ALSO"
re_syntax(n)
.SH KEYWORDS
diff --git a/doc/SaveInterpState.3 b/doc/SaveInterpState.3
new file mode 100644
index 0000000..804f9ec
--- /dev/null
+++ b/doc/SaveInterpState.3
@@ -0,0 +1,85 @@
+'\"
+'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
+'\" 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 Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
+.so man.macros
+.BS
+.SH NAME
+Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState,
+Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the
+state of an an interpreter.
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+Tcl_InterpState
+\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
+.sp
+int
+\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
+.sp
+\fBTcl_DiscardInterpState\fR(\fIstate\fR)
+.sp
+\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR)
+.sp
+\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR)
+.sp
+\fBTcl_DiscardResult\fR(\fIsavedPtr\fR)
+.SH ARGUMENTS
+.AS Tcl_InterpState savedPtr
+.AP Tcl_Interp *interp in
+The interpreter for the operation.
+.AP int status in
+The return code for the state.
+.AP Tcl_InterpState state in
+A token for saved state.
+.AP Tcl_SavedResult *savedPtr in
+A pointer to storage for saved state.
+.BE
+.SH DESCRIPTION
+.PP
+These routines save the state of an interpreter before a call to a routine such
+as \fBTcl_Eval\fR, and restore the state afterwards.
+.PP
+\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the
+result of a script, including the resulting value, the return code passed as
+\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR.
+It returns a token for the saved state. The interpreter result is not reset
+and no interpreter state is changed.
+.PP
+\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and
+returns the \fIstatus\fR originally passed in the corresponding call to
+\fBTcl_SaveInterpState\fR.
+.PP
+If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called
+to release it. A token used to discard or restore state must not be used
+again.
+.PP
+\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are
+deprecated. Instead use \fBTcl_SaveInterpState\fR,
+\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more
+capable.
+.PP
+\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location
+\fIstatePtr\fR points to and returns the interpreter result to its initial
+state. It does not save options such as \fB\-errorcode\fR or
+\fB\-errorinfo\fR.
+.PP
+\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and
+moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is
+then in an undefined state and must not be used until passed again to
+\fBTcl_SaveResult\fR.
+.PP
+\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is
+then in an undefined state and must not be used until passed again to
+\fBTcl_SaveResult\fR.
+.PP
+If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to
+release it.
+.SH KEYWORDS
+result, state, interp
diff --git a/doc/SaveResult.3 b/doc/SaveResult.3
deleted file mode 100644
index 918941e..0000000
--- a/doc/SaveResult.3
+++ /dev/null
@@ -1,120 +0,0 @@
-'\"
-'\" Copyright (c) 1997 Sun Microsystems, Inc.
-'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright)
-'\"
-'\" See the file "license.terms" for information on usage and redistribution
-'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-'\"
-.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures"
-.so man.macros
-.BS
-.SH NAME
-Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state
-.SH SYNOPSIS
-.nf
-\fB#include <tcl.h>\fR
-.sp
-Tcl_InterpState
-\fBTcl_SaveInterpState\fR(\fIinterp, status\fR)
-.sp
-int
-\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR)
-.sp
-\fBTcl_DiscardInterpState\fR(\fIstate\fR)
-.sp
-\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR)
-.sp
-\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR)
-.sp
-\fBTcl_DiscardResult\fR(\fIsavedPtr\fR)
-.SH ARGUMENTS
-.AS Tcl_InterpState savedPtr
-.AP Tcl_Interp *interp in
-Interpreter for which state should be saved.
-.AP int status in
-Return code value to save as part of interpreter state.
-.AP Tcl_InterpState state in
-Saved state token to be restored or discarded.
-.AP Tcl_SavedResult *savedPtr in
-Pointer to location where interpreter result should be saved or restored.
-.BE
-.SH DESCRIPTION
-.PP
-These routines allows a C procedure to take a snapshot of the current
-state of an interpreter so that it can be restored after a call
-to \fBTcl_Eval\fR or some other routine that modifies the interpreter
-state. There are two triplets of routines meant to work together.
-.PP
-The first triplet stores the snapshot of interpreter state in
-an opaque token returned by \fBTcl_SaveInterpState\fR. That token
-value may then be passed back to one of \fBTcl_RestoreInterpState\fR
-or \fBTcl_DiscardInterpState\fR, depending on whether the interp
-state is to be restored. So long as one of the latter two routines
-is called, Tcl will take care of memory management.
-.PP
-The second triplet stores the snapshot of only the interpreter
-result (not its complete state) in memory allocated by the caller.
-These routines are passed a pointer to \fBTcl_SavedResult\fR
-that is used to store enough information to restore the interpreter result.
-\fBTcl_SavedResult\fR can be allocated on the stack of the calling
-procedure. These routines do not save the state of any error
-information in the interpreter (e.g. the \fB\-errorcode\fR or
-\fB\-errorinfo\fR return options, when an error is in progress).
-.PP
-Because the routines \fBTcl_SaveInterpState\fR,
-\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform
-a superset of the functions provided by the other routines,
-any new code should only make use of the more powerful routines.
-The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR,
-and \fBTcl_DiscardResult\fR continue to exist only for the sake
-of existing programs that may already be using them.
-.PP
-\fBTcl_SaveInterpState\fR takes a snapshot of those portions of
-interpreter state that make up the full result of script evaluation.
-This include the interpreter result, the return code (passed in
-as the \fIstatus\fR argument, and any return options, including
-\fB\-errorinfo\fR and \fB\-errorcode\fR when an error is in progress.
-This snapshot is returned as an opaque token of type \fBTcl_InterpState\fR.
-The call to \fBTcl_SaveInterpState\fR does not itself change the
-state of the interpreter. Unlike \fBTcl_SaveResult\fR, it does
-not reset the interpreter.
-.PP
-\fBTcl_RestoreInterpState\fR accepts a \fBTcl_InterpState\fR token
-previously returned by \fBTcl_SaveInterpState\fR and restores the
-state of the interp to the state held in that snapshot. The return
-value of \fBTcl_RestoreInterpState\fR is the status value originally
-passed to \fBTcl_SaveInterpState\fR when the snapshot token was
-created.
-.PP
-\fBTcl_DiscardInterpState\fR is called to release a \fBTcl_InterpState\fR
-token previously returned by \fBTcl_SaveInterpState\fR when that
-snapshot is not to be restored to an interp.
-.PP
-The \fBTcl_InterpState\fR token returned by \fBTcl_SaveInterpState\fR
-must eventually be passed to either \fBTcl_RestoreInterpState\fR
-or \fBTcl_DiscardInterpState\fR to avoid a memory leak. Once
-the \fBTcl_InterpState\fR token is passed to one of them, the
-token is no longer valid and should not be used anymore.
-.PP
-\fBTcl_SaveResult\fR moves the string and value results
-of \fIinterp\fR into the location specified by \fIstatePtr\fR.
-\fBTcl_SaveResult\fR clears the result for \fIinterp\fR and
-leaves the result in its normal empty initialized state.
-.PP
-\fBTcl_RestoreResult\fR moves the string and value results from
-\fIstatePtr\fR back into \fIinterp\fR. Any result or error that was
-already in the interpreter will be cleared. The \fIstatePtr\fR is left
-in an uninitialized state and cannot be used until another call to
-\fBTcl_SaveResult\fR.
-.PP
-\fBTcl_DiscardResult\fR releases the saved interpreter state
-stored at \fBstatePtr\fR. The state structure is left in an
-uninitialized state and cannot be used until another call to
-\fBTcl_SaveResult\fR.
-.PP
-Once \fBTcl_SaveResult\fR is called to save the interpreter
-result, either \fBTcl_RestoreResult\fR or
-\fBTcl_DiscardResult\fR must be called to properly clean up the
-memory associated with the saved state.
-.SH KEYWORDS
-result, state, interp
diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3
index 5bb86be..473b61c 100644
--- a/doc/SetChanErr.3
+++ b/doc/SetChanErr.3
@@ -35,20 +35,20 @@ Refers to the Tcl interpreter whose bypass area is accessed.
.AP Tcl_Obj* msg in
Error message put into a bypass area. A list of return options and values,
followed by a string message. Both message and the option/value information
-are optional.
+are optional. This \fImust\fR be a well-formed list.
.AP Tcl_Obj** msgPtr out
Reference to a place where the message stored in the accessed bypass area can
be stored in.
.BE
.SH DESCRIPTION
.PP
-The current definition of a Tcl channel driver does not permit the direct
+The standard definition of a Tcl channel driver does not permit the direct
return of arbitrary error messages, except for the setting and retrieval of
channel options. All other functions are restricted to POSIX error codes.
.PP
The functions described here overcome this limitation. Channel drivers are
allowed to use \fBTcl_SetChannelError\fR and \fBTcl_SetChannelErrorInterp\fR
-to place arbitrary error messages in \fBbypass areas\fR defined for channels
+to place arbitrary error messages in \fIbypass areas\fR defined for channels
and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and
\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and
arrange for their return as errors. The POSIX error codes set by a driver are
@@ -134,6 +134,15 @@ leave all their error information in the interpreter result.
.ta 1.9i 4i
\fBTcl_Close\fR \fBTcl_UnstackChannel\fR \fBTcl_UnregisterChannel\fR
.DE
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fImsg\fR argument to \fBTcl_SetChannelError\fR and
+\fBTcl_SetChannelErrorInterp\fR, if not NULL, may have any reference count;
+these functions will copy.
+.PP
+\fBTcl_GetChannelError\fR and \fBTcl_GetChannelErrorInterp\fR write a value
+reference into their \fImsgPtr\fR, but do not manipulate its reference count.
+The reference count will be at least 1 (unless the reference is NULL).
.SH "SEE ALSO"
Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3)
.SH KEYWORDS
diff --git a/doc/SetResult.3 b/doc/SetResult.3
index c98401f..d3c0d8a 100644
--- a/doc/SetResult.3
+++ b/doc/SetResult.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH Tcl_SetResult 3 8.6 Tcl "Tcl Library Procedures"
+.TH Tcl_SetResult 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
@@ -30,9 +30,7 @@ const char *
.sp
\fBTcl_ResetResult\fR(\fIinterp\fR)
.sp
-.VS 8.6
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
-.VE 8.6
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.sp
@@ -57,17 +55,11 @@ Address of procedure to call to release storage at
An argument list which must have been initialized using
\fBva_start\fR, and cleared using \fBva_end\fR.
.AP Tcl_Interp *sourceInterp in
-.VS 8.6
Interpreter that the result and return options should be transferred from.
-.VE 8.6
.AP Tcl_Interp *targetInterp in
-.VS 8.6
Interpreter that the result and return options should be transferred to.
-.VE 8.6
.AP int code in
-.VS 8.6
Return code value that controls transfer of return options.
-.VE 8.6
.BE
.SH DESCRIPTION
.PP
@@ -153,8 +145,9 @@ call; the last argument in the list must be a NULL pointer.
.PP
\fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that
instead of taking a variable number of arguments it takes an argument list.
+Interfaces using argument lists have been found to be nonportable in practice.
+This function is deprecated and will be removed in Tcl 9.0.
.PP
-.VS 8.6
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR
to \fItargetInterp\fR. The two interpreters must have been created in the
same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same,
@@ -163,7 +156,6 @@ from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result
in \fIsourceInterp\fR. It also moves the return options dictionary as
controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.
-.VE 8.6
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
@@ -205,14 +197,9 @@ is about to replace one result value with another.
It used to be legal for programs to
directly read and write \fIinterp->result\fR
to manipulate the interpreter result. The Tcl headers no longer
-permit this access by default, and C code still doing this must
+permit this access. C code still doing this must
be updated to use supported routines \fBTcl_GetObjResult\fR,
\fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR.
-As a migration aid, access can be restored with the compiler directive
-.CS
-#define USE_INTERP_RESULT
-.CE
-but this is meant only to offer life support to otherwise dead code.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how
@@ -252,6 +239,33 @@ typedef void \fBTcl_FreeProc\fR(
.PP
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.
+
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The interpreter result is one of the main places that owns references to
+values, along with the bytecode execution stack, argument lists, variables,
+and the list and dictionary collection values.
+.PP
+\fBTcl_SetObjResult\fR takes a value with an arbitrary reference count
+\fI(specifically including zero)\fR and guarantees to increment the reference
+count. If code wishes to continue using the value after setting it as the
+result, it should add its own reference to it with \fBTcl_IncrRefCount\fR.
+.PP
+\fBTcl_GetObjResult\fR returns the current interpreter result value. This will
+have a reference count of at least 1. If the caller wishes to keep the
+interpreter result value, it should increment its reference count.
+.PP
+\fBTcl_GetStringResult\fR does not manipulate reference counts, but the string
+it returns is owned by (and has a lifetime controlled by) the current
+interpreter result value; it should be copied instead of being relied upon to
+persist after the next Tcl API call, as most Tcl operations can modify the
+interpreter result.
+.PP
+\fBTcl_SetResult\fR, \fBTcl_AppendResult\fR, \fBTcl_AppendResultVA\fR,
+\fBTcl_AppendElement\fR, and \fBTcl_ResetResult\fR all modify the interpreter
+result. They may cause the old interpreter result to have its reference count
+decremented and a new interpreter result to be allocated. After they have been
+called, the reference count of the interpreter result is guaranteed to be 1.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
diff --git a/doc/SetVar.3 b/doc/SetVar.3
index 4aa671a..9d8e0b7 100644
--- a/doc/SetVar.3
+++ b/doc/SetVar.3
@@ -242,6 +242,27 @@ but the array remains.
If an array name is specified without an index, then the entire
array is removed.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The result of \fBTcl_SetVar2Ex\fR, \fBTcl_ObjSetVar2\fR, \fBTcl_GetVar2Ex\fR,
+and \fBTcl_ObjGetVar2\fR is (if non-NULL) a value with a reference of at least
+1, where that reference is held by the variable that the function has just
+operated upon.
+.PP
+The \fInewValuePtr\fR argument to \fBTcl_SetVar2Ex\fR and \fBTcl_ObjSetVar2\fR
+may be an arbitrary reference count value. Its reference count is
+incremented on success. On failure, if its reference count is zero, it is
+decremented and freed so the caller need do nothing with it.
+.PP
+The \fIpart1Ptr\fR argument to \fBTcl_ObjSetVar2\fR and \fBTcl_ObjGetVar2\fR can
+have any reference count. These functions never modify it.
+.PP
+The \fIpart2Ptr\fR argument to \fBTcl_ObjSetVar2\fR and \fBTcl_ObjGetVar2\fR, if
+non-NULL, should not have a zero reference count as these functions may
+retain a reference to it, particularly when it is used to create an array
+element that did not previously exist, and decrementing the reference count
+later would leave them pointing to a freed Tcl_Obj.
+
.SH "SEE ALSO"
Tcl_GetObjResult, Tcl_GetStringResult, Tcl_TraceVar
diff --git a/doc/StaticLibrary.3 b/doc/StaticLibrary.3
new file mode 100644
index 0000000..9a77ab7
--- /dev/null
+++ b/doc/StaticLibrary.3
@@ -0,0 +1,78 @@
+'\"
+'\" Copyright (c) 1995-1996 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_StaticLibrary 3 7.5 Tcl "Tcl Library Procedures"
+.so man.macros
+.BS
+.SH NAME
+Tcl_StaticLibrary, Tcl_StaticPackage \- make a statically linked library available via the 'load' command
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+\fBTcl_StaticLibrary\fR(\fIinterp, prefix, initProc, safeInitProc\fR)
+.sp
+\fBTcl_StaticPackage\fR(\fIinterp, prefix, initProc, safeInitProc\fR)
+.SH ARGUMENTS
+.AS Tcl_LibraryInitProc *safeInitProc
+.AP Tcl_Interp *interp in
+If not NULL, points to an interpreter into which the library has
+already been incorporated (i.e., the caller has already invoked the
+appropriate initialization procedure). NULL means the library
+has not yet been incorporated into any interpreter.
+.AP "const char" *prefix in
+Prefix for library initialization function; should be properly
+capitalized (first letter upper-case, all others lower-case).
+.AP Tcl_LibraryInitProc *initProc in
+Procedure to invoke to incorporate this library into a trusted
+interpreter.
+.AP Tcl_LibraryInitProc *safeInitProc in
+Procedure to call to incorporate this library into a safe interpreter
+(one that will execute untrusted scripts). NULL means the library
+cannot be used in safe interpreters.
+.BE
+.SH DESCRIPTION
+.PP
+This procedure may be invoked to announce that a library has been
+linked statically with a Tcl application and, optionally, that it
+has already been incorporated into an interpreter.
+Once \fBTcl_StaticLibrary\fR has been invoked for a library, it
+may be incorporated into interpreters using the \fBload\fR command.
+\fBTcl_StaticLibrary\fR is normally invoked only by the \fBTcl_AppInit\fR
+procedure for the application, not by libraries for themselves
+(\fBTcl_StaticLibrary\fR should only be invoked for statically
+linked libraries, and code in the library itself should not need
+to know whether the library is dynamically loaded or statically linked).
+.PP
+When the \fBload\fR command is used later to incorporate the library into
+an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will
+be invoked, depending on whether the target interpreter is safe
+or not.
+\fIinitProc\fR and \fIsafeInitProc\fR must both match the
+following prototype:
+.PP
+.CS
+typedef int \fBTcl_LibraryInitProc\fR(
+ Tcl_Interp *\fIinterp\fR);
+.CE
+.PP
+The \fIinterp\fR argument identifies the interpreter in which the library
+is to be incorporated. The initialization procedure must return \fBTCL_OK\fR or
+\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in
+the event of an error it should set the interpreter's result to point to an
+error message. The result or error from the initialization procedure will
+be returned as the result of the \fBload\fR command that caused the
+initialization procedure to be invoked.
+.PP
+\fBTcl_StaticLibrary\fR was named \fBTcl_StaticPackage\fR in Tcl 8.6 and
+earlier, but the old name is deprecated now.
+.PP
+\fBTcl_StaticLibrary\fR can not be used in stub-enabled extensions. Its symbol
+entry in the stub table is deprecated and it will be removed in Tcl 9.0.
+.SH KEYWORDS
+initialization procedure, package, static linking
+.SH "SEE ALSO"
+load(n), package(n), Tcl_PkgRequire(3)
diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3
deleted file mode 100644
index bd00ab7..0000000
--- a/doc/StaticPkg.3
+++ /dev/null
@@ -1,70 +0,0 @@
-'\"
-'\" Copyright (c) 1995-1996 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_StaticPackage 3 7.5 Tcl "Tcl Library Procedures"
-.so man.macros
-.BS
-.SH NAME
-Tcl_StaticPackage \- make a statically linked package available via the 'load' command
-.SH SYNOPSIS
-.nf
-\fB#include <tcl.h>\fR
-.sp
-\fBTcl_StaticPackage\fR(\fIinterp, prefix, initProc, safeInitProc\fR)
-.SH ARGUMENTS
-.AS Tcl_PackageInitProc *safeInitProc
-.AP Tcl_Interp *interp in
-If not NULL, points to an interpreter into which the package has
-already been loaded (i.e., the caller has already invoked the
-appropriate initialization procedure). NULL means the package
-has not yet been incorporated into any interpreter.
-.AP "const char" *prefix in
-Prefix for library initialization function; should be properly
-capitalized (first letter upper-case, all others lower-case).
-.AP Tcl_PackageInitProc *initProc in
-Procedure to invoke to incorporate this package into a trusted
-interpreter.
-.AP Tcl_PackageInitProc *safeInitProc in
-Procedure to call to incorporate this package into a safe interpreter
-(one that will execute untrusted scripts). NULL means the package
-cannot be used in safe interpreters.
-.BE
-.SH DESCRIPTION
-.PP
-This procedure may be invoked to announce that a package has been
-linked statically with a Tcl application and, optionally, that it
-has already been loaded into an interpreter.
-Once \fBTcl_StaticPackage\fR has been invoked for a package, it
-may be loaded into interpreters using the \fBload\fR command.
-\fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR
-procedure for the application, not by packages for themselves
-(\fBTcl_StaticPackage\fR should only be invoked for statically
-loaded packages, and code in the package itself should not need
-to know whether the package is dynamically or statically loaded).
-.PP
-When the \fBload\fR command is used later to load the package into
-an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will
-be invoked, depending on whether the target interpreter is safe
-or not.
-\fIinitProc\fR and \fIsafeInitProc\fR must both match the
-following prototype:
-.PP
-.CS
-typedef int \fBTcl_PackageInitProc\fR(
- Tcl_Interp *\fIinterp\fR);
-.CE
-.PP
-The \fIinterp\fR argument identifies the interpreter in which the package
-is to be loaded. The initialization procedure must return \fBTCL_OK\fR or
-\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in
-the event of an error it should set the interpreter's result to point to an
-error message. The result or error from the initialization procedure will
-be returned as the result of the \fBload\fR command that caused the
-initialization procedure to be invoked.
-.SH KEYWORDS
-initialization procedure, package, static linking
-.SH "SEE ALSO"
-load(n), package(n), Tcl_PkgRequire(3)
diff --git a/doc/StringObj.3 b/doc/StringObj.3
index f016c48..a64788b 100644
--- a/doc/StringObj.3
+++ b/doc/StringObj.3
@@ -37,7 +37,7 @@ Tcl_UniChar *
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
-Tcl_UniChar
+int
\fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
.sp
int
@@ -111,17 +111,19 @@ If negative, all characters up to the first null character are used.
The index of the Unicode character to return.
.AP int first in
The index of the first Unicode character in the Unicode range to be
-returned as a new value.
+returned as a new value. If negative, behave the same as if the
+value was 0.
.AP int last in
The index of the last Unicode character in the Unicode range to be
-returned as a new value.
+returned as a new value. If negative, 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 int *lengthPtr out
-If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
-the length of a value's string representation.
+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
@@ -204,8 +206,8 @@ where the caller does not need the length of the unicode string
representation.
.PP
\fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the
-value's Unicode representation. The index is assumed to be in the
-appropriate range.
+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
@@ -251,7 +253,9 @@ must be a NULL pointer to indicate the end of the list.
.PP
\fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR
except that instead of taking a variable number of arguments it takes an
-argument list.
+argument list. Interfaces using argument lists have been found to be
+nonportable in practice. This function is deprecated and will be removed
+in Tcl 9.0.
.PP
\fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it imposes a limit on how many bytes are appended.
@@ -383,6 +387,33 @@ white space, then that value is ignored entirely. This white-space
removal was added to make the output of the \fBconcat\fR command
cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a
newly-created value whose ref count is zero.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR,
+\fBTcl_ObjPrintf\fR, and \fBTcl_ConcatObj\fR always return a zero-reference
+object, much like \fBTcl_NewObj\fR.
+.PP
+\fBTcl_GetStringFromObj\fR, \fBTcl_GetString\fR, \fBTcl_GetUnicodeFromObj\fR,
+\fBTcl_GetUnicode\fR, \fBTcl_GetUniChar\fR, \fBTcl_GetCharLength\fR, and
+\fBTcl_GetRange\fR all only work with an existing value; they do not
+manipulate its reference count in any way.
+.PP
+\fBTcl_SetStringObj\fR, \fBTcl_SetUnicodeObj\fR, \fBTcl_AppendToObj\fR,
+\fBTcl_AppendUnicodeToObj\fR, \fBTcl_AppendObjToObj\fR,
+\fBTcl_AppendStringsToObj\fR, \fBTcl_AppendStringsToObjVA\fR,
+\fBTcl_AppendLimitedToObj\fR, \fBTcl_AppendFormatToObj\fR,
+\fBTcl_AppendPrintfToObj\fR, \fBTcl_SetObjLength\fR, and
+\fBTcl_AttemptSetObjLength\fR and require their \fIobjPtr\fR to be an unshared
+value (i.e, a reference count no more than 1) as they will modify it.
+.PP
+Additional arguments to the above functions (the \fIappendObjPtr\fR argument
+to \fBTcl_AppendObjToObj\fR, values in the \fIobjv\fR argument to
+\fBTcl_Format\fR, \fBTcl_AppendFormatToObj\fR, and \fBTcl_ConcatObj\fR) can
+have any reference count, but reference counts of zero are not recommended.
+.PP
+\fBTcl_Format\fR and \fBTcl_AppendFormatToObj\fR may modify the interpreter
+result, which involves changing the reference count of a value.
+
.SH "SEE ALSO"
Tcl_NewObj(3), Tcl_IncrRefCount(3), Tcl_DecrRefCount(3), format(n), sprintf(3)
.SH KEYWORDS
diff --git a/doc/SubstObj.3 b/doc/SubstObj.3
index ca6822b..f10e01d 100644
--- a/doc/SubstObj.3
+++ b/doc/SubstObj.3
@@ -62,6 +62,13 @@ result of the whole substitution on \fIobjPtr\fR will be truncated at
the point immediately before the start of the command substitution,
and no characters will be added to the result or substitutions
performed after that point.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIobjPtr\fR argument to \fBTcl_SubstObj\fR must not have a reference
+count of zero. This function modifies the interpreter result, both on success
+and on failure; the result of this function on success is exactly the current
+interpreter result. Successful results should have their reference count
+incremented if they are to be retained.
.SH "SEE ALSO"
subst(n)
.SH KEYWORDS
diff --git a/doc/Tcl.n b/doc/Tcl.n
index 3e809fa..99af4df 100644
--- a/doc/Tcl.n
+++ b/doc/Tcl.n
@@ -1,6 +1,7 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2023 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,176 +17,152 @@ Summary of Tcl language syntax.
.SH DESCRIPTION
.PP
The following rules define the syntax and semantics of the Tcl language:
-.IP "[1] \fBCommands.\fR"
-A Tcl script is a string containing one or more commands.
-Semi-colons and newlines are command separators unless quoted as
-described below.
-Close brackets are command terminators during command substitution
-(see below) unless quoted.
-.IP "[2] \fBEvaluation.\fR"
-A command is evaluated in two steps.
-First, the Tcl interpreter breaks the command into \fIwords\fR
-and performs substitutions as described below.
-These substitutions are performed in the same way for all
-commands.
-Secondly, the first word is used to locate a command procedure to
-carry out the command, then all of the words of the command are
-passed to the command procedure.
-The command procedure is free to interpret each of its words
-in any way it likes, such as an integer, variable name, list,
-or Tcl script.
-Different commands interpret their words differently.
-.IP "[3] \fBWords.\fR"
-Words of a command are separated by white space (except for
-newlines, which are command separators).
-.IP "[4] \fBDouble quotes.\fR"
-If the first character of a word is double-quote
+.
+.IP "[1] \fBScript.\fR"
+A script is composed of zero or more commands delimited by semi-colons or
+newlines.
+.IP "[2] \fBCommand.\fR"
+A command is composed of zero or more words delimited by whitespace. The
+replacement for a substitution is included verbatim in the word. For example, a
+space in the replacement is included in the word rather than becoming a
+delimiter, and \fI\\\\\fR becomes a single backslash in the word. Each word is
+processed from left to right and each substitution is performed as soon as it
+is complete.
+For example, the command
+.RS
+.PP
+.CS
+set y [set x 0][incr x][incr x]
+.CE
+.PP
+is composed of three words, and sets the value of \fIy\fR to \fI012\fR.
+.PP
+If hash
+.PQ #
+is the first character of what would otherwise be the first word of a command,
+all characters up to the next newline are ignored.
+.RE
+.
+.IP "[3] \fBBraced word.\fR"
+If a word is enclosed in braces
+.PQ {
+and
+.PQ } ""
+, the braces are removed and the enclosed characters become the word. No
+substitutions are performed. Nested pairs of braces may occur within the word.
+A brace preceded by an odd number of backslashes is not considered part of a
+pair, and neither brace nor the backslashes are removed from the word.
+.
+.IP "[4] \fBQuoted word.\fR"
+If a word is enclosed in double quotes
.PQ \N'34'
-then the word is terminated by the next double-quote character.
-If semi-colons, close brackets, or white space characters
-(including newlines) appear between the quotes then they are treated
-as ordinary characters and included in the word.
-Command substitution, variable substitution, and backslash substitution
-are performed on the characters between the quotes as described below.
-The double-quotes are not retained as part of the word.
-.IP "[5] \fBArgument expansion.\fR"
-If a word starts with the string
-.QW {*}
-followed by a non-whitespace character, then the leading
+, the double quotes are removed and the enclosed characters become the word.
+Substitutions are performed.
+.
+.IP "[5] \fBList.\fR"
+A list has the form of a single command. Newline is whitespace, and semicolon
+has no special interpretation. There is no script evaluation so there is no
+argument expansion, variable substitution, or command substitution: Dollar-sign
+and open bracket have no special interpretation, and what would be argument
+expansion in a script is invalid in a list.
+.
+.IP "[6] \fBArgument expansion.\fR"
+If
.QW {*}
-is removed and the rest of the word is parsed and substituted as any other
-word. After substitution, the word is parsed as a list (without command or
-variable substitutions; backslash substitutions are performed as is normal for
-a list and individual internal words may be surrounded by either braces or
-double-quote characters), and its words are added to the command being
-substituted. For instance,
-.QW "cmd a {*}{b [c]} d {*}{$e f {g h}}"
+prefixes a word, it is removed. After any remaining enclosing braces or quotes
+are processed and applicable substitutions performed, the word, which must
+be a list, is removed from the command, and in its place each word in the
+list becomes an additional word in the command. For example,
+.CS
+cmd a {*}{b [c]} d {*}{$e f {g h}}
+.CE
is equivalent to
-.QW "cmd a b {[c]} d {$e} f {g h}" .
-.IP "[6] \fBBraces.\fR"
-If the first character of a word is an open brace
-.PQ {
-and rule [5] does not apply, then
-the word is terminated by the matching close brace
-.PQ } "" .
-Braces nest within the word: for each additional open
-brace there must be an additional close brace (however,
-if an open brace or close brace within the word is
-quoted with a backslash then it is not counted in locating the
-matching close brace).
-No substitutions are performed on the characters between the
-braces except for backslash-newline substitutions described
-below, nor do semi-colons, newlines, close brackets,
-or white space receive any special interpretation.
-The word will consist of exactly the characters between the
-outer braces, not including the braces themselves.
-.IP "[7] \fBCommand substitution.\fR"
-If a word contains an open bracket
+.CS
+cmd a b {[c]} d {$e} f {g h} .
+.CE
+.
+.IP "[7] \fBEvaluation.\fR"
+To evaluate a script, an interpreter evaluates each successive command. The
+first word identifies a procedure, and the remaining words are passed to that
+procedure for further evaluation. The procedure interprets each argument in
+its own way, e.g. as an integer, variable name, list, mathematical expression,
+script, or in some other arbitrary way. The result of the last command is the
+result of the script.
+.
+.IP "[8] \fBCommand substitution.\fR"
+Each pair of brackets
.PQ [
-then Tcl performs \fIcommand substitution\fR.
-To do this it invokes the Tcl interpreter recursively to process
-the characters following the open bracket as a Tcl script.
-The script may contain any number of commands and must be terminated
-by a close bracket
-.PQ ] "" .
-The result of the script (i.e. the result of its last command) is
-substituted into the word in place of the brackets and all of the
-characters between them.
-There may be any number of command substitutions in a single word.
-Command substitution is not performed on words enclosed in braces.
-.IP "[8] \fBVariable substitution.\fR"
-If a word contains a dollar-sign
+and
+.PQ ] ""
+encloses a script and is replaced by the result of that script.
+.IP "[9] \fBVariable substitution.\fR"
+Each of the following forms begins with dollar sign
.PQ $
-followed by one of the forms
-described below, then Tcl performs \fIvariable
-substitution\fR: the dollar-sign and the following characters are
-replaced in the word by the value of a variable.
-Variable substitution may take any of the following forms:
+and is replaced by the value of the identified variable. \fIname\fR names the
+variable and is composed of ASCII letters (\fBA\fR\(en\fBZ\fR and
+\fBa\fR\(en\fBz\fR), digits (\fB0\fR\(en\fB9\fR), underscores, or namespace
+delimiters (two or more colons). \fIindex\fR is the name of an individual
+variable within an array variable, and may be empty.
.RS
.TP 15
\fB$\fIname\fR
.
-\fIName\fR is the name of a scalar variable; the name is a sequence
-of one or more characters that are a letter, digit, underscore,
-or namespace separators (two or more colons).
-Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR,
-\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR).
+\fIname\fR may not be empty.
+
.TP 15
\fB$\fIname\fB(\fIindex\fB)\fR
.
-\fIName\fR gives the name of an array variable and \fIindex\fR gives
-the name of an element within that array.
-\fIName\fR must contain only letters, digits, underscores, and
-namespace separators, and may be an empty string.
-Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR,
-\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR).
-Command substitutions, variable substitutions, and backslash
-substitutions are performed on the characters of \fIindex\fR.
+\fIname\fR may be empty. Substitutions are performed on \fIindex\fR.
.TP 15
\fB${\fIname\fB}\fR
+\fIname\fR may be empty.
+.TP 15
+\fB${\fIname(index)\fB}\fR
.
-\fIName\fR is the name of a scalar variable or array element. It may contain
-any characters whatsoever except for close braces. It indicates an array
-element if \fIname\fR is in the form
-.QW \fIarrayName\fB(\fIindex\fB)\fR
-where \fIarrayName\fR does not contain any open parenthesis characters,
-.QW \fB(\fR ,
-or close brace characters,
-.QW \fB}\fR ,
-and \fIindex\fR can be any sequence of characters except for close brace
-characters. No further
-substitutions are performed during the parsing of \fIname\fR.
-.PP
-There may be any number of variable substitutions in a single word.
-Variable substitution is not performed on words enclosed in braces.
-.PP
-Note that variables may contain character sequences other than those listed
-above, but in that case other mechanisms must be used to access them (e.g.,
-via the \fBset\fR command's single-argument form).
+\fIname\fR may be empty. No substitutions are performed.
.RE
-.IP "[9] \fBBackslash substitution.\fR"
-If a backslash
+Variables that are not accessible through one of the forms above may be
+accessed through other mechanisms, e.g. the \fBset\fR command.
+.IP "[10] \fBBackslash substitution.\fR"
+Each backslash
.PQ \e
-appears within a word then \fIbackslash substitution\fR occurs.
-In all cases but those described below the backslash is dropped and
-the following character is treated as an ordinary
-character and included in the word.
-This allows characters such as double quotes, close brackets,
-and dollar signs to be included in words without triggering
-special processing.
-The following table lists the backslash sequences that are
-handled specially, along with the value that replaces each sequence.
+that is not part of one of the forms listed below is removed, and the next
+character is included in the word verbatim, which allows the inclusion of
+characters that would normally be interpreted, namely whitespace, braces,
+brackets, double quote, dollar sign, and backslash. The following sequences
+are replaced as described:
+.RS
+.RS
.RS
.TP 7
\e\fBa\fR
-Audible alert (bell) (Unicode U+000007).
+Audible alert (bell) (U+7).
.TP 7
\e\fBb\fR
-Backspace (Unicode U+000008).
+Backspace (U+8).
.TP 7
\e\fBf\fR
-Form feed (Unicode U+00000C).
+Form feed (U+C).
.TP 7
\e\fBn\fR
-Newline (Unicode U+00000A).
+Newline (U+A).
.TP 7
\e\fBr\fR
-Carriage-return (Unicode U+00000D).
+Carriage-return (U+D).
.TP 7
\e\fBt\fR
-Tab (Unicode U+000009).
+Tab (U+9).
.TP 7
\e\fBv\fR
-Vertical tab (Unicode U+00000B).
+Vertical tab (U+B).
.TP 7
\e\fB<newline>\fIwhiteSpace\fR
.
-A single space character replaces the backslash, newline, and all spaces
-and tabs after the newline. This backslash sequence is unique in that it
-is replaced in a separate prepass before the command is actually parsed.
-This means that it will be replaced even when it occurs between braces,
-and the resulting space will be treated as a word separator if it is not
-in braces or quotes.
+Newline preceded by an odd number of backslashes, along with the consecutive
+spaces and tabs that immediately follow it, is replaced by a single space.
+Because this happens before the command is split into words, it occurs even
+within braced words, and if the resulting space may subsequently be treated as
+a word delimiter.
.TP 7
\e\e
Backslash
@@ -193,80 +170,30 @@ Backslash
.TP 7
\e\fIooo\fR
.
-The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal
-value for the Unicode character that will be inserted, in the range
-\fI000\fR\(en\fI377\fR (i.e., the range U+000000\(enU+0000FF).
-The parser will stop just before this range overflows, or when
-the maximum of three digits is reached. The upper bits of the Unicode
-character will be 0.
+Up to three octal digits form an eight-bit value for a Unicode character in the
+range \fI0\fR\(en\fI377\fR, i.e. U+0\(enU+FF. Only the digits that result in a
+number in this range are consumed.
.TP 7
\e\fBx\fIhh\fR
.
-The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit
-hexadecimal value for the Unicode character that will be inserted. The upper
-bits of the Unicode character will be 0 (i.e., the character will be in the
-range U+000000\(enU+0000FF).
+Up to two hexadecimal digits form an eight-bit value for a Unicode character in
+the range \fI0\fR\(en\fIFF\fR.
.TP 7
\e\fBu\fIhhhh\fR
.
-The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a
-sixteen-bit hexadecimal value for the Unicode character that will be
-inserted. The upper bits of the Unicode character will be 0 (i.e., the
-character will be in the range U+000000\(enU+00FFFF).
+Up to four hexadecimal digits form a 16-bit value for a Unicode character in
+the range \fI0\fR\(en\fIFFFF\fR.
.TP 7
\e\fBU\fIhhhhhhhh\fR
.
-The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a
-twenty-one-bit hexadecimal value for the Unicode character that will be
-inserted, in the range U+000000\(enU+10FFFF. The parser will stop just
-before this range overflows, or when the maximum of eight digits
-is reached. The upper bits of the Unicode character will be 0.
-.RS
-.PP
-The range U+010000\(enU+10FFFD is reserved for the future.
+Up to eight hexadecimal digits form a 21-bit value for a Unicode character in
+the range \fI0\fR\(en\fI10FFFF\fR. Only the digits that result in a number in
+this range are consumed.
.RE
-.PP
-Backslash substitution is not performed on words enclosed in braces,
-except for backslash-newline as described above.
.RE
-.IP "[10] \fBComments.\fR"
-If a hash character
-.PQ #
-appears at a point where Tcl is
-expecting the first character of the first word of a command,
-then the hash character and the characters that follow it, up
-through the next newline, are treated as a comment and ignored.
-The comment character only has significance when it appears
-at the beginning of a command.
-.IP "[11] \fBOrder of substitution.\fR"
-Each character is processed exactly once by the Tcl interpreter
-as part of creating the words of a command.
-For example, if variable substitution occurs then no further
-substitutions are performed on the value of the variable; the
-value is inserted into the word verbatim.
-If command substitution occurs then the nested command is
-processed entirely by the recursive call to the Tcl interpreter;
-no substitutions are performed before making the recursive
-call and no additional substitutions are performed on the result
-of the nested script.
-.RS
.PP
-Substitutions take place from left to right, and each substitution is
-evaluated completely before attempting to evaluate the next. Thus, a
-sequence like
-.PP
-.CS
-set y [set x 0][incr x][incr x]
-.CE
-.PP
-will always set the variable \fIy\fR to the value, \fI012\fR.
.RE
-.IP "[12] \fBSubstitution and word boundaries.\fR"
-Substitutions do not affect the word boundaries of a command,
-except for argument expansion as specified in rule [5].
-For example, during variable substitution the entire value of
-the variable becomes part of a single word, even if the variable's
-value contains spaces.
+.
.SH KEYWORDS
backslash, command, comment, script, substitution, variable
'\" Local Variables:
diff --git a/doc/TclZlib.3 b/doc/TclZlib.3
index 4a5df89..c2d7f6d 100644
--- a/doc/TclZlib.3
+++ b/doc/TclZlib.3
@@ -188,7 +188,7 @@ is used to initialize the compression engine rather than leaving it to create
it on the fly from the data being compressed. Setting a compression dictionary
allows for more efficient compression in the case where the start of the data
is highly regular, but it does require both the compressor and the
-decompressor to agreee on the value to use. Compression dictionaries are only
+decompressor to agree on the value to use. Compression dictionaries are only
fully supported for zlib-format data; on compression, they must be set before
any data is sent in with \fBTcl_ZlibStreamPut\fR, and on decompression they
should be set when \fBTcl_ZlibStreamGet\fR produces an \fBerror\fR with its
@@ -262,6 +262,31 @@ file named by the \fBfilename\fR field was modified. Suitable for use with
.
The type of the uncompressed data (either \fBbinary\fR or \fBtext\fR) if
known.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_ZlibDeflate\fR and \fBTcl_ZlibInflate\fR take a value with arbitrary
+reference count for their \fIdataObj\fR and \fIdictObj\fR arguments (the
+latter often being NULL instead), and set the interpreter result with their
+output value (or an error). The existing interpreter result should not be
+passed as any argument value unless an additional reference is held.
+.PP
+\fBTcl_ZlibStreamInit\fR takes a value with arbitrary reference count for its
+\fIdictObj\fR argument; it only reads from it. The existing interpreter result
+should not be passed unless an additional reference is held.
+.PP
+\fBTcl_ZlibStreamGetCommandName\fR returns a zero reference count value, much
+like \fBTcl_NewObj\fR.
+.PP
+The \fIdataObj\fR argument to \fBTcl_ZlibStreamPut\fR is a value with
+arbitrary reference count; it is only ever read from.
+.PP
+The \fIdataObj\fR argument to \fBTcl_ZlibStreamGet\fR is an unshared value
+(see \fBTcl_IsShared\fR) that will be updated by the function.
+.PP
+The \fIcompDict\fR argument to \fBTcl_ZlibStreamSetCompressionDictionary\fR,
+if non-NULL, may be duplicated or may have its reference count incremented.
+Using a zero reference count value is not recommended.
+
.SH "PORTABILITY NOTES"
These functions will fail gracefully if Tcl is not linked with the zlib
library.
diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3
index 8104ece..6a37cda 100644
--- a/doc/Tcl_Main.3
+++ b/doc/Tcl_Main.3
@@ -85,8 +85,10 @@ that does nothing but invoke \fBTcl_Main\fR.
.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. Extensions (stub-enabled or
-not) are not intended to call \fBTcl_Main\fR.
+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
@@ -199,6 +201,17 @@ procedure (if any) returns. In non-interactive mode, after
\fBTcl_Main\fR evaluates the startup script, and the main loop
procedure (if any) returns, \fBTcl_Main\fR will also evaluate
the \fBexit\fR command.
+.PP
+\fBTcl_Main\fR can not be used in stub-enabled extensions.
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+\fBTcl_SetStartupScript\fR takes a value (or NULL) for its \fIpath\fR
+argument, and will increment the reference count of it.
+.PP
+\fBTcl_GetStartupScript\fR returns a value with reference count at least 1, or
+NULL. It's \fIencodingPtr\fR is also used (if non-NULL) to return a value with
+a reference count at least 1, or NULL. In both cases, the owner of the values
+is the current thread.
.SH "SEE ALSO"
tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3),
exit(n), encoding(n)
diff --git a/doc/Thread.3 b/doc/Thread.3
index 5966a71..ac60230 100644
--- a/doc/Thread.3
+++ b/doc/Thread.3
@@ -45,7 +45,9 @@ int
.AP Tcl_Condition *condPtr in
A condition variable, which must be associated with a mutex lock.
.AP Tcl_Mutex *mutexPtr in
-A mutex lock.
+.VS TIP509
+A recursive mutex lock.
+.VE TIP509
.AP "const Tcl_Time" *timePtr in
A time limit on the condition wait. NULL to wait forever.
Note that a polling value of 0 seconds does not make much sense.
@@ -67,7 +69,7 @@ This procedure will act as the \fBmain()\fR of the newly created
thread. The specified \fIclientData\fR will be its sole argument.
.AP ClientData clientData in
Arbitrary information. Passed as sole argument to the \fIproc\fR.
-.AP int stackSize in
+.AP unsigned stackSize in
The size of the stack given to the new thread.
.AP int flags in
Bitmask containing flags allowing the caller to modify behavior of
@@ -140,8 +142,12 @@ of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR.
If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will
block until \fBTcl_MutexUnlock\fR is called.
A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR.
-The result of locking a mutex twice from the same thread is undefined.
-On some platforms it will result in a deadlock.
+.VS TIP509
+Mutexes are reentrant: they can be locked several times from the same
+thread. However there must be exactly one call to
+\fBTcl_MutexUnlock\fR for each call to \fBTcl_MutexLock\fR in order
+for a thread to release a mutex completely.
+.VE TIP509
The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR
procedures are defined as empty macros if not compiling with threads enabled.
For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used.
diff --git a/doc/ToUpper.3 b/doc/ToUpper.3
index a281e2c..37ebd2b 100644
--- a/doc/ToUpper.3
+++ b/doc/ToUpper.3
@@ -13,13 +13,13 @@ Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_
.nf
\fB#include <tcl.h>\fR
.sp
-Tcl_UniChar
+int
\fBTcl_UniCharToUpper\fR(\fIch\fR)
.sp
-Tcl_UniChar
+int
\fBTcl_UniCharToLower\fR(\fIch\fR)
.sp
-Tcl_UniChar
+int
\fBTcl_UniCharToTitle\fR(\fIch\fR)
.sp
int
@@ -78,12 +78,5 @@ turns each character in the string into its lower-case equivalent.
turns the first character in the string into its title-case equivalent
and all following characters into their lower-case equivalents.
-.SH BUGS
-.PP
-At this time, the case conversions are only defined for the Unicode
-plane 0 characters. The result for Unicode characters above 0xFFFF
-is undefined, but - actually - only the lower 16 bits of the
-character value is handled.
-
.SH KEYWORDS
utf, unicode, toupper, tolower, totitle, case
diff --git a/doc/TraceVar.3 b/doc/TraceVar.3
index 3d506b3..5de6a44 100644
--- a/doc/TraceVar.3
+++ b/doc/TraceVar.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
+.TH Tcl_TraceVar 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
@@ -95,7 +95,7 @@ Invoke \fIproc\fR whenever an attempt is made to modify the variable.
Invoke \fIproc\fR whenever the variable is unset.
A variable may be unset either explicitly by an \fBunset\fR command,
or implicitly when a procedure returns (its local variables are
-automatically unset) or when the interpreter is deleted (all
+automatically unset) or when the interpreter or namespace is deleted (all
variables are automatically unset).
.TP
\fBTCL_TRACE_ARRAY\fR
@@ -160,10 +160,6 @@ The bit \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is
about to be destroyed; this information may be useful to \fIproc\fR
so that it can clean up its own internal data structures (see
the section \fBTCL_TRACE_DESTROYED\fR below for more details).
-Lastly, the bit \fBTCL_INTERP_DESTROYED\fR will be set if the entire
-interpreter is being destroyed.
-When this bit is set, \fIproc\fR must be especially careful in
-the things it does (see the section \fBTCL_INTERP_DESTROYED\fR below).
The trace procedure's return value should normally be NULL; see
\fBERROR RETURNS\fR below for information on other possibilities.
.PP
@@ -330,6 +326,15 @@ During unset traces, the return value is ignored and all relevant
trace procedures will always be invoked.
.SH "RESTRICTIONS"
.PP
+Because operations on variables may take place as part of the deletion
+of the interp that contains them, \fIproc\fR must be careful about checking
+what the \fIinterp\fR parameter can be used to do.
+The routine \fBTcl_InterpDeleted\fR is an important tool for this.
+When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able
+to invoke any scripts in \fIinterp\fR. You may encounter old code using
+a deprecated flag value \fBTCL_INTERP_DESTROYED\fR to signal this
+condition, but any supported code should be converted to stop using it.
+.PP
A trace procedure can be called at any time, even when there
are partially formed results stored in the interpreter. If
the trace procedure does anything that could damage this result (such
@@ -354,24 +359,16 @@ Traces on a variable are always removed whenever the variable
is deleted; the only time \fBTCL_TRACE_DESTROYED\fR is not set is for
a whole-array trace invoked when only a single element of an
array is unset.
-.SH "TCL_INTERP_DESTROYED"
+.SH "REFERENCE COUNT MANAGEMENT"
.PP
-When an interpreter is destroyed, unset traces are called for
-all of its variables.
-The \fBTCL_INTERP_DESTROYED\fR bit will be set in the \fIflags\fR
-argument passed to the trace procedures.
-Trace procedures must be extremely careful in what they do if
-the \fBTCL_INTERP_DESTROYED\fR bit is set.
-It is not safe for the procedures to invoke any Tcl procedures
-on the interpreter, since its state is partially deleted.
-All that trace procedures should do under these circumstances is
-to clean up and free their own internal data structures.
+When a \fIproc\fR callback is invoked, and that callback was installed with
+the \fBTCL_TRACE_RESULT_OBJECT\fR flag, the result of the callback is a
+Tcl_Obj reference when there is an error. The result will have its reference
+count decremented once when no longer needed, or may have additional
+references made to it (e.g., by setting it as the interpreter result with
+\fBTcl_SetObjResult\fR).
.SH BUGS
.PP
-Tcl does not do any error checking to prevent trace procedures
-from misusing the interpreter during traces with \fBTCL_INTERP_DESTROYED\fR
-set.
-.PP
Array traces are not yet integrated with the Tcl \fBinfo exists\fR command,
nor is there Tcl-level access to array traces.
.SH "SEE ALSO"
diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3
index 5ba3fc9..a07af9a 100644
--- a/doc/UniCharIsAlpha.3
+++ b/doc/UniCharIsAlpha.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters
+Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsUnicode, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -44,11 +44,14 @@ int
\fBTcl_UniCharIsUpper\fR(\fIch\fR)
.sp
int
+\fBTcl_UniCharIsUnicode\fR(\fIch\fR)
+.sp
+int
\fBTcl_UniCharIsWordChar\fR(\fIch\fR)
.SH ARGUMENTS
.AS int ch
.AP int ch in
-The Tcl_UniChar to be examined.
+The Unicode character to be examined.
.BE
.SH DESCRIPTION
@@ -81,6 +84,9 @@ with the various routines.
.PP
\fBTcl_UniCharIsUpper\fR tests if the character is an uppercase Unicode character.
.PP
+\fBTcl_UniCharIsUnicode\fR tests if the character is a Unicode character, not being
+a surrogate or noncharacter.
+.PP
\fBTcl_UniCharIsWordChar\fR tests if the character is alphanumeric or
a connector punctuation mark.
diff --git a/doc/Utf.3 b/doc/Utf.3
index 647de5c..069a612 100644
--- a/doc/Utf.3
+++ b/doc/Utf.3
@@ -8,7 +8,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
+Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_WCharToUtfDString, Tcl_WCharLen, Tcl_Char16Len, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -21,11 +21,35 @@ int
int
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
.sp
+int
+\fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR)
+.sp
+int
+\fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR)
+.sp
+char *
+\fBTcl_UniCharToUtfDString\fR(\fIuniStr, numUniChars, dsPtr\fR)
+.sp
+char *
+\fBTcl_Char16ToUtfDString\fR(\fIutf16, numUtf16, dsPtr\fR)
+.sp
char *
-\fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR)
+\fBTcl_WCharToUtfDString\fR(\fIwcharStr, numWChars, dsPtr\fR)
.sp
Tcl_UniChar *
-\fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR)
+\fBTcl_UtfToUniCharDString\fR(\fIsrc, numBytes, dsPtr\fR)
+.sp
+unsigned short *
+\fBTcl_UtfToChar16DString\fR(\fIsrc, numBytes, dsPtr\fR)
+.sp
+wchar_t *
+\fBTcl_UtfToWCharDString\fR(\fIsrc, numBytes, dsPtr\fR)
+.sp
+int
+\fBTcl_Char16Len\fR(\fIutf16\fR)
+.sp
+int
+\fBTcl_WCharLen\fR(\fIwcharStr\fR)
.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
@@ -46,10 +70,10 @@ int
\fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR)
.sp
int
-\fBTcl_UtfCharComplete\fR(\fIsrc, length\fR)
+\fBTcl_UtfCharComplete\fR(\fIsrc, numBytes\fR)
.sp
int
-\fBTcl_NumUtfChars\fR(\fIsrc, length\fR)
+\fBTcl_NumUtfChars\fR(\fIsrc, numBytes\fR)
.sp
const char *
\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR)
@@ -63,7 +87,7 @@ const char *
const char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)
.sp
-Tcl_UniChar
+int
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
.sp
const char *
@@ -75,11 +99,15 @@ int
.AS "const Tcl_UniChar" *uniPattern in/out
.AP char *buf out
Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most
-\fBTCL_UTF_MAX\fR bytes are stored in the buffer.
+4 bytes are stored in the buffer.
.AP int ch in
The Unicode character to be converted or examined.
.AP Tcl_UniChar *chPtr out
Filled with the Tcl_UniChar represented by the head of the UTF-8 string.
+.AP unsigned short *uPtr out
+Filled with the utf-16 represented by the head of the UTF-8 string.
+.AP wchar_t *wPtr out
+Filled with the wchar_t represented by the head of the UTF-8 string.
.AP "const char" *src in
Pointer to a UTF-8 string.
.AP "const char" *cs in
@@ -87,19 +115,32 @@ Pointer to a UTF-8 string.
.AP "const char" *ct in
Pointer to a UTF-8 string.
.AP "const Tcl_UniChar" *uniStr in
-A null-terminated Unicode string.
+A sequence of \fBTcl_UniChar\fR units with null-termination optional
+depending on function.
.AP "const Tcl_UniChar" *ucs in
-A null-terminated Unicode string.
+A null-terminated sequence of \fBTcl_UniChar\fR.
.AP "const Tcl_UniChar" *uct in
-A null-terminated Unicode string.
+A null-terminated sequence of \fBTcl_UniChar\fR.
.AP "const Tcl_UniChar" *uniPattern in
-A null-terminated Unicode string.
-.AP int length in
-The length of the UTF-8 string in bytes (not UTF-8 characters). If
-negative, all bytes up to the first null byte are used.
-.AP int uniLength in
-The length of the Unicode string in characters. Must be greater than or
-equal to 0.
+A null-terminated sequence of \fBTcl_UniChar\fR.
+.AP "const unsigned short" *utf16 in
+A sequence of UTF-16 units with null-termination optional
+depending on function.
+.AP "const wchar_t" *wcharStr in
+A sequence of \fBwchar_t\fR units with null-termination optional
+depending on function.
+.AP int numBytes in
+The length of the UTF-8 input in bytes. If
+negative, the length includes all bytes until the first null byte.
+.AP int numUtf16 in
+The length of the input in UTF-16 units.
+If negative, the length includes all bytes until the first null.
+.AP int numUniChars in
+The length of the input in Tcl_UniChar units.
+If negative, the length includes all bytes until the first null.
+.AP int numWChars in
+The length of the input in wchar_t units.
+If negative, the length includes all bytes until the first null.
.AP "Tcl_DString" *dsPtr in/out
A pointer to a previously initialized \fBTcl_DString\fR.
.AP "unsigned long" numChars in
@@ -113,7 +154,7 @@ If non-NULL, filled with the number of bytes in the backslash sequence,
including the backslash character.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
-At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
+At most 4 bytes are stored in the buffer.
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
@@ -121,18 +162,21 @@ case-insensitive (1).
.SH DESCRIPTION
.PP
-These routines convert between UTF-8 strings and Tcl_UniChars. A
-Tcl_UniChar is a Unicode character represented as an unsigned, fixed-size
-quantity. A UTF-8 character is a Unicode character represented as
-a varying-length sequence of up to \fBTCL_UTF_MAX\fR bytes. A multibyte UTF-8
-sequence consists of a lead byte followed by some number of trail bytes.
+These routines convert between UTF-8 strings and Unicode/Utf-16 characters.
+A UTF-8 character is a Unicode character represented as a varying-length
+sequence of up to \fB4\fR bytes. A multibyte UTF-8 sequence
+consists of a lead byte followed by some number of trail bytes.
.PP
-\fBTCL_UTF_MAX\fR is the maximum number of bytes that it takes to
-represent one Unicode character in the UTF-8 representation.
+\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 Tcl_UniChar \fIch\fR as a UTF-8 string
+\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.
+in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then
+the return value will be 1 and a single byte in the range 0xF0 - 0xF4
+will be stored. If you still want to produce UTF-8 output for it (even
+though knowing it's an illegal code-point on its own), just call
+\fBTcl_UniCharToUtf\fR again specifying ch = -1.
.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
@@ -140,27 +184,39 @@ 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
+a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the
+cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR
+and returns 1. If the input is otherwise
not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first
-byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x80 and
-0xFF and return 1.
+byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x00A0 and
+0x00FF and return 1.
+.PP
+\fBTcl_UniCharToUtfDString\fR converts the input in the form of a
+sequence of \fBTcl_UniChar\fR code points to UTF-8, appending the result to the
+previously initialized output \fBTcl_DString\fR. The return value is a pointer
+to the UTF-8 representation of the \fBappended\fR string.
+.PP
+\fBTcl_UtfToUniCharDString\fR converts the input in the form of
+a UTF-8 encoded string to a \fBTcl_UniChar\fR sequence
+appending the result in the previously initialized \fBTcl_DString\fR.
+The return value is a pointer to the appended result which is also
+terminated with a \fBTcl_UniChar\fR null character.
+.PP
+\fBTcl_WCharToUtfDString\fR and \fBTcl_UtfToWCharDString\fR are similar to
+\fBTcl_UniCharToUtfDString\fR and \fBTcl_UtfToUniCharDString\fR except they
+operate on sequences of \fBwchar_t\fR instead of \fBTcl_UniChar\fR.
+.PP
+\fBTcl_Char16ToUtfDString\fR and \fBTcl_UtfToChar16DString\fR are similar to
+\fBTcl_UniCharToUtfDString\fR and \fBTcl_UtfToUniCharDString\fR except they
+operate on sequences of \fBUTF-16\fR units instead of \fBTcl_UniChar\fR.
.PP
-\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
-to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR.
-You must specify \fIuniLength\fR, the length of the given Unicode string.
-The return value is a pointer to the UTF-8 representation of the
-Unicode string. Storage for the return value is appended to the
-end of the \fBTcl_DString\fR.
+\fBTcl_Char16Len\fR corresponds to \fBstrlen\fR for UTF-16
+characters. It accepts a null-terminated UTF-16 sequence and returns
+the number of UTF-16 units until the null.
.PP
-\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
-storing the result in the previously initialized \fBTcl_DString\fR.
-In the argument \fIlength\fR, you may either specify the length of
-the given UTF-8 string in bytes or
-.QW \-1 ,
-in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
-calculate the length. The return value is a pointer to the Unicode
-representation of the UTF-8 string. Storage for the return value
-is appended to the end of the \fBTcl_DString\fR. The Unicode string
-is terminated with a Unicode null character.
+\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t
+characters. It accepts a null-terminated \fBwchar_t\fR sequence and returns
+the number of \fBwchar_t\fR units until the null.
.PP
\fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode
characters. It accepts a null-terminated Unicode string and returns
@@ -196,11 +252,11 @@ differences in case when comparing upper, lower or title case
characters.
.PP
\fBTcl_UtfCharComplete\fR returns 1 if the source UTF-8 string \fIsrc\fR
-of \fIlength\fR bytes is long enough to be decoded by
+of \fInumBytes\fR bytes is long enough to be decoded by
\fBTcl_UtfToUniChar\fR/\fBTcl_UtfNext\fR, or 0 otherwise. This function
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 Tcl_UniChar has been seen.
+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
@@ -208,12 +264,12 @@ returns the number of Tcl_UniChars that are represented by the UTF-8 string
length is negative, 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 Tcl_UniChar \fIch\fR
+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
-returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR
+returns a pointer to the last 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
@@ -239,29 +295,33 @@ always a pointer to a location in the string. It always returns a pointer to
a byte that begins a character when scanning for characters beginning
from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it
always returns a pointer less than \fIsrc\fR and greater than or
-equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins
+equal to (\fIsrc\fR - 4). The character that begins
at the returned pointer is the first one that either includes the
byte \fIsrc[-1]\fR, or might include it if the right trail bytes are
present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the
byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte
-\fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR.
+\fIsrc[-5]\fR.
.PP
\fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the
-Pascal Ord() function. It returns the Tcl_UniChar represented at the
+Pascal Ord() function. It returns the Unicode character represented at the
specified character (not byte) \fIindex\fR in the UTF-8 string
\fIsrc\fR. The source string must contain at least \fIindex\fR
-characters. Behavior is undefined if a negative \fIindex\fR is given.
+characters. If a negative \fIindex\fR is given or \fIindex\fR points
+to the second half of a surrogate pair, it returns -1.
.PP
\fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not
byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must
contain at least \fIindex\fR characters. This is equivalent to calling
-\fBTcl_UtfToUniChar\fR \fIindex\fR times. If a negative \fIindex\fR is given,
-the return pointer points to the first character in the source string.
+\fBTcl_UtfToUniChar\fR \fIindex\fR times, except if that would return
+a pointer to the second byte of a valid 4-byte UTF-8 sequence, in which
+case, \fBTcl_UtfToUniChar\fR will be called once more to find the end
+of the sequence. If a negative \fIindex\fR is given, the returned pointer
+points to the first character in the source string.
.PP
\fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl
commands. It parses a backslash sequence and stores the properly formed
UTF-8 character represented by the backslash sequence in the output
-buffer \fIdst\fR. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer.
+buffer \fIdst\fR. At most 4 bytes are stored in the buffer.
\fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number
of bytes in the backslash sequence, including the backslash character.
The return value is the number of bytes stored in the output buffer.
diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3
index 93e2ebb..533cb4f 100644
--- a/doc/WrongNumArgs.3
+++ b/doc/WrongNumArgs.3
@@ -73,6 +73,12 @@ is now an \fIindexObject\fR because it was passed to
.CS
wrong # args: should be "foo barfly fileName count"
.CE
+.SH "REFERENCE COUNT MANAGEMENT"
+.PP
+The \fIobjv\fR argument to \fBTcl_WrongNumArgs\fR should be the exact
+arguments passed to the command or method implementation function that is
+calling \fBTcl_WrongNumArgs\fR. As such, all values referenced in it should
+have reference counts greater than zero; this is usually a non-issue.
.SH "SEE ALSO"
Tcl_GetIndexFromObj(3)
.SH KEYWORDS
diff --git a/doc/abstract.n b/doc/abstract.n
new file mode 100644
index 0000000..c58abd8
--- /dev/null
+++ b/doc/abstract.n
@@ -0,0 +1,77 @@
+'\"
+'\" Copyright (c) 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.
+'\"
+.TH abstract n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::abstract \- a class that does not allow direct instances of itself
+.SH SYNOPSIS
+.nf
+package require tcl::oo
+
+\fBoo::abstract\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::abstract\fR
+.fi
+.BE
+.SH DESCRIPTION
+Abstract classes are classes that can contain definitions, but which cannot be
+directly manufactured; they are intended to only ever be inherited from and
+instantiated indirectly. The characteristic methods of \fBoo::class\fR
+(\fBcreate\fR and \fBnew\fR) are not exported by an instance of
+\fBoo::abstract\fR.
+.PP
+Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR.
+.SS CONSTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy all its subclasses).
+.SS "EXPORTED METHODS"
+The \fBoo::abstract\fR class defines no new exported methods.
+.SS "NON-EXPORTED METHODS"
+The \fBoo::abstract\fR class explicitly states that \fBcreate\fR,
+\fBcreateWithNamespace\fR, and \fBnew\fR are unexported.
+.SH EXAMPLES
+.PP
+This example defines a simple class hierarchy and creates a new instance of
+it. It then invokes a method of the object before destroying the hierarchy and
+showing that the destruction is transitive.
+.PP
+.CS
+\fBoo::abstract\fR create fruit {
+ method eat {} {
+ puts "yummy!"
+ }
+}
+oo::class create banana {
+ superclass fruit
+ method peel {} {
+ puts "skin now off"
+ }
+}
+set b [banana \fBnew\fR]
+$b peel \fI\(-> prints 'skin now off'\fR
+$b eat \fI\(-> prints 'yummy!'\fR
+set f [fruit new] \fI\(-> error 'unknown method "new"...'\fR
+.CE
+.SH "SEE ALSO"
+oo::define(n), oo::object(n)
+.SH KEYWORDS
+abstract class, class, metaclass, object
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/append.n b/doc/append.n
index e3bf224..99b4ece 100644
--- a/doc/append.n
+++ b/doc/append.n
@@ -20,6 +20,11 @@ Append all of the \fIvalue\fR arguments to the current value
of variable \fIvarName\fR. If \fIvarName\fR does not exist,
it is given a value equal to the concatenation of all the
\fIvalue\fR arguments.
+.VS TIP508
+If \fIvarName\fR indicate an element that does not exist of an array that has
+a default value set, the concatenation of the default value and all the
+\fIvalue\fR arguments will be stored in the array element.
+.VE TIP508
The result of this command is the new value stored in variable
\fIvarName\fR.
This command provides an efficient way to build up long
@@ -44,6 +49,7 @@ puts $var
concat(n), lappend(n)
.SH KEYWORDS
append, variable
-'\" Local Variables:
-'\" mode: nroff
-'\" End:
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/array.n b/doc/array.n
index 25ad0c6..268597d 100644
--- a/doc/array.n
+++ b/doc/array.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH array n 8.3 Tcl "Tcl Built-In Commands"
+.TH array n 8.7 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
@@ -36,6 +36,53 @@ with an empty name, since the return value from
\fBarray nextelement\fR will not indicate whether the search
has been completed.
.TP
+\fBarray default \fIsubcommand arrayName args...\fR
+.VS TIP508
+Manages the default value of the array. Arrays initially have no default
+value, but this command allows you to set one; the default value will be
+returned when reading from an element of the array \fIarrayName\fR if the read
+would otherwise result in an error. Note that this may cause the \fBappend\fR,
+\fBdict\fR, \fBincr\fR and \fBlappend\fR commands to change their behavior in
+relation to non-existing array elements.
+.RS
+.PP
+The \fIsubcommand\fR argument controls what exact operation will be performed
+on the default value of \fIarrayName\fR. Supported \fIsubcommand\fRs are:
+.VE TIP508
+.TP
+\fBarray default exists \fIarrayName\fR
+.VS TIP508
+This returns a boolean value indicating whether a default value has been set
+for the array \fIarrayName\fR. Returns a false value if \fIarrayName\fR does
+not exist. Raises an error if \fIarrayName\fR is an existing variable that is
+not an array.
+.VE TIP508
+.TP
+\fBarray default get \fIarrayName\fR
+.VS TIP508
+This returns the current default value for the array \fIarrayName\fR. Raises
+an error if \fIarrayName\fR is an existing variable that is not an array, or
+if \fIarrayName\fR is an array without a default value.
+.VE TIP508
+.TP
+\fBarray default set \fIarrayName value\fR
+.VS TIP508
+This sets the default value for the array \fIarrayName\fR to \fIvalue\fR.
+Returns the empty string. Raises an error if \fIarrayName\fR is an existing
+variable that is not an array, or if \fIarrayName\fR is an illegal name for an
+array. If \fIarrayName\fR does not currently exist, it is created as an empty
+array as well as having its default value set.
+.VE TIP508
+.TP
+\fBarray default unset \fIarrayName\fR
+.VS TIP508
+This removes the default value for the array \fIarrayName\fR and returns the
+empty string. Does nothing if \fIarrayName\fR does not have a default
+value. Raises an error if \fIarrayName\fR is an existing variable that is not
+an array.
+.VE TIP508
+.RE
+.TP
\fBarray donesearch \fIarrayName searchId\fR
This command terminates an array search and destroys all the
state associated with that search. \fISearchId\fR indicates
@@ -47,6 +94,15 @@ been the return value from a previous invocation of
Returns 1 if \fIarrayName\fR is an array variable, 0 if there
is no variable by that name or if it is a scalar variable.
.TP
+\fBarray for {\fIkeyVariable valueVariable\fB} \fIarrayName body\fP
+The first argument is a two element list of variable names for the
+key and value of each entry in the array. The second argument is the
+array name to iterate over. The third argument is the body to execute
+for each key and value returned.
+The ordering of the returned keys is undefined.
+If an array element is deleted or a new array element is inserted during
+the \fIarray for\fP process, the command will terminate with an error.
+.TP
\fBarray get \fIarrayName\fR ?\fIpattern\fR?
Returns a list containing pairs of elements. The first
element in each pair is the name of an element in \fIarrayName\fR
@@ -185,3 +241,7 @@ foreach color [lsort [\fBarray names\fR colorcount]] {
list(n), string(n), variable(n), trace(n), foreach(n)
.SH KEYWORDS
array, element names, search
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/binary.n b/doc/binary.n
index d39fd11..7968d77 100644
--- a/doc/binary.n
+++ b/doc/binary.n
@@ -12,12 +12,10 @@
.SH NAME
binary \- Insert and extract fields from binary strings
.SH SYNOPSIS
-.VS 8.6
\fBbinary decode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR
.br
\fBbinary encode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR
.br
-.VE 8.6
\fBbinary format \fIformatString \fR?\fIarg arg ...\fR?
.br
\fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR?
@@ -31,11 +29,9 @@ architecture, it might produce an 8-byte binary string consisting of
two 4-byte integers, one for each of the numbers. The subcommand
\fBbinary scan\fR, does the opposite: it extracts data
from a binary string and returns it as ordinary Tcl string values.
-.VS 8.6
The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert
binary data to or from string encodings such as base64 (used in MIME
messages for example).
-.VE 8.6
.PP
Note that other operations on binary data, such as taking a subsequence of it,
getting its length, or reinterpreting it as a string in some encoding, are
@@ -44,7 +40,6 @@ done by other Tcl commands (respectively \fBstring range\fR,
binary string in Tcl is merely one where all the characters it contains are in
the range \eu0000\-\eu00FF.
.SH "BINARY ENCODE AND DECODE"
-.VS 8.6
.PP
When encoding binary data as a readable string, the starting binary data is
passed to the \fBbinary encode\fR command, together with the name of the
@@ -137,7 +132,6 @@ between the encoder and decoder.
Note that neither the encoder nor the decoder handle the header and footer of
the uuencode format.
.RE
-.VE 8.6
.SH "BINARY FORMAT"
.PP
The \fBbinary format\fR command generates a binary string whose layout
@@ -152,7 +146,9 @@ Most field specifiers consume one argument to obtain the value to be
formatted. The type character specifies how the value is to be
formatted. The \fIcount\fR typically indicates how many items of the
specified type are taken from the value. If present, the \fIcount\fR
-is a non-negative decimal integer or \fB*\fR, which normally indicates
+is a non-negative decimal integer or
+.QW \fB*\fR ,
+which normally indicates
that all of the items in the value are to be used. If the number of
arguments does not match the number of fields in the format string
that consume arguments, then an error is generated. The flag character
@@ -160,6 +156,7 @@ is ignored for \fBbinary format\fR.
.PP
Here is a small example to clarify the relation between the field
specifiers and the arguments:
+.PP
.CS
\fBbinary format\fR d3d {1.0 2.0 3.0 4.0} 0.1
.CE
@@ -187,29 +184,63 @@ not part of the ISO 8859\-1 character set.)
If \fIarg\fR has fewer than \fIcount\fR bytes, then additional zero
bytes are used to pad out the field. If \fIarg\fR is longer than the
specified length, the extra characters will be ignored. If
-\fIcount\fR is \fB*\fR, then all of the bytes in \fIarg\fR will be
+\fIcount\fR is
+.QW \fB*\fR ,
+then all of the bytes in \fIarg\fR will be
formatted. If \fIcount\fR is omitted, then one character will be
-formatted. For example,
+formatted. For example, the command:
.RS
+.PP
.CS
\fBbinary format\fR a7a*a alpha bravo charlie
.CE
-will return a string equivalent to \fBalpha\e000\e000bravoc\fR,
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fBalpha\e000\e000bravoc\fR
+.CE
+.PP
+the command:
+.PP
.CS
\fBbinary format\fR a* [encoding convertto utf-8 \eu20ac]
.CE
-will return a string equivalent to \fB\e342\e202\e254\fR (which is the
-UTF-8 byte sequence for a Euro-currency character) and
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\e342\e202\e254\fR
+.CE
+.PP
+(which is the
+UTF-8 byte sequence for a Euro-currency character), and the command:
+.PP
.CS
\fBbinary format\fR a* [encoding convertto iso8859-15 \eu20ac]
.CE
-will return a string equivalent to \fB\e244\fR (which is the ISO
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\e244\fR
+.CE
+.PP
+(which is the ISO
8859\-15 byte sequence for a Euro-currency character). Contrast these
last two with:
+.PP
.CS
\fBbinary format\fR a* \eu20ac
.CE
-which returns a string equivalent to \fB\e254\fR (i.e. \fB\exac\fR) by
+.PP
+which returns a binary string equivalent to:
+.PP
+.CS
+\fB\e254\fR
+.CE
+.PP
+(i.e. \fB\exAC\fR) by
truncating the high-bits of the character, and which is probably not
what is desired.
.RE
@@ -217,42 +248,62 @@ what is desired.
This form is the same as \fBa\fR except that spaces are used for
padding instead of nulls. For example,
.RS
+.PP
.CS
\fBbinary format\fR A6A*A alpha bravo charlie
.CE
-will return \fBalpha bravoc\fR.
+.PP
+will return
+.PP
+.CS
+\fBalpha bravoc\fR
+.CE
.RE
.IP \fBb\fR 5
Stores a string of \fIcount\fR binary digits in low-to-high order
-within each byte in the output string. \fIArg\fR must contain a
+within each byte in the output binary string. \fIArg\fR must contain a
sequence of \fB1\fR and \fB0\fR characters. The resulting bytes are
emitted in first to last order with the bits being formatted in
low-to-high order within each byte. If \fIarg\fR has fewer than
\fIcount\fR digits, then zeros will be used for the remaining bits.
If \fIarg\fR has more than the specified number of digits, the extra
-digits will be ignored. If \fIcount\fR is \fB*\fR, then all of the
+digits will be ignored. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the
digits in \fIarg\fR will be formatted. If \fIcount\fR is omitted,
then one digit will be formatted. If the number of bits formatted
does not end at a byte boundary, the remaining bits of the last byte
will be zeros. For example,
.RS
+.PP
.CS
\fBbinary format\fR b5b* 11100 111000011010
.CE
-will return a string equivalent to \fB\ex07\ex87\ex05\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex07\ex87\ex05\fR
+.CE
.RE
.IP \fBB\fR 5
This form is the same as \fBb\fR except that the bits are stored in
high-to-low order within each byte. For example,
.RS
+.PP
.CS
\fBbinary format\fR B5B* 11100 111000011010
.CE
-will return a string equivalent to \fB\exe0\exe1\exa0\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\exE0\exE1\exA0\fR
+.CE
.RE
.IP \fBH\fR 5
Stores a string of \fIcount\fR hexadecimal digits in high-to-low
-within each byte in the output string. \fIArg\fR must contain a
+within each byte in the output binary string. \fIArg\fR must contain a
sequence of characters in the set
.QW 0123456789abcdefABCDEF .
The resulting bytes are emitted in first to last order with the hex digits
@@ -260,43 +311,66 @@ being formatted in high-to-low order within each byte. If \fIarg\fR
has fewer than \fIcount\fR digits, then zeros will be used for the
remaining digits. If \fIarg\fR has more than the specified number of
digits, the extra digits will be ignored. If \fIcount\fR is
-\fB*\fR, then all of the digits in \fIarg\fR will be formatted. If
+.QW \fB*\fR ,
+then all of the digits in \fIarg\fR will be formatted. If
\fIcount\fR is omitted, then one digit will be formatted. If the
number of digits formatted does not end at a byte boundary, the
remaining bits of the last byte will be zeros. For example,
.RS
+.PP
.CS
\fBbinary format\fR H3H*H2 ab DEF 987
.CE
-will return a string equivalent to \fB\exab\ex00\exde\exf0\ex98\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\exAB\ex00\exDE\exF0\ex98\fR
+.CE
.RE
.IP \fBh\fR 5
This form is the same as \fBH\fR except that the digits are stored in
low-to-high order within each byte. This is seldom required. For example,
.RS
+.PP
.CS
\fBbinary format\fR h3h*h2 AB def 987
.CE
-will return a string equivalent to \fB\exba\ex00\exed\ex0f\ex89\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\exBA\ex00\exED\ex0F\ex89\fR
+.CE
.RE
.IP \fBc\fR 5
Stores one or more 8-bit integer values in the output string. If no
\fIcount\fR is specified, then \fIarg\fR must consist of an integer
value. If \fIcount\fR is specified, \fIarg\fR must consist of a list
containing at least that many integers. The low-order 8 bits of each integer
-are stored as a one-byte value at the cursor position. If \fIcount\fR
-is \fB*\fR, then all of the integers in the list are formatted. If the
+are stored as a one-byte value at the cursor position. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the integers in the list are formatted. If the
number of elements in the list is greater
than \fIcount\fR, then the extra elements are ignored. For example,
.RS
+.PP
.CS
\fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5}
.CE
-will return a string equivalent to
-\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR, whereas
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex03\exFD\ex80\ex04\ex02\ex05\fR
+.CE
+.PP
+whereas:
+.PP
.CS
\fBbinary format\fR c {2 5}
.CE
+.PP
will generate an error.
.RE
.IP \fBs\fR 5
@@ -306,22 +380,32 @@ low-order 16-bits of each integer are stored as a two-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
+.PP
.CS
\fBbinary format\fR s3 {3 -3 258 1}
.CE
-will return a string equivalent to
-\fB\ex03\ex00\exfd\exff\ex02\ex01\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex03\ex00\exFD\exFF\ex02\ex01\fR
+.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that it stores one or more
16-bit integers in big-endian byte order in the output string. For
example,
.RS
+.PP
.CS
\fBbinary format\fR S3 {3 -3 258 1}
.CE
-will return a string equivalent to
-\fB\ex00\ex03\exff\exfd\ex01\ex02\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex00\ex03\exFF\exFD\ex01\ex02\fR
+.CE
.RE
.IP \fBt\fR 5
This form (mnemonically \fItiny\fR) is the same as \fBs\fR and \fBS\fR
@@ -336,22 +420,32 @@ low-order 32-bits of each integer are stored as a four-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
+.PP
.CS
\fBbinary format\fR i3 {3 -3 65536 1}
.CE
-will return a string equivalent to
-\fB\ex03\ex00\ex00\ex00\exfd\exff\exff\exff\ex00\ex00\ex01\ex00\fR
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex03\ex00\ex00\ex00\exFD\exFF\exFF\exFF\ex00\ex00\ex01\ex00\fR
+.CE
.RE
.IP \fBI\fR 5
This form is the same as \fBi\fR except that it stores one or more one
or more 32-bit integers in big-endian byte order in the output string.
For example,
.RS
+.PP
.CS
\fBbinary format\fR I3 {3 -3 65536 1}
.CE
-will return a string equivalent to
-\fB\ex00\ex00\ex00\ex03\exff\exff\exff\exfd\ex00\ex01\ex00\ex00\fR
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex00\ex00\ex00\ex03\exFF\exFF\exFF\exFD\ex00\ex01\ex00\ex00\fR
+.CE
.RE
.IP \fBn\fR 5
This form (mnemonically \fInumber\fR or \fInormal\fR) is the same as
@@ -367,20 +461,24 @@ low-order 64-bits of each integer are stored as an eight-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
+.PP
.CS
\fBbinary format\fR w 7810179016327718216
.CE
-will return the string \fBHelloTcl\fR
+.PP
+will return the binary string \fBHelloTcl\fR.
.RE
.IP \fBW\fR 5
This form is the same as \fBw\fR except that it stores one or more one
or more 64-bit integers in big-endian byte order in the output string.
For example,
.RS
+.PP
.CS
\fBbinary format\fR Wc 4785469626960341345 110
.CE
-will return the string \fBBigEndian\fR
+.PP
+will return the binary string \fBBigEndian\fR
.RE
.IP \fBm\fR 5
This form (mnemonically the mirror of \fBw\fR) is the same as \fBw\fR
@@ -403,11 +501,16 @@ double-precision floating point numbers internally, there may be some
loss of precision in the conversion to single-precision. For example,
on a Windows system running on an Intel Pentium processor,
.RS
+.PP
.CS
\fBbinary format\fR f2 {1.6 3.4}
.CE
-will return a string equivalent to
-\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\exCD\exCC\exCC\ex3F\ex9A\ex99\ex59\ex40\fR
+.CE
.RE
.IP \fBr\fR 5
This form (mnemonically \fIreal\fR) is the same as \fBf\fR except that
@@ -424,11 +527,16 @@ or more double-precision floating point numbers in the machine's native
representation in the output string. For example, on a
Windows system running on an Intel Pentium processor,
.RS
+.PP
.CS
\fBbinary format\fR d1 {1.6}
.CE
-will return a string equivalent to
-\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fB\ex9A\ex99\ex99\ex99\ex99\ex99\exF9\ex3F\fR
+.CE
.RE
.IP \fBq\fR 5
This form (mnemonically the mirror of \fBd\fR) is the same as \fBd\fR
@@ -441,26 +549,37 @@ This form is the same as \fBq\fR except that it stores the
double-precision floating point numbers in big-endian order.
.IP \fBx\fR 5
Stores \fIcount\fR null bytes in the output string. If \fIcount\fR is
-not specified, stores one null byte. If \fIcount\fR is \fB*\fR,
+not specified, stores one null byte. If \fIcount\fR is
+.QW \fB*\fR ,
generates an error. This type does not consume an argument. For
example,
.RS
+.PP
.CS
\fBbinary format\fR a3xa3x2a3 abc def ghi
.CE
-will return a string equivalent to \fBabc\e000def\e000\e000ghi\fR.
+.PP
+will return a binary string equivalent to:
+.PP
+.CS
+\fBabc\e000def\e000\e000ghi\fR
+.CE
.RE
.IP \fBX\fR 5
Moves the cursor back \fIcount\fR bytes in the output string. If
-\fIcount\fR is \fB*\fR or is larger than the current cursor position,
+\fIcount\fR is
+.QW \fB*\fR
+or is larger than the current cursor position,
then the cursor is positioned at location 0 so that the next byte
stored will be the first byte in the result string. If \fIcount\fR is
omitted then the cursor is moved back one byte. This type does not
consume an argument. For example,
.RS
+.PP
.CS
\fBbinary format\fR a3X*a3X2a3 abc def ghi
.CE
+.PP
will return \fBdghi\fR.
.RE
.IP \fB@\fR 5
@@ -469,14 +588,22 @@ specified by \fIcount\fR. Position 0 refers to the first byte in the
output string. If \fIcount\fR refers to a position beyond the last
byte stored so far, then null bytes will be placed in the uninitialized
locations and the cursor will be placed at the specified location. If
-\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of
+\fIcount\fR is
+.QW \fB*\fR ,
+then the cursor is moved to the current end of
the output string. If \fIcount\fR is omitted, then an error will be
generated. This type does not consume an argument. For example,
.RS
+.PP
.CS
\fBbinary format\fR a5@2a1@*a3@10a1 abcde f ghi j
.CE
-will return \fBabfdeghi\e000\e000j\fR.
+.PP
+will return
+.PP
+.CS
+\fBabfdeghi\e000\e000j\fR
+.CE
.RE
.SH "BINARY SCAN"
.PP
@@ -498,8 +625,9 @@ argument to obtain the variable into which the scanned values should
be placed. The type character specifies how the binary data is to be
interpreted. The \fIcount\fR typically indicates how many items of
the specified type are taken from the data. If present, the
-\fIcount\fR is a non-negative decimal integer or \fB*\fR, which
-normally indicates that all of the remaining items in the data are to
+\fIcount\fR is a non-negative decimal integer or
+.QW \fB*\fR ,
+which normally indicates that all of the remaining items in the data are to
be used. If there are not enough bytes left after the current cursor
position to satisfy the current field specifier, then the
corresponding variable is left untouched and \fBbinary scan\fR returns
@@ -513,6 +641,7 @@ is accepted for all field types but is ignored for non-integer fields.
A similar example as with \fBbinary format\fR should explain the
relation between field specifiers and arguments in case of the binary
scan subcommand:
+.PP
.CS
\fBbinary scan\fR $bytes s3s first second
.CE
@@ -524,12 +653,15 @@ If \fIbytes\fR contains fewer than 8 bytes (i.e. four 2-byte
integers), no assignment to \fIsecond\fR will be made, and if
\fIbytes\fR contains fewer than 6 bytes (i.e. three 2-byte integers),
no assignment to \fIfirst\fR will be made. Hence:
+.PP
.CS
puts [\fBbinary scan\fR abcdefg s3s first second]
puts $first
puts $second
.CE
+.PP
will print (assuming neither variable is set previously):
+.PP
.CS
1
25185 25699 26213
@@ -541,14 +673,17 @@ It is \fIimportant\fR to note that the \fBc\fR, \fBs\fR, and \fBS\fR
long data size values. In doing this, values that have their high
bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints),
will be sign extended. Thus the following will occur:
+.PP
.CS
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
+.PP
If you require unsigned values you can include the
.QW u
flag character following
the field type. For example, to read an unsigned short value:
+.PP
.CS
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort su1 val; \fI# val == 0x00008000\fR
@@ -559,8 +694,9 @@ reading bytes from the current position. The cursor is initially
at position 0 at the beginning of the data. The type may be any one of
the following characters:
.IP \fBa\fR 5
-The data is a byte string of length \fIcount\fR. If \fIcount\fR
-is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be
+The data is a byte string of length \fIcount\fR. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bytes in \fIstring\fR will be
scanned into the variable. If \fIcount\fR is omitted, then one
byte will be scanned.
All bytes scanned will be interpreted as being characters in the
@@ -569,24 +705,30 @@ needed if the string is not a binary string or a string encoded in ISO
8859\-1.
For example,
.RS
+.PP
.CS
\fBbinary scan\fR abcde\e000fghi a6a10 var1 var2
.CE
+.PP
will return \fB1\fR with the string equivalent to \fBabcde\e000\fR
stored in \fIvar1\fR and \fIvar2\fR left unmodified, and
+.PP
.CS
\fBbinary scan\fR \e342\e202\e254 a* var1
set var2 [encoding convertfrom utf-8 $var1]
.CE
+.PP
will store a Euro-currency character in \fIvar2\fR.
.RE
.IP \fBA\fR 5
This form is the same as \fBa\fR, except trailing blanks and nulls are stripped from
the scanned value before it is stored in the variable. For example,
.RS
+.PP
.CS
\fBbinary scan\fR "abc efghi \e000" A* var1
.CE
+.PP
will return \fB1\fR with \fBabc efghi\fR stored in \fIvar1\fR.
.RE
.IP \fBb\fR 5
@@ -597,13 +739,16 @@ and
.QW 0
characters. The data bytes are scanned in first to last order with
the bits being taken in low-to-high order within each byte. Any extra
-bits in the last byte are ignored. If \fIcount\fR is \fB*\fR, then
-all of the remaining bits in \fIstring\fR will be scanned. If
+bits in the last byte are ignored. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bits in \fIstring\fR will be scanned. If
\fIcount\fR is omitted, then one bit will be scanned. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex07\ex87\ex05 b5b* var1 var2
.CE
+.PP
will return \fB2\fR with \fB11100\fR stored in \fIvar1\fR and
\fB1110000110100000\fR stored in \fIvar2\fR.
.RE
@@ -611,12 +756,23 @@ will return \fB2\fR with \fB11100\fR stored in \fIvar1\fR and
This form is the same as \fBb\fR, except the bits are taken in
high-to-low order within each byte. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex70\ex87\ex05 B5B* var1 var2
.CE
+.PP
will return \fB2\fR with \fB01110\fR stored in \fIvar1\fR and
\fB1000011100000101\fR stored in \fIvar2\fR.
.RE
+.IP \fBC\fR 5
+This form is similar to \fBA\fR, except that it scans the data from start
+and terminates at the first null (C string semantics). For example,
+.RS
+.CS
+\fBbinary scan\fR "abc\e000efghi" C* var1
+.CE
+will return \fB1\fR with \fBabc\fR stored in \fIvar1\fR.
+.RE
.IP \fBH\fR 5
The data is turned into a string of \fIcount\fR hexadecimal digits in
high-to-low order represented as a sequence of characters in the set
@@ -624,13 +780,16 @@ high-to-low order represented as a sequence of characters in the set
The data bytes are scanned in first to last
order with the hex digits being taken in high-to-low order within each
byte. Any extra bits in the last byte are ignored. If \fIcount\fR is
-\fB*\fR, then all of the remaining hex digits in \fIstring\fR will be
+.QW \fB*\fR ,
+then all of the remaining hex digits in \fIstring\fR will be
scanned. If \fIcount\fR is omitted, then one hex digit will be
scanned. For example,
.RS
+.PP
.CS
-\fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2
+\fBbinary scan\fR \ex07\exC6\ex05\ex1F\ex34 H3H* var1 var2
.CE
+.PP
will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and
\fB051f34\fR stored in \fIvar2\fR.
.RE
@@ -638,9 +797,11 @@ will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and
This form is the same as \fBH\fR, except the digits are taken in
reverse (low-to-high) order within each byte. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex07\ex86\ex05\ex12\ex34 h3h* var1 var2
.CE
+.PP
will return \fB2\fR with \fB706\fR stored in \fIvar1\fR and
\fB502143\fR stored in \fIvar2\fR.
.PP
@@ -649,135 +810,151 @@ multiple bytes in order should use the \fBH\fR format.
.RE
.IP \fBc\fR 5
The data is turned into \fIcount\fR 8-bit signed integers and stored
-in the corresponding variable as a list. If \fIcount\fR is \fB*\fR,
+in the corresponding variable as a list, or as unsigned if \fBu\fR is placed
+immediately after the \fBc\fR. If \fIcount\fR is
+.QW \fB*\fR ,
then all of the remaining bytes in \fIstring\fR will be scanned. If
\fIcount\fR is omitted, then one 8-bit integer will be scanned. For
example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex07\ex86\ex05 c2c* var1 var2
.CE
+.PP
will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR
-stored in \fIvar2\fR. Note that the integers returned are signed, but
-they can be converted to unsigned 8-bit quantities using an expression
-like:
-.CS
-set num [expr { $num & 0xFF }]
-.CE
+stored in \fIvar2\fR. Note that the integers returned are signed unless
+\fBcu\fR in place of \fBc\fR.
.RE
.IP \fBs\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
-represented in little-endian byte order. The integers are stored in
-the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
-all of the remaining bytes in \fIstring\fR will be scanned. If
+represented in little-endian byte order, or as unsigned if \fBu\fR is placed
+immediately after the \fBs\fR. The integers are stored in
+the corresponding variable as a list. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bytes in \fIstring\fR will be scanned. If
\fIcount\fR is omitted, then one 16-bit integer will be scanned. For
example,
.RS
+.PP
.CS
-\fBbinary scan\fR \ex05\ex00\ex07\ex00\exf0\exff s2s* var1 var2
+\fBbinary scan\fR \ex05\ex00\ex07\ex00\exF0\exFF s2s* var1 var2
.CE
+.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
-stored in \fIvar2\fR. Note that the integers returned are signed, but
-they can be converted to unsigned 16-bit quantities using an expression
-like:
-.CS
-set num [expr { $num & 0xFFFF }]
-.CE
+stored in \fIvar2\fR. Note that the integers returned are signed unless
+\fBsu\fR is used in place of \fBs\fR.
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that the data is interpreted
-as \fIcount\fR 16-bit signed integers represented in big-endian byte
+as \fIcount\fR 16-bit integers represented in big-endian byte
order. For example,
.RS
+.PP
.CS
-\fBbinary scan\fR \ex00\ex05\ex00\ex07\exff\exf0 S2S* var1 var2
+\fBbinary scan\fR \ex00\ex05\ex00\ex07\exFF\exF0 S2S* var1 var2
.CE
+.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
.RE
.IP \fBt\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
represented in the native byte order of the machine running the Tcl
-script. It is otherwise identical to \fBs\fR and \fBS\fR.
+script, or as unsigned if \fBu\fR is placed
+immediately after the \fBt\fR. It is otherwise identical to \fBs\fR and \fBS\fR.
To determine what the native byte order of the machine is, refer to
the \fBbyteOrder\fR element of the \fBtcl_platform\fR array.
.IP \fBi\fR 5
The data is interpreted as \fIcount\fR 32-bit signed integers
-represented in little-endian byte order. The integers are stored in
-the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
-all of the remaining bytes in \fIstring\fR will be scanned. If
+represented in little-endian byte order, or as unsigned if \fBu\fR is placed
+immediately after the \fBi\fR. The integers are stored in
+the corresponding variable as a list. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bytes in \fIstring\fR will be scanned. If
\fIcount\fR is omitted, then one 32-bit integer will be scanned. For
example,
.RS
+.PP
.CS
-set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff
+set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exF0\exFF\exFF\exFF
\fBbinary scan\fR $str i2i* var1 var2
.CE
+.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
-stored in \fIvar2\fR. Note that the integers returned are signed, but
-they can be converted to unsigned 32-bit quantities using an expression
-like:
-.CS
-set num [expr { $num & 0xFFFFFFFF }]
-.CE
+stored in \fIvar2\fR. Note that the integers returned are signed unless
+\fBiu\fR is used in place of \fBi\fR.
.RE
.IP \fBI\fR 5
This form is the same as \fBI\fR except that the data is interpreted
as \fIcount\fR 32-bit signed integers represented in big-endian byte
-order. For example,
+order, or as unsigned if \fBu\fR is placed
+immediately after the \fBI\fR. For example,
.RS
+.PP
.CS
-set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0
+set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exFF\exFF\exFF\exF0
\fBbinary scan\fR $str I2I* var1 var2
.CE
+.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
.RE
.IP \fBn\fR 5
The data is interpreted as \fIcount\fR 32-bit signed integers
represented in the native byte order of the machine running the Tcl
-script. It is otherwise identical to \fBi\fR and \fBI\fR.
+script, or as unsigned if \fBu\fR is placed
+immediately after the \fBn\fR. It is otherwise identical to \fBi\fR and \fBI\fR.
To determine what the native byte order of the machine is, refer to
the \fBbyteOrder\fR element of the \fBtcl_platform\fR array.
.IP \fBw\fR 5
The data is interpreted as \fIcount\fR 64-bit signed integers
-represented in little-endian byte order. The integers are stored in
-the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
-all of the remaining bytes in \fIstring\fR will be scanned. If
+represented in little-endian byte order, or as unsigned if \fBu\fR is placed
+immediately after the \fBw\fR. The integers are stored in
+the corresponding variable as a list. If \fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bytes in \fIstring\fR will be scanned. If
\fIcount\fR is omitted, then one 64-bit integer will be scanned. For
example,
.RS
+.PP
.CS
-set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff
+set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exF0\exFF\exFF\exFF
\fBbinary scan\fR $str wi* var1 var2
.CE
+.PP
will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and
-\fB\-16\fR stored in \fIvar2\fR. Note that the integers returned are
-signed and cannot be represented by Tcl as unsigned values.
+\fB\-16\fR stored in \fIvar2\fR.
.RE
.IP \fBW\fR 5
This form is the same as \fBw\fR except that the data is interpreted
as \fIcount\fR 64-bit signed integers represented in big-endian byte
-order. For example,
+order, or as unsigned if \fBu\fR is placed
+immediately after the \fBW\fR. For example,
.RS
+.PP
.CS
-set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0
+set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exFF\exFF\exFF\exF0
\fBbinary scan\fR $str WI* var1 var2
.CE
+.PP
will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
.RE
.IP \fBm\fR 5
The data is interpreted as \fIcount\fR 64-bit signed integers
represented in the native byte order of the machine running the Tcl
-script. It is otherwise identical to \fBw\fR and \fBW\fR.
+script, or as unsigned if \fBu\fR is placed
+immediately after the \fBm\fR. It is otherwise identical to \fBw\fR and \fBW\fR.
To determine what the native byte order of the machine is, refer to
the \fBbyteOrder\fR element of the \fBtcl_platform\fR array.
.IP \fBf\fR 5
The data is interpreted as \fIcount\fR single-precision floating point
numbers in the machine's native representation. The floating point
numbers are stored in the corresponding variable as a list. If
-\fIcount\fR is \fB*\fR, then all of the remaining bytes in
+\fIcount\fR is
+.QW \fB*\fR ,
+then all of the remaining bytes in
\fIstring\fR will be scanned. If \fIcount\fR is omitted, then one
single-precision floating point number will be scanned. The size of a
floating point number may vary across architectures, so the number of
@@ -786,9 +963,11 @@ valid floating point number, the resulting value is undefined and
compiler dependent. For example, on a Windows system running on an
Intel Pentium processor,
.RS
+.PP
.CS
-\fBbinary scan\fR \ex3f\excc\excc\excd f var1
+\fBbinary scan\fR \ex3F\exCC\exCC\exCD f var1
.CE
+.PP
will return \fB1\fR with \fB1.6000000238418579\fR stored in
\fIvar1\fR.
.RE
@@ -808,9 +987,11 @@ as \fIcount\fR double-precision floating point numbers in the
machine's native representation. For example, on a Windows system
running on an Intel Pentium processor,
.RS
+.PP
.CS
-\fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1
+\fBbinary scan\fR \ex9A\ex99\ex99\ex99\ex99\ex99\exF9\ex3F d var1
.CE
+.PP
will return \fB1\fR with \fB1.6000000000000001\fR
stored in \fIvar1\fR.
.RE
@@ -826,28 +1007,36 @@ order. This conversion is not portable to the minority of systems not
using IEEE floating point representations.
.IP \fBx\fR 5
Moves the cursor forward \fIcount\fR bytes in \fIstring\fR. If
-\fIcount\fR is \fB*\fR or is larger than the number of bytes after the
+\fIcount\fR is
+.QW \fB*\fR
+or is larger than the number of bytes after the
current cursor position, then the cursor is positioned after
the last byte in \fIstring\fR. If \fIcount\fR is omitted, then the
cursor is moved forward one byte. Note that this type does not
consume an argument. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex01\ex02\ex03\ex04 x2H* var1
.CE
+.PP
will return \fB1\fR with \fB0304\fR stored in \fIvar1\fR.
.RE
.IP \fBX\fR 5
Moves the cursor back \fIcount\fR bytes in \fIstring\fR. If
-\fIcount\fR is \fB*\fR or is larger than the current cursor position,
+\fIcount\fR is
+.QW \fB*\fR
+or is larger than the current cursor position,
then the cursor is positioned at location 0 so that the next byte
scanned will be the first byte in \fIstring\fR. If \fIcount\fR
is omitted then the cursor is moved back one byte. Note that this
type does not consume an argument. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex01\ex02\ex03\ex04 c2XH* var1 var2
.CE
+.PP
will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR
stored in \fIvar2\fR.
.RE
@@ -858,9 +1047,11 @@ by \fIcount\fR. Note that position 0 refers to the first byte in
\fIstring\fR, then the cursor is positioned after the last byte. If
\fIcount\fR is omitted, then an error will be generated. For example,
.RS
+.PP
.CS
\fBbinary scan\fR \ex01\ex02\ex03\ex04 c2@1H* var1 var2
.CE
+.PP
will return \fB2\fR with \fB1 2\fR stored in \fIvar1\fR and \fB020304\fR
stored in \fIvar2\fR.
.RE
diff --git a/doc/callback.n b/doc/callback.n
new file mode 100644
index 0000000..3ab81ac
--- /dev/null
+++ b/doc/callback.n
@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 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.
+'\"
+.TH callback n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+callback, mymethod \- generate callbacks to methods
+.SH SYNOPSIS
+.nf
+package require tcl::oo
+
+\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR?
+\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBcallback\fR command,
+'\" Based on notes in the tcllib docs, we know the provenance of mymethod
+also called \fBmymethod\fR for compatibility with the ooutil and snit packages
+of Tcllib,
+and which should only be used from within the context of a call to a method
+(i.e. inside a method, constructor or destructor body) is used to generate a
+script fragment that will invoke the method, \fImethodName\fR, on the current
+object (as reported by \fBself\fR) when executed. Any additional arguments
+provided will be provided as leading arguments to the callback. The resulting
+script fragment shall be a proper list.
+.PP
+Note that it is up to the caller to ensure that the current object is able to
+handle the call of \fImethodName\fR; this command does not check that.
+\fImethodName\fR may refer to any exported or unexported method, but may not
+refer to a private method as those can only be invoked directly from within
+methods. If there is no such method present at the point when the callback is
+invoked, the standard \fBunknown\fR method handler will be called.
+.SH EXAMPLE
+This is a simple echo server class. The \fBcallback\fR command is used in two
+places, to arrange for the incoming socket connections to be handled by the
+\fIAccept\fR method, and to arrange for the incoming bytes on those
+connections to be handled by the \fIReceive\fR method.
+.PP
+.CS
+oo::class create EchoServer {
+ variable server clients
+ constructor {port} {
+ set server [socket -server [\fBcallback\fR Accept] $port]
+ set clients {}
+ }
+ destructor {
+ chan close $server
+ foreach client [dict keys $clients] {
+ chan close $client
+ }
+ }
+
+ method Accept {channel clientAddress clientPort} {
+ dict set clients $channel [dict create \e
+ address $clientAddress port $clientPort]
+ chan event $channel readable [\fBcallback\fR Receive $channel]
+ }
+ method Receive {channel} {
+ if {[chan gets $channel line] >= 0} {
+ my echo $channel $line
+ } else {
+ chan close $channel
+ dict unset clients $channel
+ }
+ }
+
+ method echo {channel line} {
+ dict with clients $channel {
+ chan puts $channel \e
+ [format {[%s:%d] %s} $address $port $line]
+ }
+ }
+}
+.CE
+.SH "SEE ALSO"
+chan(n), fileevent(n), my(n), self(n), socket(n), trace(n)
+.SH KEYWORDS
+callback, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/catch.n b/doc/catch.n
index d43a7ec..8d885d4 100644
--- a/doc/catch.n
+++ b/doc/catch.n
@@ -56,9 +56,7 @@ When the return code from evaluation of \fIscript\fR is
\fBTCL_ERROR\fR, four additional entries are defined in the dictionary
of return options stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR,
\fB\-errorcode\fR, \fB\-errorline\fR, and
-.VS 8.6
\fB\-errorstack\fR.
-.VE 8.6
The value of the \fB\-errorinfo\fR entry is a formatted stack trace containing
more information about the context in which the error happened. The formatted
stack trace is meant to be read by a person. The value of the
@@ -67,7 +65,6 @@ list. The \fB\-errorcode\fR value is meant to be further processed by
programs, and may not be particularly readable by people. The value of the
\fB\-errorline\fR entry is an integer indicating which line of \fIscript\fR
was being evaluated when the error occurred.
-.VS 8.6
The value of the \fB\-errorstack\fR entry is an
even-sized list made of token-parameter pairs accumulated while
unwinding the stack. The token may be
@@ -87,14 +84,11 @@ the static text of the calling sites, and
.IP [3]
it is coarser-grained, with only one element per stack frame (like procs; no
separate elements for \fBforeach\fR constructs for example).
-.VE 8.6
.PP
The values of the \fB\-errorinfo\fR and \fB\-errorcode\fR entries of
the most recent error are also available as values of the global
variables \fB::errorInfo\fR and \fB::errorCode\fR respectively.
-.VS 8.6
The value of the \fB\-errorstack\fR entry surfaces as \fBinfo errorstack\fR.
-.VE 8.6
.PP
Tcl packages may provide commands that set other entries in the
dictionary of return options, and the \fBreturn\fR command may be
diff --git a/doc/cd.n b/doc/cd.n
index dceb075..4cd4792 100644
--- a/doc/cd.n
+++ b/doc/cd.n
@@ -22,7 +22,7 @@ home directory (as specified in the HOME environment variable) if
Returns an empty string.
Note that the current working directory is a per-process resource; the
\fBcd\fR command changes the working directory for all interpreters
-and (in a threaded environment) all threads.
+and all threads.
.SH EXAMPLES
.PP
Change to the home directory of the user \fBfred\fR:
@@ -41,3 +41,7 @@ current one:
filename(n), glob(n), pwd(n)
.SH KEYWORDS
working directory
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/chan.n b/doc/chan.n
index 77e9326..b184b00 100644
--- a/doc/chan.n
+++ b/doc/chan.n
@@ -1,5 +1,6 @@
'\"
'\" Copyright (c) 2005-2006 Donal K. Fellows
+'\" Copyright (c) 2021 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -8,771 +9,608 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-chan \- Read, write and manipulate channels
+chan \- Reads, writes and manipulates channels.
.SH SYNOPSIS
-\fBchan \fIoption\fR ?\fIarg arg ...\fR?
+\fBchan \fIoperation\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
-This command provides several operations for reading from, writing to
-and otherwise manipulating open channels (such as have been created
-with the \fBopen\fR and \fBsocket\fR commands, or the default named
-channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to
-the process's standard input, output and error streams respectively).
-\fIOption\fR indicates what to do with the channel; any unique
-abbreviation for \fIoption\fR is acceptable. Valid options are:
-.TP
-\fBchan blocked \fIchannelId\fR
-.
-This tests whether the last input operation on the channel called
-\fIchannelId\fR failed because it would have otherwise caused the
-process to block, and returns 1 if that was the case. It returns 0
-otherwise. Note that this only ever returns 1 when the channel has
-been configured to be non-blocking; all Tcl channels have blocking
-turned on by default.
-.TP
-\fBchan close \fIchannelId\fR ?\fIdirection\fR?
-.
-Close and destroy the channel called \fIchannelId\fR. Note that this
-deletes all existing file-events registered on the channel.
-.VS 8.6
-If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or
-any unique abbreviation of them) is present, the channel will only be
-half-closed, so that it can go from being read-write to write-only or
-read-only respectively. If a read-only channel is closed for reading, it is
-the same as if the channel is fully closed, and respectively similar for
-write-only channels. Without the \fIdirection\fR argument, the channel is
-closed for both reading and writing (but only if those directions are
-currently open). It is an error to close a read-only channel for writing, or a
-write-only channel for reading.
-.VE 8.6
+\fBchan\fR provides several operations for reading from, writing to, and
+otherwise manipulating channels, e.g. those created by \fBopen\fR and
+\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR
+which correspond respectively to the standard input, output, and error streams
+of the process. Any unique abbreviation for \fIoperation\fR is acceptable.
+Available operations are:
+.TP
+\fBchan blocked \fIchannelName\fR
+.
+Returns 1 when the channel is in non-blocking mode and the last input operation
+on the channel failed because it would have otherwise caused the process to
+block, and 0 otherwise. Each Tcl channel is in blocking mode unless configured
+otherwise.
+.TP
+\fBchan close \fIchannelName\fR ?\fIdirection\fR?
+.
+Closes and destroys the named channel, deleting any existing event handlers
+established for the channel, and returns the empty string. If \fIdirection\fR is
+given, it is
+.QW\fBread\fR
+or
+.QW\fBwrite\fR
+or any unique abbreviation of those words, and only that side of the channel is
+closed. I.e. a read-write channel may become read-only or write-only.
+Closing a read-only channel for reading, or closing a write-only channel for
+writing is the same as simply closing the channel. It is an error to close a
+read-only channel for writing or to close a write-only channel for reading.
.RS
.PP
-As part of closing the channel, all buffered output is flushed to the
-channel's output device (only if the channel is ceasing to be writable), any
-buffered input is discarded (only if the channel is ceasing to be readable),
-the underlying operating system resource is closed and \fIchannelId\fR becomes
-unavailable for future use (both only if the channel is being completely
-closed).
-.PP
-If the channel is blocking and the channel is ceasing to be writable, the
-command does not return until all output is flushed. If the channel is
-non-blocking and there is unflushed output, the channel remains open and the
-command returns immediately; output will be flushed in the background and the
-channel will be closed when all the flushing is complete.
-.PP
-If \fIchannelId\fR is a blocking channel for a command pipeline then
-\fBchan close\fR waits for the child processes to complete.
-.PP
-If the channel is shared between interpreters, then \fBchan close\fR
-makes \fIchannelId\fR unavailable in the invoking interpreter but has
-no other effect until all of the sharing interpreters have closed the
-channel. When the last interpreter in which the channel is registered
-invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions
-described above occur. With half-closing, the half-close of the channel only
-applies to the current interpreter's view of the channel until all channels
-have closed it in that direction (or completely).
-See the \fBinterp\fR command for a description of channel sharing.
-.PP
-Channels are automatically fully closed when an interpreter is destroyed and
-when the process exits. Channels are switched to blocking mode, to
-ensure that all output is correctly flushed before the process exits.
-.PP
-The command returns an empty string, and may generate an error if
-an error occurs while flushing output. If a command in a command
-pipeline created with \fBopen\fR returns an error, \fBchan close\fR
-generates an error (similar to the \fBexec\fR command.)
-.PP
-.VS 8.6
-Note that half-closes of sockets and command pipelines can have important side
-effects because they result in a shutdown() or close() of the underlying
-system resource, which can change how other processes or systems respond to
-the Tcl program.
-.VE 8.6
+When a channel is closed for writing, any buffered output on the channel is
+flushed. When a channel is closed for reading, any buffered input is discarded.
+When a channel is destroyed the underlying resource is closed and the channel
+is thereafter unavailable.
+.PP
+\fBchan close\fR fully flushes any output before closing the write side of a
+channel unless it is non-blocking mode, where it returns immediately and the
+channel is flushed in the background before finally being closed.
+.PP
+\fBchan close\fR may return an error if an error occurs while flushing
+output. If a process in a command pipeline created by \fBopen\fR returns an
+error (either by returning a non-zero exit code or writing to its standard
+error file descriptor), \fBchan close\fR generates an error in the same
+manner as \fBexec\fR.
+.PP
+Closing one side of a socket or command pipeline may lead to the shutdown() or
+close() of the underlying system resource, leading to a reaction from whatever
+is on the other side of the pipeline or socket.
+.PP
+If the channel for a command pipeline is in blocking mode, \fBchan close\fR
+waits for the connected processes to complete.
+.PP
+\fBchan close\fR only affects the current interpreter. If the channel is open
+in any other interpreter, its state is unchanged there. See \fBinterp\fR for a
+description of channel sharing.
+.PP
+When the last interpreter sharing a channel is destroyed, the channel is
+switched to blocking mode and fully flushed and then closed.
+.PP
+Channels are automatically closed when an interpreter is destroyed and
+when the process exits.
+From 8.6 on (TIP#398), nonblocking channels are no longer switched to
+blocking mode when exiting; this guarantees a timely exit even when the
+peer or a communication channel is stalled. To ensure proper flushing of
+stalled nonblocking channels on exit, one must now either (a) actively
+switch them back to blocking or (b) use the environment variable
+\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
+.QW \fB0\fR
+restores the previous behavior.
.RE
.TP
-\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
+\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?...
.
-Query or set the configuration options of the channel named
-\fIchannelId\fR.
+Configures or reports the configuration of \fIchannelName\fR.
.RS
.PP
-If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the
-command returns a list containing alternating option names and values
-for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR
-then the command returns the current value of the given option. If
-one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
-the command sets each of the named options to the corresponding
-\fIvalue\fR; in this case the return value is an empty string.
-.PP
-The options described below are supported for all channels. In
-addition, each channel type may add options that only it supports. See
-the manual entry for the command that creates each type of channel
-for the options supported by that specific type of channel. For
-example, see the manual entry for the \fBsocket\fR command for additional
-options for sockets, and the \fBopen\fR command for additional options for
-serial devices.
+If no \fIoptionName\fR or \fIvalue\fR arguments are given,
+\fBchan configure\fR returns a dictionary of option names and
+values for the channel. If \fIoptionName\fR is supplied without a \fIvalue\fR,
+\fBchan configure\fR returns the current value of the named option. If one or
+more pairs of \fIoptionName\fR and \fIvalue\fR are supplied,
+\fBchan configure\fR sets each of the named options to the corresponding
+\fIvalue\fR and returns the empty string.
+.PP
+The options described below are supported for all channels. Each type of
+channel may provide additional options. Those options are described in the
+relevant documentation. For example, additional options are documented for
+\fBsocket\fR, and also for serial devices at \fBopen\fR.
.TP
\fB\-blocking\fR \fIboolean\fR
.
-The \fB\-blocking\fR option determines whether I/O operations on the
-channel can cause the process to block indefinitely. The value of the
-option must be a proper boolean value. Channels are normally in
-blocking mode; if a channel is placed into non-blocking mode it will
-affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan
-puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the
-documentation for those commands for details. For non-blocking mode to
-work correctly, the application must be using the Tcl event loop
-(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR
-command).
+If \fB\-blocking\fR is set to \fBtrue\fR, which is the default, reading from or
+writing to the channel may cause the process to block indefinitely. Otherwise,
+operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan
+flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in
+generally requires that the event loop is entered, e.g. by calling
+\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to
+process events on the channel.
.TP
\fB\-buffering\fR \fInewValue\fR
.
-If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output
-until its internal buffer is full or until the \fBchan flush\fR
-command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O
-system will automatically flush output for the channel whenever a
-newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O
-system will flush automatically after every output operation. The
-default is for \fB\-buffering\fR to be set to \fBfull\fR except for
-channels that connect to terminal-like devices; for these channels the
-initial setting is \fBline\fR. Additionally, \fBstdin\fR and
-\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set
-to \fBnone\fR.
+If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered
+until the internal buffer is full or until \fBchan flush\fR is called. If
+\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line
+character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after
+every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that
+connect to terminal-like devices, the default value is \fBline\fR. For
+\fBstderr\fR the default value is \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
-\fINewvalue\fR must be an integer; its value is used to set the size
-of buffers, in bytes, subsequently allocated for this channel to store
-input or output. \fINewvalue\fR must be a number of no more than one
-million, allowing buffers of up to one million bytes in size.
-.TP
-\fB\-encoding\fR \fIname\fR
-.
-This option is used to specify the encoding of the channel as one of
-the named encodings returned by \fBencoding names\fR or the special
-value \fBbinary\fR, so that the data can be converted to and from
-Unicode for use in Tcl. For instance, in order for Tcl to read
-characters from a Japanese file in \fBshiftjis\fR and properly process
-and display the contents, the encoding would be set to \fBshiftjis\fR.
-Thereafter, when reading from the channel, the bytes in the Japanese
-file would be converted to Unicode as they are read. Writing is also
-supported \- as Tcl strings are written to the channel they will
-automatically be converted to the specified encoding on output.
+\fInewSize\fR, an integer no greater than one million, is the size in bytes of
+any input or output buffers subsequently allocated for this channel.
+.TP
+\fB\-encoding\fR ?\fIname\fR?
+.
+Sets the encoding of the channel. \fIname\fR is either one of the names
+returned by \fBencoding names\fR, or
+.QW \fBbinary\fR
+\&. Input is converted from the encoding into Unicode, and output is converted
+from Unicode to the encoding.
.RS
.PP
-If a file contains pure binary data (for instance, a JPEG image), the
-encoding for the channel should be configured to be \fBbinary\fR. Tcl
-will then assign no interpretation to the data in the file and simply
-read or write raw bytes. The Tcl \fBbinary\fR command can be used to
-manipulate this byte-oriented data. It is usually better to set the
-\fB\-translation\fR option to \fBbinary\fR when you want to transfer
-binary data, as this turns off the other automatic interpretations of
-the bytes in the stream as well.
-.PP
-The default encoding for newly opened channels is the same platform-
-and locale-dependent system encoding used for interfacing with the
-operating system, as returned by \fBencoding system\fR.
+\fBbinary\fR is an alias for \fBiso8859-1\fR: Each byte read from the
+channel becomes the Unicode character having the same value as that byte, and
+each character written to the channel becomes a single byte in the output,
+allowing Tcl to work seamlessly with binary data as long as each "character" in
+the data remains in the range of 0 to 255 so that there is no distinction between
+binary data and text. For example, A JPEG image can be read from a
+\fBbinary\fR channel, manipulated, and then written back to a \fBbinary\fR
+channel.
+
+For working with binary data \fB\-translation binary\fR is usually used
+instead, as it sets the encoding to \fBbinary\fR and also disables other
+translations on the channel.
+.PP
+The encoding of a new channel is the value of \fBencoding system\fR,
+which returns the platform- and locale-dependent system encoding used to
+interface with the operating system,
.RE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
-\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
-.
-This option supports DOS file systems that use Control-z (\ex1A) as an
-end of file marker. If \fIchar\fR is not an empty string, then this
-character signals end-of-file when it is encountered during input.
-For output, the end-of-file character is output when the channel is
-closed. If \fIchar\fR is the empty string, then there is no special
-end of file character marker. For read-write channels, a two-element
-list specifies the end of file marker for input and output,
-respectively. As a convenience, when setting the end-of-file
-character for a read-write channel you can specify a single value that
-will apply to both reading and writing. When querying the end-of-file
-character of a read-write channel, a two-element list will always be
-returned. The default value for \fB\-eofchar\fR is the empty string
-in all cases except for files under Windows. In that case the
-\fB\-eofchar\fR is Control-z (\ex1A) for reading and the empty string
-for writing.
-The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f;
-attempting to set \fB\-eofchar\fR to a value outside of this range will
-generate an error.
-.TP
-\fB\-translation\fR \fImode\fR
-.TP
-\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR
-.
-In Tcl scripts the end of a line is always represented using a single
-newline character (\en). However, in actual files and devices the end
-of a line may be represented differently on different platforms, or
-even for different devices on the same platform. For example, under
-UNIX newlines are used in files, whereas carriage-return-linefeed
-sequences are normally used in network connections. On input (i.e.,
-with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system
-automatically translates the external end-of-line representation into
-newline characters. Upon output (i.e., with \fBchan puts\fR), the I/O
-system translates newlines to the external end-of-line representation.
-The default translation mode, \fBauto\fR, handles all the common cases
-automatically, but the \fB\-translation\fR option provides explicit
-control over the end of line translations.
+\fB\-eofchar\fR \fB{\fIchar outChar\fB}\fR
+.
+\fIchar\fR signals the end of the data when it is encountered in the input.
+For output, \fIoutChar\fR is added when the channel is closed. If \fIchar\fR
+is the empty string, there is no special character that marks the end of the
+data. For read-write channels, one end-of-file character for input and another
+for output may be given. When only one end-of-file character is given it is
+applied to input only.
+
+The default value is the empty string, except that under Windows the default
+value for reading is Control-z (\ex1A). The acceptable range is \ex01 -
+\ex7F. A value outside this range results in an error.
+.VS "TCL8.7 TIP656"
+.TP
+\fB\-profile\fR \fIprofile\fR
+.
+Specifies the encoding profile to be used on the channel. The encoding
+transforms in use for the channel's input and output will then be subject to the
+rules of that profile. Any failures will result in a channel error. See
+\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding
+profiles.
+.VE "TCL8.7 TIP656"
+.TP
+\fB\-translation\fR \fItranslation\fR
+.TP
+\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR
+.
+In Tcl a single line feed (\en) represents the end of a line. However,
+at the destination the end of a line may be represented differently on
+different platforms, or even for different devices on the same platform. For
+example, under UNIX line feed is used in files and a
+carriage-return-linefeed sequence is normally used in network connections.
+Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each
+external end-of-line character is translated into a line feed. On
+output, e.g. with \fBchan puts\fR, each line feed is translated to the external
+end-of-line character. The default translation, \fBauto\fR, handles all the common
+cases, and \fB\-translation\fR provides explicit control over the end-of-line
+character.
.RS
.PP
-The value associated with \fB\-translation\fR is a single item for
-read-only and write-only channels. The value is a two-element list for
-read-write channels; the read translation mode is the first element of
-the list, and the write translation mode is the second element. As a
-convenience, when setting the translation mode for a read-write channel
-you can specify a single value that will apply to both reading and
-writing. When querying the translation mode of a read-write channel, a
-two-element list will always be returned. The following values are
-currently supported:
+Returns the input translation for a read-only channel, the output translation
+for a write-only channel, and both the input translation and the the output
+translation for a read-write channel. When two translations are given, they
+are the input and output translation, respectively. When only one translation
+is given for a read-write channel, it is the translation for both input and
+output. The following values are currently supported:
.TP
\fBauto\fR
.
-As the input translation mode, \fBauto\fR treats any of newline
-(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by
-a newline (\fBcrlf\fR) as the end of line representation. The end of
-line representation can even change from line-to-line, and all cases
-are translated to a newline. As the output translation mode,
-\fBauto\fR chooses a platform specific representation; for sockets on
-all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses
-\fBlf\fR, and for the various flavors of Windows it chooses
-\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR
-for both input and output.
+The default. For input each occurrence of a line feed (\fBlf\fR), carriage
+return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is
+translated into a line feed. For output, each line feed is translated into a
+platform-specific representation: For all Unix variants it is \fBlf\fR, and
+for all Windows variants it is \fBcrlf\fR, except that for sockets on all
+platforms it is \fBcrlf\fR for both input and output.
.TP
\fBbinary\fR
.
-No end-of-line translations are performed. This is nearly identical
-to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets
-the end-of-file character to the empty string (which disables it) and
-sets the encoding to \fBbinary\fR (which disables encoding filtering).
-See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more
-information.
+Like \fBlf\fR, no end-of-line translation is performed, but in addition,
+\fB\-eofchar\fR is set to the empty string to disable it, and \fB\-encoding\fR
+is set to \fBbinary\fR. With this one setting, a channel is fully configured
+for binary input and output.
.TP
\fBcr\fR
.
-The end of a line in the underlying file or device is represented by a
-single carriage return character. As the input translation mode,
-\fBcr\fR mode converts carriage returns to newline characters. As the
-output translation mode, \fBcr\fR mode translates newline characters
-to carriage returns.
+The end of a line is represented in the external data by a single carriage
+return character. For input, each carriage return is translated to a line
+feed, and for output each line feed character is translated to a carriage
+return.
.TP
\fBcrlf\fR
.
-The end of a line in the underlying file or device is represented by a
-carriage return character followed by a linefeed character. As the
-input translation mode, \fBcrlf\fR mode converts
-carriage-return-linefeed sequences to newline characters. As the
-output translation mode, \fBcrlf\fR mode translates newline characters
-to carriage-return-linefeed sequences. This mode is typically used on
-Windows platforms and for network connections.
+The end of a line is represented in the external data by a carriage return
+character followed by a line feed. For input, each carriage-return-linefeed
+sequence is translated to a line feed. For output, each line feed is
+translated to a carriage-return-linefeed sequence. This translation is
+typically used for network connections, and also on Windows systems.
.TP
\fBlf\fR
.
-The end of a line in the underlying file or device is represented by a
-single newline (linefeed) character. In this mode no translations
-occur during either input or output. This mode is typically used on
-UNIX platforms.
+The end of a line in the external data is represented by a line feed so no
+translations occur during either input or output. This translation is
+typically used on UNIX platforms,
.RE
.RE
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
-Copy data from the channel \fIinputChan\fR, which must have been
-opened for reading, to the channel \fIoutputChan\fR, which must have
-been opened for writing. The \fBchan copy\fR command leverages the
-buffering in the Tcl I/O system to avoid extra copies and to avoid
-buffering too much data in main memory when copying large files to
-slow destinations like network sockets.
+Copies data from \fIinputChan\fR to \fIoutputChan\fR, leveraging internal
+buffers to avoid extra copies and to avoid buffering too much data in main
+memory when copying large files to slow destinations like network sockets.
.RS
.PP
-The \fBchan copy\fR command transfers data from \fIinputChan\fR until
-end of file or \fIsize\fR bytes or characters have been transferred;
-\fIsize\fR is in bytes if the two channels are using the same encoding,
-and is in characters otherwise. If no \fB\-size\fR argument is given,
-then the copy goes until end of file. All the data read from
-\fIinputChan\fR is copied to \fIoutputChan\fR. Without the
-\fB\-command\fR option, \fBchan copy\fR blocks until the copy is
-complete and returns the number of bytes or characters (using the same
-rules as for the \fB\-size\fR option) written to \fIoutputChan\fR.
-.PP
-The \fB\-command\fR argument makes \fBchan copy\fR work in the
-background. In this case it returns immediately and the
-\fIcallback\fR is invoked later when the copy completes. The
-\fIcallback\fR is called with one or two additional arguments that
-indicates how many bytes were written to \fIoutputChan\fR. If an
-error occurred during the background copy, the second argument is the
-error string associated with the error. With a background copy, it is
-not necessary to put \fIinputChan\fR or \fIoutputChan\fR into
-non-blocking mode; the \fBchan copy\fR command takes care of that
-automatically. However, it is necessary to enter the event loop by
-using the \fBvwait\fR command or by using Tk.
-.PP
-You are not allowed to do other I/O operations with \fIinputChan\fR or
-\fIoutputChan\fR during a background \fBchan copy\fR. If either
-\fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in
-progress, the current copy is stopped and the command callback is
-\fInot\fR made. If \fIinputChan\fR is closed, then all data already
-queued for \fIoutputChan\fR is written out.
-.PP
-Note that \fIinputChan\fR can become readable during a background
-copy. You should turn off any \fBchan event\fR or \fBfileevent\fR
-handlers during a background copy so those handlers do not interfere
-with the copy. Any I/O attempted by a \fBchan event\fR or
-\fBfileevent\fR handler will get a
-.QW "channel busy"
-error.
-.PP
-\fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR
-and \fIoutputChan\fR according to the \fB\-translation\fR option for
-these channels (see \fBchan configure\fR above). The translations
-mean that the number of bytes read from \fIinputChan\fR can be
-different than the number of bytes written to \fIoutputChan\fR. Only
-the number of bytes written to \fIoutputChan\fR is reported, either as
-the return value of a synchronous \fBchan copy\fR or as the argument
-to the callback for an asynchronous \fBchan copy\fR.
-.PP
-\fBChan copy\fR obeys the encodings and character translations
-configured for the channels. This means that the incoming characters
-are converted internally first UTF-8 and then into the encoding of the
-channel \fBchan copy\fR writes to (see \fBchan configure\fR above for
-details on the \fB\-encoding\fR and \fB\-translation\fR options). No
-conversion is done if both channels are set to encoding \fBbinary\fR
-and have matching translations. If only the output channel is set to
-encoding \fBbinary\fR the system will write the internal UTF-8
-representation of the incoming characters. If only the input channel
-is set to encoding \fBbinary\fR the system will assume that the
-incoming bytes are valid UTF-8 characters and convert them according
-to the output encoding. The behaviour of the system for bytes which
-are not valid UTF-8 characters is undefined in this case.
+If \fB\-size\fR is given, the size is in bytes if the two channels have the
+same encoding and in characters otherwise, and only that amount is copied.
+Otherwise, all data until the end of the file is copied.
+
+\fBchan copy\fR blocks until the copy is complete and returns the number of
+bytes or characters written to \fIoutputChan\fR.
+.PP
+If \fB\-command\fR is given, \fBchan copy\fR returns immediately, the copy is
+carried out in the background, and then \fIcallback\fR is called with the
+number of bytes written to \fIoutputChan\fR as its first argument, and the
+error message for any error that occurred as its second argument.
+\fIinputChan\fR and \fIoutputChan\fR are automatically configured for
+non-blocking mode if needed. Background copying only works correctly if the
+event loop is active, e.g. via \fBvwait\fR or Tk.
+.PP
+During a background copy no other read or write operation may be performed on
+\fIinputChan\fR or \fIoutputChan\fR. If either \fIinputChan\fR or
+\fIoutputChan\fR is closed while the copy is in progress copying ceases and
+\fBno\fR callback is made. If \fIinputChan\fR is closed all data already queued
+is written to \fIoutputChan\fR.
+.PP
+The should be no event handler established for \fIinputChan\fR because it may
+become readable during a background copy. An attempt to read or write
+from within an event handler results result in the error, "channel busy".
+.PP
+Due to end-of-line translation the number of bytes read from \fIinputChan\fR
+may be different than the number of bytes written to \fIoutputChan\fR. Only
+the number of bytes written to \fIoutputChan\fR is reported.
+.PP
+\fBChan copy\fR reads the data according to the \fB\-encoding\fR,
+\fB\-translation\fR, and \fB\-eofchar\fR of the source and writes to the
+destination according to the configuration for that channel. If the encoding
+and translation of both channels is \fBbinary\fR and the \fB\-eofchar\fR of
+both channels is the empty string, an identical copy is made. If only the
+encoding of the destination is \fBbinary\fR, Tcl's internal modified UTF-8
+representation of the characters read from the source is written to the
+destination. If only the encoding of the source is \fBbinary\fR, each byte read
+becomes one Unicode character in the range of 0 to 255, and that character is
+subject to the encoding and translation of the destination as it is written.
.RE
.TP
\fBchan create \fImode cmdPrefix\fR
.
-This subcommand creates a new script level channel using the command
-prefix \fIcmdPrefix\fR as its handler. Any such channel is called a
-\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR,
-must be a non-empty list, and should provide the API described in the
-\fBrefchan\fR manual page. The handle of the new channel is
-returned as the result of the \fBchan create\fR command, and the
-channel is open. Use either \fBclose\fR or \fBchan close\fR to remove
-the channel.
+Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR
+as its handler, and returns the name of the channel. \fBcmdPrefix\fR is the
+first words of a command that provides the interface for a \fBrefchan\fR.
.RS
.PP
-The argument \fImode\fR specifies if the new channel is opened for
-reading, writing, or both. It has to be a list containing any of the
-strings
+\fBImode\fR is a list of one or more of the strings
.QW \fBread\fR
or
-.QW \fBwrite\fR .
-The list must have at least one
-element, as a channel you can neither write to nor read from makes no
-sense. The handler command for the new channel must support the chosen
-mode, or an error is thrown.
-.PP
-The command prefix is executed in the global namespace, at the top of
-call stack, following the appending of arguments as described in the
-\fBrefchan\fR manual page. Command resolution happens at the
-time of the call. Renaming the command, or destroying it means that
-the next call of a handler method may fail, causing the channel
-command invoking the handler to fail as well. Depending on the
-subcommand being invoked, the error message may not be able to explain
-the reason for that failure.
-.PP
-Every channel created with this subcommand knows which interpreter it
-was created in, and only ever executes its handler command in that
-interpreter, even if the channel was shared with and/or was moved into
-a different interpreter. Each reflected channel also knows the thread
-it was created in, and executes its handler command only in that
-thread, even if the channel was moved into a different thread. To this
-end all invocations of the handler are forwarded to the original
-thread by posting special events to it. This means that the original
-thread (i.e. the thread that executed the \fBchan create\fR command)
-must have an active event loop, i.e. it must be able to process such
-events. Otherwise the thread sending them will \fIblock
-indefinitely\fR. Deadlock may occur.
-.PP
-Note that this permits the creation of a channel whose two endpoints
-live in two different threads, providing a stream-oriented bridge
-between these threads. In other words, we can provide a way for
-regular stream communication between threads instead of having to send
-commands.
-.PP
-When a thread or interpreter is deleted, all channels created with
-this subcommand and using this thread/interpreter as their computing
-base are deleted as well, in all interpreters they have been shared
-with or moved into, and in whatever thread they have been transferred
-to. While this pulls the rug out under the other thread(s) and/or
-interpreter(s), this cannot be avoided. Trying to use such a channel
-will cause the generation of a regular error about unknown channel
-handles.
-.PP
-This subcommand is \fBsafe\fR and made accessible to safe
-interpreters. While it arranges for the execution of arbitrary Tcl
-code the system also makes sure that the code is always executed
-within the safe interpreter.
+.QW \fBwrite\fR ,
+indicating whether the channel is a read channel, a write channel, or both.
+It is an error if the handler does not support the chosen mode.
+.PP
+The handler is called as needed from the global namespace at the top level, and
+command resolution happens there at the time of the call. If the handler is
+renamed or deleted any subsequent attempt to call it is an error, which may
+not be able to describe the failure.
+.PP
+The handler is always called in the interpreter and thread it was created in,
+even if the channel was shared with or moved into a different interpreter in a
+different thread. This is achieved through event dispatch, so if the event
+loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or
+using Tk, the thread performing the channel operation \fIblocks
+indefinitely\fR, resulting in deadlock.
+.PP
+One side of a channel may be in one thread while the other side is in a
+different thread, providing a stream-oriented bridge between the threads. This
+provides a method for regular stream communication between threads as an
+alternative to sending commands.
+.PP
+When the interpreter the handler is in is deleted each channel associated with
+the handler is deleted as well, regardless of which interpreter or thread it
+is currently in or shared with.
+.PP
+\fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The
+handler is always called in the safe interpreter it was created in.
.RE
.TP
-\fBchan eof \fIchannelId\fR
-.
-Test whether the last input operation on the channel called
-\fIchannelId\fR failed because the end of the data stream was reached,
-returning 1 if end-of-file was reached, and 0 otherwise.
-.TP
-\fBchan event \fIchannelId event\fR ?\fIscript\fR?
-.
-Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile
-event handler\fR to be called whenever the channel called
-\fIchannelId\fR enters the state described by \fIevent\fR (which must
-be either \fBreadable\fR or \fBwritable\fR); only one such handler may
-be installed per event per channel at a time. If \fIscript\fR is the
-empty string, the current handler is deleted (this also happens if the
-channel is closed or the interpreter deleted). If \fIscript\fR is
-omitted, the currently installed script is returned (or an empty
-string if no such handler is installed). The callback is only
-performed if the event loop is being serviced (e.g. via \fBvwait\fR or
-\fBupdate\fR).
-.RS
-.PP
-A file event handler is a binding between a channel and a script, such
-that the script is evaluated whenever the channel becomes readable or
-writable. File event handlers are most commonly used to allow data to
-be received from another process on an event-driven basis, so that the
-receiver can continue to interact with the user or with other channels
-while waiting for the data to arrive. If an application invokes
-\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is
-no input data available, the process will block; until the input data
-arrives, it will not be able to service other events, so it will
-appear to the user to
-.QW "freeze up" .
-With \fBchan event\fR, the
-process can tell when data is present and only invoke \fBchan gets\fR
-or \fBchan read\fR when they will not block.
-.PP
-A channel is considered to be readable if there is unread data
-available on the underlying device. A channel is also considered to
-be readable if there is unread data in an input buffer, except in the
-special case where the most recent attempt to read from the channel
-was a \fBchan gets\fR call that could not find a complete line in the
-input buffer. This feature allows a file to be read a line at a time
-in non-blocking mode using events. A channel is also considered to be
-readable if an end of file or error condition is present on the
-underlying file or device. It is important for \fIscript\fR to check
-for these conditions and handle them appropriately; for example, if
-there is no special check for end of file, an infinite loop may occur
-where \fIscript\fR reads no data, returns, and is immediately invoked
-again.
-.PP
-A channel is considered to be writable if at least one byte of data
-can be written to the underlying file or device without blocking, or
-if an error condition is present on the underlying file or device.
-Note that client sockets opened in asynchronous mode become writable
-when they become connected or if the connection fails.
-.PP
-Event-driven I/O works best for channels that have been placed into
-non-blocking mode with the \fBchan configure\fR command. In blocking
-mode, a \fBchan puts\fR command may block if you give it more data
-than the underlying file or device can accept, and a \fBchan gets\fR
-or \fBchan read\fR command will block if you attempt to read more data
-than is ready; no events will be processed while the commands block.
-In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
-gets\fR never block.
-.PP
-The script for a file event is executed at global level (outside the
-context of any Tcl procedure) in the interpreter in which the \fBchan
-event\fR command was invoked. If an error occurs while executing the
-script then the command registered with \fBinterp bgerror\fR is used
-to report the error. In addition, the file event handler is deleted
-if it ever returns an error; this is done in order to prevent infinite
-loops due to buggy handlers.
-.RE
+\fBchan eof \fIchannelName\fR
+.
+Returns 1 if the last read on the channel failed because the end of the data
+was already reached, and 0 otherwise.
.TP
-\fBchan flush \fIchannelId\fR
+\fBchan event \fIchannelName event\fR ?\fIscript\fR?
.
-Ensures that all pending output for the channel called \fIchannelId\fR
-is written.
+Arranges for the given script, called a \fBchannel event hndler\fR, to be
+called whenever the given event, one of
+.QW \fBreadable\fR
+or
+.QW \fBwritable\fR
+occurs on the given channel, replacing any script that was previously set. If
+\fIscript\fR is the empty string the current handler is deleted. It is also
+deleted when the channel is closed. If \fIscript\fR is omitted, either the
+existing script or the empty string is returned. The event loop must be
+entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to
+be evaluated.
+
.RS
.PP
-If the channel is in blocking mode the command does not return until
-all the buffered output has been flushed to the channel. If the
-channel is in non-blocking mode, the command may return before all
-buffered output has been flushed; the remainder will be flushed in the
-background as fast as the underlying file or device is able to absorb
-it.
+\fIscript\fR is evaluated at the global level in the interpreter it was
+established in. Any resulting error is handled in the background, i.e. via
+\fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy
+handler, the handler is deleted if \fIscript\fR returns an error so that it is
+not evaluated again.
+
+.PP
+Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in
+blocking mode may block until data becomes available, become during which the
+thread is unable to perform other work or respond to events on other channels.
+This could cause the application to appear to
+.QW "freeze up"
+\&.
+Channel event handlers allow events on the channel to direct channel handling
+so that the reader or writer can continue to perform other processing while
+waiting for a channel to become available and then handle channel operations
+when the channel is ready for the operation.
+.PP
+A
+.QW readable
+event occurs when there is data that can be read from the channel and also when
+there is an error on the channel. The handler must check for these conditions
+and handle them appropriately. For example, a handler that does not check
+whether the end of the data has been reached may be repeatedly evaluated in a
+busy loop until the channel is closed.
+.PP
+A
+.QW writable
+event occurs when at least one byte of data can be written, or if there is an
+error on the channel. A client socket opened in non-blocking mode becomes
+writable when it becomes connected or if the connection fails.
+.PP
+Event-driven channel handling works best for channels in non-blocking mode. A
+channel in blocking mode blocks when \fBchan puts\fR writes more data than the
+channel can accept at the moment, and when \fBchan gets\fR or \fBchan read\fR
+requests more data than is currently available. When a channel blocks, the
+thread can not do any other processing or service any other events. A channel
+in non-blocking mode allows a thread to carry on with other work and get back
+to the channel at the right time.
.RE
.TP
-\fBchan gets \fIchannelId\fR ?\fIvarName\fR?
-.
-Reads the next line from the channel called \fIchannelId\fR. If
-\fIvarName\fR is not specified, the result of the command will be the
-line that has been read (without a trailing newline character) or an
-empty string upon end-of-file or, in non-blocking mode, if the data
-available is exhausted. If \fIvarName\fR is specified, the line that
-has been read will be written to the variable called \fIvarName\fR and
-result will be the number of characters that have been read or -1 if
-end-of-file was reached or, in non-blocking mode, if the data
-available is exhausted.
+\fBchan flush \fIchannelName\fR
+.
+For a channel in blocking mode, flushes all buffered output to the destination,
+and then returns. For a channel in non-blocking mode, returns immediately
+while all buffered output is flushed in the background as soon as possible.
+.TP
+\fBchan gets \fIchannelName\fR ?\fIvarName\fR?
+.
+Returns the next line from the channel, removing the trailing line feed, or if
+\fIvarName\fR is given, assigns the line to that variable and returns the
+number of characters read.
+the line that was read, removing the trailing line feed, or returns the
+empty string if there is no data to return and the end of the file has been
+reached, or in non-blocking mode, if no complete line is currently available.
+If \fIvarName\fR is given, assigns the line that was read to variable named
+\fIvarName\fR and returns the number of characters that were read, or -1 if
+there no data available and the end of the channel was reached or the channel
+is in non-blocking mode.
.RS
.PP
-If an end-of-file occurs while part way through reading a line, the
-partial line will be returned (or written into \fIvarName\fR). When
-\fIvarName\fR is not specified, the end-of-file case can be
-distinguished from an empty line using the \fBchan eof\fR command, and
-the partial-line-but-non-blocking case can be distinguished with the
-\fBchan blocked\fR command.
+If the end of the channel is reached the data read so far is returned or
+assigned to \fIvarName\fR. When \fIvarName\fR is not given, \fBchan eof\fR may
+indicate that the empty string means that the end of the data has been reached,
+and \fBchan blocked\fR may indicate that that the empty string means there
+isn't currently enough data do return the next line.
.RE
.TP
\fBchan names\fR ?\fIpattern\fR?
.
-Produces a list of all channel names. If \fIpattern\fR is specified,
-only those channel names that match it (according to the rules of
-\fBstring match\fR) will be returned.
+Returns a list of all channel names, or if \fIpattern\fR is given, only those
+names that match according to the rules of \fBstring match\fR.
.TP
-\fBchan pending \fImode channelId\fR
+\fBchan pending \fImode channelName\fR
.
-Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR,
-returns the number of
-bytes of input or output (respectively) currently buffered
-internally for \fIchannelId\fR (especially useful in a readable event
-callback to impose application-specific limits on input line lengths to avoid
-a potential denial-of-service attack where a hostile user crafts
-an extremely long line that exceeds the available memory to buffer it).
-Returns -1 if the channel was not opened for the mode in question.
+Returns the number of bytes of input
+when \fImode\fR is
+.QW\fBinput\fR
+, or output when \fImode\fR is
+.QW\fBoutput\fR
+, that are currently internally buffered for the channel. Useful in a readable
+event callback to impose limits on input line length to avoid a potential
+denial-of-service attack where an extremely long line exceeds the available
+memory to buffer it. Returns -1 if the channel was not opened for the mode in
+question.
.TP
\fBchan pipe\fR
-.VS 8.6
-Creates a standalone pipe whose read- and write-side channels are
-returned as a 2-element list, the first element being the read side and
-the second the write side. Can be useful e.g. to redirect
-separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do
-this, spawn with "2>@" or
-">@" redirection operators onto the write side of a pipe, and then
-immediately close it in the parent. This is necessary to get an EOF on
-the read side once the child has exited or otherwise closed its output.
+Creates a pipe, i.e. a readable channel and a writable channel, and returns the
+names of the readable channel and the writable channel. Data written to the
+writable channel can be read from the readable channel. Because the pipe is a
+real system-level pipe, it can be connected to other processes using
+redirection. For example, to redirect \fBstderr\fR from a subprocess into one
+channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each
+onto the writable side of a pipe, closing the writable side immediately
+thereafter so that EOF is signaled on the read side once the subprocess has
+closed its output, typically on exit.
.RS
.PP
-Note that the pipe buffering semantics can vary at the operating system level
-substantially; it is not safe to assume that a write performed on the output
-side of the pipe will appear instantly to the input side. This is a
-fundamental difference and Tcl cannot conceal it. The overall stream semantics
-\fIare\fR compatible, so blocking reads and writes will not see most of the
-differences, but the details of what exactly gets written when are not. This
-is most likely to show up when using pipelines for testing; care should be
-taken to ensure that deadlocks do not occur and that potential short reads are
-allowed for.
+Due to buffering, data written to one side of a pipe might not immediately
+become available on the other side. Tcl's own buffers can be configured via
+\fBchan configure -buffering\fR, but overall behaviour still depends on
+operating system buffers outside of Tcl's control. Once the write side of the
+channel is closed, any data remaining in the buffers is flushed through to the
+read side. It may be useful to arrange for the connected process to flush at
+some point after writing to the channel or to have it use some system-provided
+mechanism to configure buffering. When two pipes are connected to the same
+process, one to send data to the process, and one to read data from the
+process, a deadlock may occur if the channels are in blocking mode: If
+reading, the channel may block waiting for data that can never come because
+buffers are only flushed on subsequent writes, and if writing, the channel may
+block while waiting for the buffers to become free, which can never happen
+because the reader can not read while the writer is blocking. To avoid this
+issue, either put the channels into non-blocking mode and use event handlers,
+or place the read channel and the write channel in separate interpreters in
+separate threads.
.RE
-.VE 8.6
-.TP
-\fBchan pop \fIchannelId\fR
-.VS 8.6
-Removes the topmost transformation from the channel \fIchannelId\fR, if there
-is any. If there are no transformations added to \fIchannelId\fR, this is
-equivalent to \fBchan close\fR of that channel. The result is normally the
-empty string, but can be an error in some situations (i.e. where the
-underlying system stream is closed and that results in an error).
-.VE 8.6
-.TP
-\fBchan postevent \fIchannelId eventSpec\fR
-.
-This subcommand is used by command handlers specified with \fBchan
-create\fR. It notifies the channel represented by the handle
-\fIchannelId\fR that the event(s) listed in the \fIeventSpec\fR have
-occurred. The argument has to be a list containing any of the strings
-\fBread\fR and \fBwrite\fR. The list must contain at least one
-element as it does not make sense to invoke the command if there are
-no events to post.
+.TP
+\fBchan pop \fIchannelName\fR
+Removes the topmost transformation handler from the channel if there is one,
+and closes the channel otherwise. The result is normally the empty string, but
+may be an error in some situations, e.g. when closing the underlying resource
+results in an error.
+.TP
+\fBchan postevent \fIchannelName eventSpec\fR
+.
+For use by handlers established with \fBchan create\fR. Notifies Tcl that
+that one or more event(s) listed in \fIeventSpec\fR, each of which is either
+.QW\fBread\fR
+or
+.QW\fBwrite\fR.
+, have occurred.
.RS
.PP
-Note that this subcommand can only be used with channel handles that
-were created/opened by \fBchan create\fR. All other channels will
-cause this subcommand to report an error.
-.PP
-As only the Tcl level of a channel, i.e. its command handler, should
-post events to it we also restrict the usage of this command to the
-interpreter that created the channel. In other words, posting events
-to a reflected channel from an interpreter that does not contain it's
-implementation is not allowed. Attempting to post an event from any
-other interpreter will cause this subcommand to report an error.
-.PP
-Another restriction is that it is not possible to post events that the
-I/O core has not registered an interest in. Trying to do so will cause
-the method to throw an error. See the command handler method
-\fBwatch\fR described in \fBrefchan\fR, the document specifying
-the API of command handlers for reflected channels.
-.PP
-This command is \fBsafe\fR and made accessible to safe interpreters.
-It can trigger the execution of \fBchan event\fR handlers, whether in the
-current interpreter or in other interpreters or other threads, even
-where the event is posted from a safe interpreter and listened for by
-a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR
-executed in the interpreter that set them up.
+For use only by handlers for a channel created by \fBchan create\fR. It is an
+error to post an event for any other channel.
+.PP
+Since only the handler for a reflected channel channel should post events it is
+an error to post an event from any interpreter other than the interpreter that
+created the channel.
+.PP
+It is an error to post an event that the channel has no interest in. See
+\fBwatch\fR in the \fBrefchan\fR documentation for more information
+.PP
+\fBchan postevent\fR is available in safe interpreters, as any handler for a
+reflected channel would have been created, and will be evaluated in that
+interpreter as well.
.RE
.TP
-\fBchan push \fIchannelId cmdPrefix\fR
-.VS 8.6
-Adds a new transformation on top of the channel \fIchannelId\fR. The
-\fIcmdPrefix\fR argument describes a list of one or more words which represent
-a handler that will be used to implement the transformation. The command
-prefix must provide the API described in the \fBtranschan\fR manual page.
-The result of this subcommand is a handle to the transformation. Note that it
-is important to make sure that the transformation is capable of supporting the
-channel mode that it is used with or this can make the channel neither
-readable nor writable.
-.VE 8.6
-.TP
-\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR
-.
-Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a
-newline character. A trailing newline character is written unless the
-optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is
-omitted, the string is written to the standard output channel,
+\fBchan push \fIchannelName cmdPrefix\fR
+Adds a new transformation handler on top of the channel and returns a handle
+for the transformation. \fIcmdPrefix\fR is the first words of a command that
+provides the interface documented for \fBtranschan\fR, and transforms data on
+the channel, It is an error if handler does not support the mode(s) the channel
+is in.
+.TP
+\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR
+.
+Writes \fIstring\fR and a line feed to the channel. If \fB\-nonewline\fR is
+given, the trailing line feed is not written. The default channel is
\fBstdout\fR.
.RS
.PP
-Newline characters in the output are translated by \fBchan puts\fR to
-platform-specific end-of-line sequences according to the currently
-configured value of the \fB\-translation\fR option for the channel
-(for example, on PCs newlines are normally replaced with
-carriage-return-linefeed sequences; see \fBchan configure\fR above for
-details).
-.PP
-Tcl buffers output internally, so characters written with \fBchan
-puts\fR may not appear immediately on the output file or device; Tcl
-will normally delay output until the buffer is full or the channel is
-closed. You can force output to appear immediately with the \fBchan
-flush\fR command.
-.PP
-When the output buffer fills up, the \fBchan puts\fR command will
-normally block until all the buffered data has been accepted for
-output by the operating system. If \fIchannelId\fR is in non-blocking
-mode then the \fBchan puts\fR command will not block even if the
-operating system cannot accept the data. Instead, Tcl continues to
-buffer the data and writes it in the background as fast as the
-underlying file or device can accept it. The application must use the
-Tcl event loop for non-blocking output to work; otherwise Tcl never
-finds out that the file or device is ready for more output data. It
-is possible for an arbitrarily large amount of data to be buffered for
-a channel in non-blocking mode, which could consume a large amount of
-memory. To avoid wasting memory, non-blocking I/O should normally be
-used in an event-driven fashion with the \fBchan event\fR command
-(do not invoke \fBchan puts\fR unless you have recently been notified
-via a file event that the channel is ready for more output data).
+Each line feed in the output is translated according to the configuration of
+\fB\-translation\fR.
+.PP
+Because Tcl internally buffers output, characters written to a channel may not
+immediately be available at the destination. Tcl normally delays output until
+the buffer is full or the channel is closed. \fBchan flush\fR forces output in
+the direction of the destination.
+.PP
+When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks
+until space in the buffer is available again, but for a channel in non-blocking
+mode, it returns immediately and the data is written in the background as fast
+possible, constrained by the speed at which as the destination accepts it.
+Output to a channel in non-blocking mode only works properly when the
+application enters the event loop, giving Tcl a chance to find out that the
+destination is ready to accept more data. When a channel is in non-blocking
+mode, Tcl's internal buffers can hold an arbitrary amount of data, possibly
+consuming a large amount of memory. To avoid wasting memory, channels in
+non-blocking mode should normally be handled using \fBchan event\fR, where the
+application only invokes \fBchan puts\fR after being recently notified through
+a file event handler that the channel is ready for more output data.
.RE
.TP
-\fBchan read \fIchannelId\fR ?\fInumChars\fR?
+\fBchan read \fIchannelName\fR ?\fInumChars\fR?
.TP
-\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR
+\fBchan read \fR?\fB\-nonewline\fR? \fIchannelName\fR
.
-In the first form, the result will be the next \fInumChars\fR
-characters read from the channel named \fIchannelId\fR; if
-\fInumChars\fR is omitted, all characters up to the point when the
-channel would signal a failure (whether an end-of-file, blocked or
-other error condition) are read. In the second form (i.e. when
-\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be
-given to indicate that any trailing newline in the string that has
-been read should be trimmed.
+Reads and returns the next \fInumChars\fR characters from the channel. If
+\fInumChars\fR is omitted, all available characters up to the end of the file
+are read, or if the channel is in non-blocking mode, all currently-available
+characters are read. If there is an error on the channel, reading ceases and
+an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR
+may be given, causing any any trailing line feed to be trimmed.
.RS
.PP
-If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not
-read as many characters as requested: once all available input has
-been read, the command will return the data that is available rather
-than blocking for more input. If the channel is configured to use a
-multi-byte encoding, then there may actually be some bytes remaining
-in the internal buffers that do not form a complete character. These
-bytes will not be returned until a complete character is available or
-end-of-file is reached. The \fB\-nonewline\fR switch is ignored if
-the command returns before reaching the end of the file.
-.PP
-\fBChan read\fR translates end-of-line sequences in the input into
-newline characters according to the \fB\-translation\fR option for the
-channel (see \fBchan configure\fR above for a discussion on the ways
-in which \fBchan configure\fR will alter input).
-.PP
-When reading from a serial port, most applications should configure
-the serial port channel to be non-blocking, like this:
-.PP
-.CS
-\fBchan configure \fIchannelId \fB\-blocking \fI0\fR.
-.CE
-.PP
-Then \fBchan read\fR behaves much like described above. Note that
-most serial ports are comparatively slow; it is entirely possible to
-get a \fBreadable\fR event for each character read from them. Care
-must be taken when using \fBchan read\fR on blocking serial ports:
-.TP
-\fBchan read \fIchannelId numChars\fR
-.
-In this form \fBchan read\fR blocks until \fInumChars\fR have been
-received from the serial port.
-.TP
-\fBchan read \fIchannelId\fR
-.
-In this form \fBchan read\fR blocks until the reception of the
-end-of-file character, see \fBchan configure -eofchar\fR. If there no
-end-of-file character has been configured for the channel, then
-\fBchan read\fR will block forever.
+If the channel is in non-blocking mode, fewer characters than requested may be
+returned. If the channel is configured to use a multi-byte encoding, bytes
+that do not form a complete character are retained in the buffers until enough
+bytes to complete the character accumulate, or the end of the data is reached.
+\fB\-nonewline\fR is ignored if characters are returned before reaching the end
+of the file.
+.PP
+Each end-of-line sequence according to the value of \fB\-translation\fR is
+translated into a line feed.
+.PP
+When reading from a serial port, most applications should configure the serial
+port channel to be in non-blocking mode, but not necessarily use an event
+handler since most serial ports are comparatively slow. It is entirely
+possible to get a \fBreadable\fR event for each individual character. In
+blocking mode, \fBchan read\fR blocks forever when reading to the end of the
+data if there is no \fBchan configure -eofchar\fR configured for the channel.
.RE
.TP
-\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR?
+\fBchan seek \fIchannelName offset\fR ?\fIorigin\fR?
.
-Sets the current access position within the underlying data stream for
-the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to
-\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative)
-and \fIorigin\fR must be one of the following:
+Sets the current position for the data in the channel to integer \fIoffset\fR
+bytes relative to \fIorigin\fR. A negative offset moves the current position
+backwards from the origin. \fIorigin\fR is one of the
+following:
.RS
+.PP
.TP 10
\fBstart\fR
.
-The new access position will be \fIoffset\fR bytes from the start
-of the underlying file or device.
+The origin is the start of the data. This is the default.
.TP 10
\fBcurrent\fR
.
-The new access position will be \fIoffset\fR bytes from the current
-access position; a negative \fIoffset\fR moves the access position
-backwards in the underlying file or device.
+The origin is the current position.
.TP 10
\fBend\fR
.
-The new access position will be \fIoffset\fR bytes from the end of the
-file or device. A negative \fIoffset\fR places the access position
-before the end of file, and a positive \fIoffset\fR places the access
-position after the end of file.
-.PP
-The \fIorigin\fR argument defaults to \fBstart\fR.
+The origin is the end of the data.
.PP
-\fBChan seek\fR flushes all buffered output for the channel before the
-command returns, even if the channel is in non-blocking mode. It also
-discards any buffered and unread input. This command returns an empty
-string. An error occurs if this command is applied to channels whose
-underlying file or device does not support seeking.
+\fBChan seek\fR flushes all buffered output even if the channel is in
+non-blocking mode, discards any buffered and unread input, and returns the
+empty string or an error if the channel does not support seeking.
.PP
-Note that \fIoffset\fR values are byte offsets, not character offsets.
-Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
-not characters, unlike \fBchan read\fR.
+\fIoffset\fR values are byte offsets, not character offsets. Unlike \fBchan
+read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes,
+not characters,
.RE
.TP
-\fBchan tell \fIchannelId\fR
+\fBchan tell \fIchannelName\fR
.
-Returns a number giving the current access position within the
-underlying data stream for the channel named \fIchannelId\fR. This
-value returned is a byte offset that can be passed to \fBchan seek\fR
-in order to set the channel to a particular position. Note that this
-value is in terms of bytes, not characters like \fBchan read\fR. The
-value returned is -1 for channels that do not support seeking.
+Returns the offset in bytes of the current position in the underlying data, or
+-1 if the channel does not suport seeking. The value can be passed to \fBchan
+seek\fR to set current position to that offset.
.TP
-\fBchan truncate \fIchannelId\fR ?\fIlength\fR?
+\fBchan truncate \fIchannelName\fR ?\fIlength\fR?
.
-Sets the byte length of the underlying data stream for the channel
-named \fIchannelId\fR to be \fIlength\fR (or to the current byte
-offset within the underlying data stream if \fIlength\fR is
-omitted). The channel is flushed before truncation.
+Flushes the channel and truncates the data in the channel to \fIlength\fR
+bytes, or to the current position in bytes if \fIlength\fR is omitted.
.
.SH EXAMPLES
.PP
-This opens a file using a known encoding (CP1252, a very common encoding
-on Windows), searches for a string, rewrites that part, and truncates the
-file after a further two lines.
+In the following example a file is opened using the encoding CP1252, which is
+common on Windows, searches for a string, rewrites that part, and truncates the
+file two lines later.
.PP
.CS
set f [open somefile.txt r+]
@@ -782,7 +620,7 @@ set offset 0
\fI# Search for string "FOOBAR" in the file\fR
while {[\fBchan gets\fR $f line] >= 0} {
set idx [string first FOOBAR $line]
- if {$idx > -1} {
+ if {$idx >= 0} {
\fI# Found it; rewrite line\fR
\fBchan seek\fR $f [expr {$offset + $idx}]
@@ -803,12 +641,12 @@ while {[\fBchan gets\fR $f line] >= 0} {
\fBchan close\fR $f
.CE
.PP
-A network server that does echoing of its input line-by-line without
-preventing servicing of other connections at the same time.
+A network server that echoes its input line-by-line without
+preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
-proc log {message} {
+proc log message {
\fBchan puts\fR stdout $message
}
diff --git a/doc/class.n b/doc/class.n
index 198ae41..c48f52d 100644
--- a/doc/class.n
+++ b/doc/class.n
@@ -12,7 +12,7 @@
oo::class \- class of all classes
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBoo::class\fI method \fR?\fIarg ...\fR?
.fi
diff --git a/doc/classvariable.n b/doc/classvariable.n
new file mode 100644
index 0000000..70d9f13
--- /dev/null
+++ b/doc/classvariable.n
@@ -0,0 +1,78 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 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.
+'\"
+.TH classvariable n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+classvariable \- create link from local variable to variable in class
+.SH SYNOPSIS
+.nf
+package require tcl::oo
+
+\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBclassvariable\fR command is available within methods. It takes a series
+of one or more variable names and makes them available in the method's scope;
+those variable names must not be qualified and must not refer to array
+elements. The originating scope for the variables is the namespace of the
+class that the method was defined by. In other words, the referenced variables
+are shared between all instances of that class.
+.PP
+Note: This command is equivalent to the command \fBtypevariable\fR provided by
+the snit package in tcllib for approximately the same purpose. If used in a
+method defined directly on a class instance (e.g., through the
+\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just
+using:
+.PP
+.CS
+namespace upvar [namespace current] $var $var
+.CE
+.PP
+for each variable listed to \fBclassvariable\fR.
+.SH EXAMPLE
+This class counts how many instances of it have been made.
+.PP
+.CS
+oo::class create Counted {
+ initialise {
+ variable count 0
+ }
+
+ variable number
+ constructor {} {
+ \fBclassvariable\fR count
+ set number [incr count]
+ }
+
+ method report {} {
+ \fBclassvariable\fR count
+ puts "This is instance $number of $count"
+ }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+ \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+ \fI\(-> This is instance 2 of 3\fR
+$c report
+ \fI\(-> This is instance 3 of 3\fR
+.CE
+.SH "SEE ALSO"
+global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n)
+.SH KEYWORDS
+class, class variable, variable
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/clock.n b/doc/clock.n
index 3c408fc..5157ed1 100644
--- a/doc/clock.n
+++ b/doc/clock.n
@@ -8,7 +8,7 @@
.SH NAME
clock \- Obtain and manipulate dates and times
.SH "SYNOPSIS"
-package require \fBTcl 8.5\fR
+package require \fBTcl 8.5-\fR
.sp
\fBclock add\fR \fItimeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR?
.sp
@@ -89,10 +89,9 @@ have 59 or 61 seconds.
.TP
\fIunit\fR
One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR,
-\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or
-any unique prefix of such a word. Used in conjunction with \fIcount\fR
-to identify an interval of time, for example, \fI3 seconds\fR or
-\fI1 year\fR.
+\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR.
+Used in conjunction with \fIcount\fR to identify an interval of time,
+for example, \fI3 seconds\fR or \fI1 year\fR.
.SS "OPTIONS"
.TP
\fB\-base\fR time
@@ -175,8 +174,7 @@ given as its first argument. The remaining arguments (other than the
possible \fB\-timezone\fR, \fB\-locale\fR and \fB\-gmt\fR options)
are integers and keywords in alternation, where the keywords are chosen
from \fBseconds\fR, \fBminutes\fR, \fBhours\fR,
-\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or
-any unique prefix of such a word.
+\fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR.
.PP
Addition of seconds, minutes and hours is fairly straightforward;
the given time increment (times sixty for minutes, or 3600 for hours)
@@ -213,7 +211,8 @@ the given time to a calendar day and time of day in the appropriate
time zone and locale. The requisite number of days (weeks are converted
to days by multiplying by seven) is added to the calendar day, and
the date and time are then converted back to a count of seconds from
-the epoch time.
+the epoch time. The \fBweekdays\fR keyword is similar to \fBdays\fR,
+with the only difference that weekends - Saturdays and Sundays - are skipped.
.PP
Adding and subtracting a given number of days across the point that
the time changes at the start or end of summer time (Daylight Saving Time)
@@ -887,41 +886,47 @@ The \fIinputString\fR argument consists of zero or more specifications of the
following form:
.TP
\fItime\fR
-A time of day, which is of the form: \fBhh?:mm?:ss?? ?meridian? ?zone?\fR
-or \fBhhmm ?meridian? ?zone?\fR
-If no meridian is specified, \fBhh\fR is interpreted on
+.
+A time of day, which is of the form:
+.QW "\fIhh\fR?\fB:\fImm\fR?\fB:\fIss\fR?? ?\fImeridian\fR? ?\fIzone\fR?"
+or
+.QW "\fBhhmm \fR?\fBmeridian\fR? ?\fBzone\fR?" .
+If no \fImeridian\fR is specified, \fIhh\fR is interpreted on
a 24-hour clock.
.TP
\fIdate\fR
+.
A specific month and day with optional year. The
acceptable formats are
-.QW "\fBmm/dd\fR?\fB/yy\fR?" ,
-.QW "\fBmonthname dd\fR?\fB, yy\fR?" ,
-.QW "\fBday, dd monthname \fR?\fByy\fR?" ,
-.QW "\fBdd monthname yy\fR" ,
-.QW "?\fBCC\fR?\fByymmdd\fR" ,
+.QW "\fImm\fB/\fIdd\fR?\fB/\fIyy\fR?" ,
+.QW "\fImonthname dd\fR?\fB, \fIyy\fR?" ,
+.QW "\fIday\fB, \fIdd monthname \fR?\fIyy\fR?" ,
+.QW "\fIdd monthname yy\fR" ,
+.QW "?\fICC\fR?\fIyymmdd\fR" ,
and
-.QW "\fBdd-monthname-\fR?\fBCC\fR?\fByy\fR" .
+.QW "\fIdd\fB-\fImonthname\fB-\fR?\fICC\fR?\fIyy\fR" .
The default year is the current year. If the year is less
than 100, we treat the years 00-68 as 2000-2068 and the years 69-99
as 1969-1999. Not all platforms can represent the years 38-70, so
an error may result if these years are used.
.TP
\fIISO 8601 point-in-time\fR
+.
An ISO 8601 point-in-time specification, such as
-.QW \fICCyymmdd\fBT\fIhhmmss\fR,
+.QW "\fICCyymmdd\fBT\fIhhmmss\fR",
where \fBT\fR is the literal
.QW T ,
.QW "\fICCyymmdd hhmmss\fR" ,
-.QW \fICCyymmdd\fBT\fIhh:mm:ss\fR ,
+.QW "\fICCyymmdd\fBT\fIhh:mm:ss\fR" ,
or
-.QW \fICCyy-mm-dd\fBT\fIhh:mm:ss\fR.
+.QW "\fICCyy-mm-dd\fBT\fIhh\fB:\fImm\fB:\fIss\fR".
Note that only these four formats are accepted.
The command does \fInot\fR accept the full range of point-in-time
specifications specified in ISO8601. Other formats can be recognized by
giving an explicit \fB\-format\fR option to the \fBclock scan\fR command.
.TP
\fIrelative time\fR
+.
A specification relative to the current time. The format is \fBnumber
unit\fR. Acceptable units are \fByear\fR, \fBfortnight\fR,
\fBmonth\fR, \fBweek\fR, \fBday\fR,
diff --git a/doc/close.n b/doc/close.n
index 5daf3e2..2066583 100644
--- a/doc/close.n
+++ b/doc/close.n
@@ -12,11 +12,12 @@
.SH NAME
close \- Close an open channel
.SH SYNOPSIS
-\fBclose \fIchannelId\fR ?r(ead)|w(rite)?
+\fBclose \fIchannelId\fR ?\fBr\fR(\fBead\fR)|\fBw\fR(\fBrite\fR)?
.BE
.SH DESCRIPTION
.PP
-Closes or half-closes the channel given by \fIchannelId\fR.
+Closes or half-closes the channel given by \fIchannelId\fR. \fBchan close\fR
+is another name for this command.
.PP
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
@@ -49,16 +50,21 @@ When the last interpreter in which the channel is registered invokes
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits.
-.VS 8.6
-From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when set and not equal to "0" restores the previous behavior.
-.VE 8.6
+From 8.6 on (TIP#398), nonblocking channels are no longer switched to
+blocking mode when exiting; this guarantees a timely exit even when the
+peer or a communication channel is stalled. To ensure proper flushing of
+stalled nonblocking channels on exit, one must now either (a) actively
+switch them back to blocking or (b) use the environment variable
+\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
+.QW \fB0\fR
+restores the previous behavior.
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output. If a command in a command
-pipeline created with \fBopen\fR returns an error, \fBclose\fR
-generates an error (similar to the \fBexec\fR command.)
+pipeline created with \fBopen\fR returns an error (either by returning a
+non-zero exit code or writing to its standard error file descriptor),
+\fBclose\fR generates an error (similar to the \fBexec\fR command.)
.PP
-.VS 8.6
The two-argument form is a
.QW "half-close" :
given a bidirectional channel like a
@@ -80,7 +86,6 @@ abnormal exit error.
.PP
Currently only sockets and command pipelines support half-close. A future
extension will allow reflected and stacked channels to do so.
-.VE 8.6
.SH EXAMPLE
.PP
This illustrates how you can use Tcl to ensure that files get closed
@@ -99,7 +104,7 @@ proc withOpenFile {filename channelVar script} {
}
.CE
.SH "SEE ALSO"
-file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
+chan(n), file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, close, nonblocking, half-close
'\" Local Variables:
diff --git a/doc/configurable.n b/doc/configurable.n
new file mode 100644
index 0000000..0102f8c
--- /dev/null
+++ b/doc/configurable.n
@@ -0,0 +1,333 @@
+'\"
+'\" Copyright © 2019 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH configurable n 0.4 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBoo::configurable create \fIclass\fR ?\fIdefinitionScript\fR?
+
+\fBoo::define \fIclass\fB {\fR
+ \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
+\fB}\fR
+
+\fBoo::objdefine \fIobject\fB {\fR
+ \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
+\fB}\fR
+
+\fIobjectName \fBconfigure\fR
+\fIobjectName \fBconfigure\fR \fI\-prop\fR
+\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::configurable\fR
+
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::configurablesupport::configurable\fR
+.fi
+.BE
+.SH DESCRIPTION
+.PP
+Configurable objects are objects that support being configured with a
+\fBconfigure\fR method. Each of the configurable entities of the object is
+known as a property of the object. Properties may be defined on classes or
+instances; when configuring an object, any of the properties defined by its
+classes (direct or indirect) or by the instance itself may be configured.
+.PP
+The \fBoo::configurable\fR metaclass installs basic support for making
+configurable objects into a class. This consists of making a \fBproperty\fR
+definition command available in definition scripts for the class and instances
+(e.g., from the class's constructor, within \fBoo::define\fR and within
+\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the
+instances.
+.SS "CONFIGURE METHOD"
+.PP
+The behavior of the \fBconfigure\fR method is modelled after the
+\fBfconfigure\fR/\fBchan configure\fR command.
+.PP
+If passed no additional arguments, the \fBconfigure\fR method returns an
+alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR
+properties and their current values.
+.PP
+If passed a single additional argument, that argument to the \fBconfigure\fR
+method must be the name of a property to read (or an unambiguous prefix
+thereof); its value is returned.
+.PP
+Otherwise, if passed an even number of arguments then each pair of arguments
+specifies a property name (or an unambiguous prefix thereof) and the value to
+set it to. The properties will be set in the order specified, including
+duplicates. If the setting of any property fails, the overall \fBconfigure\fR
+method fails, the preceding pairs (if any) will continue to have been applied,
+and the succeeding pairs (if any) will be not applied. On success, the result
+of the \fBconfigure\fR method in this mode operation will be an empty string.
+.SS "PROPERTY DEFINITIONS"
+.PP
+When a class has been manufactured by the \fBoo::configurable\fR metaclass (or
+one of its subclasses), it gains an extra definition, \fBproperty\fR. The
+\fBproperty\fR definition defines one or more properties that will be exposed
+by the class's instances.
+.PP
+The \fBproperty\fR command takes the name of a property to define first,
+\fIwithout a leading hyphen\fR, followed by a number of option-value pairs
+that modify the basic behavior of the property. This can then be followed by
+an arbitrary number of other property definitions. The supported options are:
+.TP
+\fB\-get \fIgetterScript\fR
+.
+This defines the implementation of how to read from the property; the
+\fIgetterScript\fR will become the body of a method (taking no arguments)
+defined on the class, if the kind of the property is such that the property
+can be read from. The method will be named
+\fB<ReadProp-\fIpropertyName\fB>\fR, and will default to being a simple read
+of the instance variable with the same name as the property (e.g.,
+.QW "\fBproperty\fR xyz"
+will result in a method
+.QW <ReadProp-xyz>
+being created).
+.TP
+\fB\-kind \fIpropertyKind\fR
+.
+This defines what sort of property is being created. The \fIpropertyKind\fR
+must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR
+(which is the default) which will make the property read-only, write-only or
+read-write, respectively. Read-only properties can only ever be read from,
+write-only properties can only ever be written to, and read-write properties
+can be both read and written.
+.RS
+.PP
+Note that write-only properties are not particularly discoverable as they are
+never reported by the \fBconfigure\fR method other than by error messages when
+attempting to write to a property that does not exist.
+.RE
+.TP
+\fB\-set \fIsetterScript\fR
+.
+This defines the implementation of how to write to the property; the
+\fIsetterScript\fR will become the body of a method taking a single argument,
+\fIvalue\fR, defined on the class, if the kind of the property is such that
+the property can be written to. The method will be named
+\fB<WriteProp-\fIpropertyName\fB>\fR, and will default to being a simple write
+of the instance variable with the same name as the property (e.g.,
+.QW "\fBproperty\fR xyz"
+will result in a method
+.QW <WriteProp-xyz>
+being created).
+.PP
+Instances of the class that was created by \fBoo::configurable\fR will also
+support \fBproperty\fR definitions; the semantics will be exactly as above
+except that the properties will be defined on the instance alone.
+.PP
+Note that the property implementation methods that \fBproperty\fR defines
+should not be private, as this makes them inaccessible from the implementation
+of \fBconfigure\fR (by design; the property configuration mechanism is
+intended for use mainly from outside a class, whereas a class may access
+variables directly). The variables accessed by the default implementations of
+the properties \fImay\fR be private, if so declared.
+.SH "ADVANCED USAGE"
+.PP
+The configurable class system is comprised of several pieces. The
+\fBoo::configurable\fR metaclass works by mixing in a class and setting
+definition namespaces during object creation that provide the other bits and
+pieces of machinery. The key pieces of the implementation are enumerated here
+so that they can be used by other code:
+.TP
+\fBoo::configuresupport::configurable\fR
+.
+This is a class that provides the implementation of the \fBconfigure\fR method
+(described above in \fBCONFIGURE METHOD\fR).
+.TP
+\fBoo::configuresupport::configurableclass\fR
+.
+This is a namespace that contains the definition dialect that provides the
+\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and
+class constructors under normal circumstances), as described above in
+\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR
+command so that it may be used easily in user definition dialects.
+.TP
+\fBoo::configuresupport::configurableobject\fR
+.
+This is a namespace that contains the definition dialect that provides the
+\fBproperty\fR declaration for use in instance objects (i.e., via
+\fBoo::objdefine\fR, and the \fBself\fR declaration in \fBoo::define\fR), as
+described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its
+\fBproperty\fR command so that it may be used easily in user definition
+dialects.
+.PP
+The underlying property discovery mechanism relies on four slots (see
+\fBoo::define\fR for what that implies) that list the properties that can be
+configured. These slots do not themselves impose any semantics on what the
+slots mean other than that they have unique names, no important order, can be
+inherited and discovered on classes and instances.
+.PP
+These slots, and their intended semantics, are:
+.TP
+\fBoo::configuresupport::readableproperties\fR
+.
+The set of properties of a class (not including those from its superclasses)
+that may be read from when configuring an instance of the class. This slot can
+also be read with the \fBinfo class properties\fR command.
+.TP
+\fBoo::configuresupport::writableproperties\fR
+.
+The set of properties of a class (not including those from its superclasses)
+that may be written to when configuring an instance of the class. This slot
+can also be read with the \fBinfo class properties\fR command.
+.TP
+\fBoo::configuresupport::objreadableproperties\fR
+.
+The set of properties of an object instance (not including those from its
+classes) that may be read from when configuring the object. This slot can
+also be read with the \fBinfo object properties\fR command.
+.TP
+\fBoo::configuresupport::objwritableproperties\fR
+.
+The set of properties of an object instance (not including those from its
+classes) that may be written to when configuring the object. This slot can
+also be read with the \fBinfo object properties\fR command.
+.PP
+Note that though these are slots, they are \fInot\fR in the standard
+\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them
+inside a definition script, they need to be referred to by full name. This is
+because they are intended to be building bricks of configurable property
+system, and not directly used by normal user code.
+.SS "IMPLEMENTATION NOTE"
+.PP
+The implementation of the \fBconfigure\fR method uses
+\fBinfo object properties\fR with the \fB\-all\fR option to discover what
+properties it may manipulate.
+.SH EXAMPLES
+.PP
+Here we create a simple configurable class and demonstrate how it can be
+configured:
+.PP
+.CS
+\fBoo::configurable\fR create Point {
+ \fBproperty\fR x y
+ constructor args {
+ my \fBconfigure\fR -x 0 -y 0 {*}$args
+ }
+ variable x y
+ method print {} {
+ puts "x=$x, y=$y"
+ }
+}
+
+set pt [Point new -x 27]
+$pt print; \fI# x=27, y=0\fR
+$pt \fBconfigure\fR -y 42
+$pt print; \fI# x=27, y=42\fR
+puts "distance from origin: [expr {
+ hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y])
+}]"; \fI# distance from origin: 49.92995093127971\fR
+puts [$pt \fBconfigure\fR]
+ \fI# -x 27 -y 42\fR
+.CE
+.PP
+Such a configurable class can be extended by subclassing, though the subclass
+needs to also be created by \fBoo::configurable\fR if it will use the
+\fBproperty\fR definition:
+.PP
+.CS
+\fBoo::configurable\fR create Point3D {
+ superclass Point
+ \fBproperty\fR z
+ constructor args {
+ next -z 0 {*}$args
+ }
+}
+
+set pt2 [Point3D new -x 2 -y 3 -z 4]
+puts [$pt2 \fBconfigure\fR]
+ \fI# -x 2 -y 3 -z 4\fR
+.CE
+.PP
+Once you have a configurable class, you can also add instance properties to
+it. (The backing variables for all properties start unset.) Note below that we
+are using an unambiguous prefix of a property name when setting it; this is
+supported for all properties though full names are normally recommended
+because subclasses will not make an unambiguous prefix become ambiguous in
+that case.
+.PP
+.CS
+oo::objdefine $pt {
+ \fBproperty\fR color
+}
+$pt \fBconfigure\fR -c bisque
+puts [$pt \fBconfigure\fR]
+ \fI# -color bisque -x 27 -y 42\fR
+.CE
+.PP
+You can also do derived properties by making them read-only and supplying a
+script that computes them.
+.PP
+.CS
+\fBoo::configurable\fR create PointMk2 {
+ \fBproperty\fR x y
+ \fBproperty\fR distance -kind readable -get {
+ return [expr {hypot($x, $y)}]
+ }
+ variable x y
+ constructor args {
+ my \fBconfigure\fR -x 0 -y 0 {*}$args
+ }
+}
+
+set pt3 [PointMk2 new -x 3 -y 4]
+puts [$pt3 \fBconfigure\fR -distance]
+ \fI# 5.0\fR
+$pt3 \fBconfigure\fR -distance 10
+ \fI# ERROR: bad property "-distance": must be -x or -y\fR
+.CE
+.PP
+Setters are used to validate the type of a property:
+.PP
+.CS
+\fBoo::configurable\fR create PointMk3 {
+ \fBproperty\fR x -set {
+ if {![string is double -strict $value]} {
+ error "-x property must be a number"
+ }
+ set x $value
+ }
+ \fBproperty\fR y -set {
+ if {![string is double -strict $value]} {
+ error "-y property must be a number"
+ }
+ set y $value
+ }
+ variable x y
+ constructor args {
+ my \fBconfigure\fR -x 0 -y 0 {*}$args
+ }
+}
+
+set pt4 [PointMk3 new]
+puts [$pt4 \fBconfigure\fR]
+ \fI# -x 0 -y 0\fR
+$pt4 \fBconfigure\fR -x 3 -y 4
+puts [$pt4 \fBconfigure\fR]
+ \fI# -x 3 -y 4\fR
+$pt4 \fBconfigure\fR -x "obviously not a number"
+ \fI# ERROR: -x property must be a number\fR
+.CE
+.SH "SEE ALSO"
+info(n), oo::class(n), oo::define(n)
+.SH KEYWORDS
+class, object, properties, configuration
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/continue.n b/doc/continue.n
index 92ff3b4..5eca861 100644
--- a/doc/continue.n
+++ b/doc/continue.n
@@ -23,7 +23,7 @@ exception to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
continues with the next iteration of the loop.
-Catch exceptions are also handled in a few other situations, such
+Continue exceptions are also handled in a few other situations, such
as the \fBcatch\fR command and the outermost scripts of procedure
bodies.
.SH EXAMPLE
diff --git a/doc/cookiejar.n b/doc/cookiejar.n
new file mode 100644
index 0000000..7d2f46b
--- /dev/null
+++ b/doc/cookiejar.n
@@ -0,0 +1,217 @@
+'\"
+'\" Copyright (c) 2014-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.
+'\"
+.TH "cookiejar" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+cookiejar \- Implementation of the Tcl http package cookie jar protocol
+.SH SYNOPSIS
+.nf
+\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR?
+
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR?
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+
+\fIcookiejar\fR \fBdestroy\fR
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.fi
+.SH DESCRIPTION
+.PP
+The cookiejar package provides an implementation of the http package's cookie
+jar protocol using an SQLite database. It provides one main command,
+\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to
+create a cookie jar that manages a particular HTTP session.
+.PP
+The database management policy can be controlled at the package level by the
+\fBconfigure\fR method on the \fB::http::cookiejar\fR class object:
+.TP
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+.
+If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a
+copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is
+supplied, just the value of the named option is returned. If both
+\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed
+to be the given value.
+.RS
+.PP
+Supported options are:
+.TP
+\fB\-domainfile \fIfilename\fR
+.
+A file (defaulting to within the cookiejar package) with a description of the
+list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains
+\fImust not\fR accept cookies set upon them. Note that the list of such
+domains is both security-sensitive and \fInot\fR constant and should be
+periodically refetched. Cookie jars maintain their own cache of the domain
+list.
+.TP
+\fB\-domainlist \fIurl\fR
+.
+A URL to fetch the list of top-level domains (e.g., \fB.com\fR or
+\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon
+them. Note that the list of such domains is both security-sensitive and
+\fInot\fR constant and should be periodically refetched. Cookie jars maintain
+their own cache of the domain list.
+.TP
+\fB\-domainrefresh \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the \fI\-domainlist\fR for new
+domains.
+.TP
+\fB\-loglevel \fIlevel\fR
+.
+The logging level of this package. The logging level must be (in order of
+decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or
+\fBerror\fR.
+.TP
+\fB\-offline \fIflag\fR
+.
+Allows the cookie managment engine to be placed into offline mode. In offline
+mode, the list of domains is read immediately from the file configured in the
+\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it
+also makes the \fB\-domainrefresh\fR option be effectively ignored.
+.TP
+\fB\-purgeold \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the database for expired
+cookies; expired cookies are deleted.
+.TP
+\fB\-retain \fIcookieCount\fR
+.
+The maximum number of cookies to retain in the database.
+.TP
+\fB\-vacuumtrigger \fIdeletionCount\fR
+.
+A count of the number of persistent cookie deletions to go between vacuuming
+the database.
+.RE
+.PP
+Cookie jar instances may be made with any of the standard TclOO instance
+creation methods (\fBcreate\fR or \fBnew\fR).
+.TP
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+.
+If a \fIfilename\fR argument is provided, it is the name of a file containing
+an SQLite database that will contain the persistent cookies maintained by the
+cookie jar; the database will be created if the file does not already
+exist. If \fIfilename\fR is not supplied, the database will be held entirely within
+memory, which effectively forces all cookies within it to be session cookies.
+.SS "INSTANCE METHODS"
+.PP
+The following methods are supported on the instances:
+.TP
+\fIcookiejar\fR \fBdestroy\fR
+.
+This is the standard TclOO destruction method. It does \fInot\fR delete the
+SQLite database if it is written to disk. Callers are responsible for ensuring
+that the cookie jar is not in use by the http package at the time of
+destruction.
+.TP
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+.
+This method causes the cookie jar to immediately load (and cache) the domain
+list data. The domain list will be loaded from the \fB\-domainlist\fR
+configured a the package level if that is enabled, and otherwise will be
+obtained from the \fB\-domainfile\fR configured at the package level.
+.TP
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+.
+This method obtains the cookies for a particular HTTP request. \fIThis
+implements the http cookie jar protocol.\fR
+.TP
+\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR
+.
+This method is called by the \fBstoreCookie\fR method to get a decision on
+whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and
+\fIpath\fR. This is checked immediately before the database is updated but
+after the built-in security checks are done, and should return a boolean
+value; if the value is false, the operation is rejected and the database is
+not modified. The supported \fIoperation\fRs are:
+.RS
+.TP
+\fBdelete\fR
+.
+The \fIdomain\fR is seeking to delete a cookie.
+.TP
+\fBsession\fR
+.
+The \fIdomain\fR is seeking to create or update a session cookie.
+.TP
+\fBset\fR
+.
+The \fIdomain\fR is seeking to create or update a persistent cookie (with a
+defined lifetime).
+.PP
+The default implementation of this method just returns true, but subclasses of
+this class may impose their own rules.
+.RE
+.TP
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+.
+This method stores a single cookie from a particular HTTP response. Cookies
+that fail security checks are ignored. \fIThis implements the http cookie jar
+protocol.\fR
+.TP
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.
+This method looks a cookie by exact host (or domain) matching. If neither
+\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is
+stored is returned. If just \fIhost\fR (which may be a hostname or a domain
+name) is supplied, the list of cookie keys stored for that host is returned.
+If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is
+returned; it is an error if no such host or key match exactly.
+.SH "EXAMPLES"
+.PP
+The simplest way of using a cookie jar is to just permanently configure it at
+the start of the application.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl-lang.org/]
+.CE
+.PP
+To only allow a particular domain to use cookies, perhaps because you only
+want to enable a particular host to create and manipulate sessions, create a
+subclass that imposes that policy.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+oo::class create MyCookieJar {
+ superclass \fBhttp::cookiejar\fR
+
+ method \fBpolicyAllow\fR {operation domain path} {
+ return [expr {$domain eq "my.example.com"}]
+ }
+}
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [MyCookieJar new $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl-lang.org/]
+.CE
+.SH "SEE ALSO"
+http(n), oo::class(n), sqlite3(n)
+.SH KEYWORDS
+cookie, internet, security policy, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/copy.n b/doc/copy.n
index 706be54..56160a0 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -12,7 +12,7 @@
oo::copy \- create copies of objects and classes
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBoo::copy\fI sourceObject \fR?\fItargetObject\fR? ?\fItargetNamespace\fR?
.fi
diff --git a/doc/coroutine.n b/doc/coroutine.n
index 52775ef..11f9069 100644
--- a/doc/coroutine.n
+++ b/doc/coroutine.n
@@ -9,15 +9,18 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-coroutine, yield, yieldto \- Create and produce values from coroutines
+coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values from coroutines
.SH SYNOPSIS
.nf
\fBcoroutine \fIname command\fR ?\fIarg...\fR?
\fByield\fR ?\fIvalue\fR?
-.VS TIP396
\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
\fIname\fR ?\fIvalue...\fR?
-.VE TIP396
+.sp
+.VS "8.7, TIP383"
+\fBcoroinject \fIcoroName command\fR ?\fIarg...\fR?
+\fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR?
+.VE "8.7, TIP383"
.fi
.BE
.SH DESCRIPTION
@@ -39,7 +42,6 @@ the context to be suspended. If the coroutine context never yields and instead
returns conventionally, the result of the \fBcoroutine\fR command will be the
result of the evaluation of the context.
.PP
-.VS TIP396
The coroutine may also suspend its execution by use of the \fByieldto\fR
command, which instead of returning, cedes execution to some command called
\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
@@ -58,11 +60,10 @@ with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
command, like this:
.PP
.CS
-proc yieldm {value} {
- \fByieldto\fR return -level 0 $value
+proc yieldMultiple {value} {
+ tailcall \fByieldto\fR string cat $value
}
.CE
-.VE TIP396
.PP
The coroutine can also be deleted by destroying the command \fIname\fR, and
the name of the current coroutine can be retrieved by using
@@ -75,6 +76,51 @@ At the point when \fIcommand\fR is called, the current namespace will be the
global namespace and there will be no stack frames above it (in the sense of
\fBupvar\fR and \fBuplevel\fR). However, which command to call will be
determined in the namespace that the \fBcoroutine\fR command was called from.
+.PP
+.VS "8.7, TIP383"
+A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d)
+may have its state inspected (or modified) at that point by using
+\fBcoroprobe\fR to run a command at the point where the coroutine is at. The
+command takes the name of the coroutine to run the command in, \fIcoroName\fR,
+and the name of a command (any any arguments it requires) to immediately run
+at that point. The result of that command is the result of the \fBcoroprobe\fR
+command, and the gross state of the coroutine remains the same afterwards
+(i.e., the coroutine is still expecting the results of a \fByield\fR or
+\fByieldto\fR as before) though variables may have been changed.
+.PP
+Similarly, the \fBcoroinject\fR command may be used to place a command to be
+run inside a suspended coroutine (when it is resumed) to process arguments,
+with quite a bit of similarity to \fBcoroprobe\fR. However, with
+\fBcoroinject\fR there are several key differences:
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+The coroutine is not immediately resumed after the injection has been done. A
+consequence of this is that multiple injections may be done before the
+coroutine is resumed. There injected commands are performed in \fIreverse
+order of definition\fR (that is, they are internally stored on a stack).
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+An additional two arguments are appended to the list of arguments to be run
+(that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements).
+The first is the name of the command that suspended the coroutine (\fByield\fR
+or \fByieldto\fR), and the second is the argument (or list of arguments, in
+the case of \fByieldto\fR) that is the current resumption value.
+.VE "8.7, TIP383"
+.IP \(bu
+.VS "8.7, TIP383"
+The result of the injected command is used as the result of the \fByield\fR or
+\fByieldto\fR that caused the coroutine to become suspended. Where there are
+multiple injected commands, the result of one becomes the resumption value
+processed by the next.
+.PP
+The injection is a one-off. It is not retained once it has been executed. It
+may \fByield\fR or \fByieldto\fR as part of its execution.
+.PP
+Note that running coroutines may be neither probed nor injected; the
+operations may only be applied to
+.VE "8.7, TIP383"
.SH EXAMPLES
.PP
This example shows a coroutine that will produce an infinite sequence of
@@ -138,7 +184,6 @@ for {set i 1} {$i <= 20} {incr i} {
}
.CE
.PP
-.VS TIP396
This example shows how a value can be passed around a group of three
coroutines that yield to each other:
.PP
@@ -150,14 +195,57 @@ proc juggler {name target {value ""}} {
while {$value ne ""} {
puts "$name : $value"
set value [string range $value 0 end-1]
- lassign [\fByieldto\fR $target $value] value
+ lassign [\fByieldto\fR \fI$target\fR $value] value
}
}
\fBcoroutine\fR j1 juggler Larry [
\fBcoroutine\fR j2 juggler Curly [
\fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
.CE
-.VE TIP396
+.PP
+.VS "8.7, TIP383"
+This example shows a simple coroutine that collects non-empty values and
+returns a list of them when not given an argument. It also shows how we can
+look inside the coroutine to find out what it is doing, and how we can modify
+the input on a one-off basis.
+.PP
+.CS
+proc collectorImpl {} {
+ set me [info coroutine]
+ set accumulator {}
+ for {set val [\fByield\fR $me]} {$val ne ""} {set val [\fByield\fR]} {
+ lappend accumulator $val
+ }
+ return $accumulator
+}
+
+\fBcoroutine\fR collect collectorImpl
+\fIcollect\fR 123
+\fIcollect\fR "abc def"
+\fIcollect\fR 456
+
+puts [\fBcoroprobe \fIcollect\fR set accumulator]
+# ==> 123 {abc def} 456
+
+\fIcollect\fR "pqr"
+
+\fBcoroinject \fIcollect\fR apply {{type value} {
+ puts "Received '$value' at a $type in [info coroutine]"
+ return [string toupper $value]
+}}
+
+\fIcollect\fR rst
+# ==> Received 'rst' at a yield in ::collect
+\fIcollect\fR xyz
+
+puts [\fIcollect\fR]
+# ==> 123 {abc def} 456 pqr RST xyz
+.CE
+.PP
+This example shows a simple coroutine that collects non-empty values and
+returns a list of them when not given an argument. It also shows how we can
+look inside the coroutine to find out what it is doing.
+.VE "8.7, TIP383"
.SS "DETAILED SEMANTICS"
.PP
This example demonstrates that coroutines start from the global namespace, and
diff --git a/doc/dde.n b/doc/dde.n
index 9a0be56..8316af9 100644
--- a/doc/dde.n
+++ b/doc/dde.n
@@ -17,11 +17,9 @@ dde \- Execute a Dynamic Data Exchange command
.sp
\fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR?
.sp
-.VS 8.6
\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR
.sp
\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR
-.VE 8.6
.sp
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
.sp
@@ -82,13 +80,11 @@ script is run in the application. The \fB\-async\fR option requests
asynchronous invocation. The command returns an error message if the
script did not run, unless the \fB\-async\fR flag was used, in which case
the command returns immediately with no error.
-.VS 8.6
Without the \fB\-binary\fR option all data will be sent in unicode. For
dde clients which don't implement the CF_UNICODE clipboard format, this
will automatically be translated to the system encoding. You can use
the \fB\-binary\fR option in combination with the result of
\fBencoding convertto\fR to send data in any other encoding.
-.VE 8.6
.TP
\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR
.
@@ -99,13 +95,11 @@ specific but can be a command to the server or the name of a file to work
on. The \fIitem\fR is also application specific and is often not used, but
it must always be non-null. The \fIdata\fR field is given to the remote
application.
-.VS 8.6
Without the \fB\-binary\fR option all data will be sent in unicode. For
dde clients which don't implement the CF_UNICODE clipboard format, this
will automatically be translated to the system encoding. You can use
the \fB\-binary\fR option in combination with the result of
\fBencoding convertto\fR to send data in any other encoding.
-.VE 8.6
.TP
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
.
diff --git a/doc/define.n b/doc/define.n
index ad991e1..c1c3049 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -1,5 +1,5 @@
'\"
-'\" Copyright (c) 2007 Donal K. Fellows
+'\" Copyright (c) 2007-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.
@@ -12,7 +12,7 @@
oo::define, oo::objdefine \- define and configure classes and objects
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBoo::define\fI class defScript\fR
\fBoo::define\fI class subcommand arg\fR ?\fIarg ...\fR?
@@ -34,11 +34,36 @@ either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following
\fIarg\fR arguments; when the second is present, it is exactly as if all the
arguments from \fIsubcommand\fR onwards are made into a list and that list is
used as the \fIdefScript\fR argument.
-.SS "CONFIGURING CLASSES"
+.PP
+Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on
+the script argument that it is provided. This is a convenient way to create
+and define a class in one step.
+.SH "CONFIGURING CLASSES"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form:
.TP
+\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR?
+.VS TIP478
+This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are
+omitted) promotes an existing method on the class object to be a class
+method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in
+the \fBmethod\fR definition, below.
+.RS
+.PP
+Class methods can be called on either the class itself or on the instances of
+that class. When they are called, the current object (see the \fBsel\fR and
+\fBmy\fR commands) is the class on which they are called or the class of the
+instance on which they are called, depending on whether they are called on the
+class or an instance of the class, respectively. If called on a subclass or
+instance of the subclass, the current object is the subclass.
+.PP
+In a private definition context, the methods as invoked on classes are
+\fInot\fR private, but the methods as invoked on instances of classes are
+private.
+.RE
+.VE TIP478
+.TP
\fBconstructor\fI argList bodyScript\fR
.
This creates or updates the constructor for a class. The formal arguments to
@@ -49,14 +74,11 @@ namespace of the constructor will be a namespace that is unique to the object
being constructed. Within the constructor, the \fBnext\fR command should be
used to call the superclasses' constructors. If \fIbodyScript\fR is the empty
string, the constructor will be deleted.
-.TP
-\fBdeletemethod\fI name\fR ?\fIname ...\fR?
-.
-This deletes each of the methods called \fIname\fR from a class. The methods
-must have previously existed in that class. Does not affect the superclasses
-of the class, nor does it affect the subclasses or instances of the class
-(except when they have a call chain through the class being modified) or the
-class object itself.
+.RS
+.PP
+Classes do not need to have a constructor defined. If none is specified, the
+superclass's constructor will be used instead.
+.RE
.TP
\fBdestructor\fI bodyScript\fR
.
@@ -82,19 +104,6 @@ class being defined. Note that the methods themselves may be actually defined
by a superclass; subclass exports override superclass visibility, and may in
turn be overridden by instances.
.TP
-\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
-.VS
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-.VE
-sets or updates the list of method names that are used to guard whether
-method call to instances of the class may be called and what the method's
-results are. Each \fImethodName\fR names a single filtering method (which may
-be exposed or not exposed); it is not an error for a non-existent method to be
-named since they may be defined by subclasses.
-.VS
-By default, this slot works by appending.
-.VE
-.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded method called \fIname\fR. The method is
@@ -106,8 +115,24 @@ fully-qualified, the command will be searched for in each object's namespace,
using the instances' namespace's path, or by looking in the global namespace.
The method will be exported if \fIname\fR starts with a lower-case letter, and
non-exported otherwise.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private forwarded methods.
+.VE TIP500
+.RE
+.TP
+\fBinitialise\fI script\fR
+.TP
+\fBinitialize\fI script\fR
+.VS TIP478
+This evaluates \fIscript\fR in a context which supports local variables and
+where the current namespace is the instance namespace of the class object
+itself. This is useful for setting up, e.g., class-scoped variables.
+.VE TIP478
.TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
.
This creates or updates a method that is implemented as a procedure-like
script. The name of the method is \fIname\fR, the formal arguments to the
@@ -117,33 +142,44 @@ the body of the method is evaluated, the current namespace of the method will
be a namespace that is unique to the current object. The method will be
exported if \fIname\fR starts with a lower-case letter, and non-exported
otherwise; this behavior can be overridden via \fBexport\fR and
-\fBunexport\fR.
+\fBunexport\fR
+.VS TIP519
+or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the
+optional parameter \fIoption\fR.
+.VE TIP519
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
+.VE TIP500
+.RE
.TP
-\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
-.VS
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-.VE
-sets or updates the list of additional classes that are to be mixed into
-all the instances of the class being defined. Each \fIclassName\fR argument
-names a single class that is to be mixed in.
-.VS
-By default, this slot works by replacement.
-.VE
+\fBprivate \fIcmd arg...\fR
.TP
-\fBrenamemethod\fI fromName toName\fR
+\fBprivate \fIscript\fR
.
-This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
-method must have previously existed in the class, and \fItoName\fR must not
-previously refer to a method in that class. Does not affect the superclasses
-of the class, nor does it affect the subclasses or instances of the class
-(except when they have a call chain through the class being modified), or the
-class object itself. Does
-not change the export status of the method; if it was exported before, it will
-be afterwards.
+.VS TIP500
+This evaluates the \fIscript\fR (or the list of command and arguments given by
+\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
+current class will be private definitions.
+.RS
+.PP
+The following class definition commands are affected by \fBprivate\fR:
+\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting
+\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost
+definition context is just a private definition context. All other definition
+commands have no difference in behavior when used in a private definition
+context.
+.RE
+.VE TIP500
.TP
\fBself\fI subcommand arg ...\fR
.TP
\fBself\fI script\fR
+.TP
+\fBself\fR
.
This command is equivalent to calling \fBoo::objdefine\fR on the class being
defined (see \fBCONFIGURING OBJECTS\fR below for a description of the
@@ -153,20 +189,29 @@ and
.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
operates identically to
.QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
+.RS
+.PP
+.VS TIP470
+If no arguments at all are used, this gives the name of the class currently
+being configured.
+.VE TIP470
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), the definitions on the class object will also be made in a private
+definition context.
+.VE TIP500
+.RE
.TP
\fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
-.VS
+.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
-.VE
allows the alteration of the superclasses of the class being defined.
Each \fIclassName\fR argument names one class that is to be a superclass of
the defined class. Note that objects must not be changed from being classes to
being non-classes or vice-versa, that an empty parent class is equivalent to
\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
\fBoo::class\fR may not be modified.
-.VS
By default, this slot works by replacement.
-.VE
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
@@ -178,37 +223,103 @@ actually defined by a superclass; subclass unexports override superclass
visibility, and may be overridden by instance unexports.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
-.VS
+.
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made
available in the methods, constructor and destructor declared by the class
being defined. Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
-actually present in the instance object on which the method is executed. Note
+actually present in the namespace of the instance object on which the method
+is executed. Note
that the variable lists declared by a superclass or subclass are completely
disjoint, as are variable lists declared by instances; the list of variable
names is just for methods (and constructors and destructors) declared by this
class. By default, this slot works by appending.
-.VE
-.SS "CONFIGURING OBJECTS"
+.RS
.PP
-The following commands are supported in the \fIdefScript\fR for
-\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
-form:
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this slot manipulates the list of private variable bindings for this
+class. In a private variable binding, the name of the variable within the
+instance object is different to the name given in the definition; the name
+used in the definition is the name that you use to access the variable within
+the methods of this class, and the name of the variable in the instance
+namespace has a unique prefix that makes accidental use from other classes
+extremely unlikely.
+.VE TIP500
+.RE
+.SS "ADVANCED CLASS CONFIGURATION OPTIONS"
+.PP
+The following definitions are also supported, but are not required in simple
+programs:
.TP
-\fBclass\fI className\fR
+\fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR
+.VS TIP524
+This allows control over what namespace will be used by the \fBoo::define\fR
+and \fBoo::objdefine\fR commands to look up the definition commands they
+use. When any object has a definition operation applied to it, \fIthe class that
+it is an instance of\fR (and its superclasses and mixins) is consulted for
+what definition namespace to use. \fBoo::define\fR gets the class definition
+namespace, and \fB::oo::objdefine\fR gets the instance definition namespace,
+but both otherwise use the identical lookup operation.
+.RS
+.PP
+This sets the definition namespace of kind \fIkind\fR provided by the current
+class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a
+currently existing namespace, or must be the empty string (to stop the current
+class from having such a namespace connected). The \fIkind\fR, if supplied,
+must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the
+whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR
+respectively is being set.
+.PP
+The class \fBoo::object\fR has its instance namespace locked to
+\fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace
+locked to \fB::oo::define\fR. A consequence of this is that effective use of
+this feature for classes requires the definition of a metaclass.
+.RE
+.VE TIP524
+.TP
+\fBdeletemethod\fI name\fR ?\fIname ...\fR?
.
-This allows the class of an object to be changed after creation. Note that the
-class's constructors are not called when this is done, and so the object may
-well be in an inconsistent state unless additional configuration work is done.
+This deletes each of the methods called \fIname\fR from a class. The methods
+must have previously existed in that class. Does not affect the superclasses
+of the class, nor does it affect the subclasses or instances of the class
+(except when they have a call chain through the class being modified) or the
+class object itself.
.TP
-\fBdeletemethod\fI name\fR ?\fIname ...\fR
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.
-This deletes each of the methods called \fIname\fR from an object. The methods
-must have previously existed in that object (e.g., because it was created
-through \fBoo::objdefine method\fR). Does not affect the classes that the
-object is an instance of, or remove the exposure of those class-provided
-methods in the instance of that class.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of method names that are used to guard whether
+method call to instances of the class may be called and what the method's
+results are. Each \fImethodName\fR names a single filtering method (which may
+be exposed or not exposed); it is not an error for a non-existent method to be
+named since they may be defined by subclasses.
+By default, this slot works by appending.
+.TP
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of additional classes that are to be mixed into
+all the instances of the class being defined. Each \fIclassName\fR argument
+names a single class that is to be mixed in.
+By default, this slot works by replacement.
+.TP
+\fBrenamemethod\fI fromName toName\fR
+.
+This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
+method must have previously existed in the class, and \fItoName\fR must not
+previously refer to a method in that class. Does not affect the superclasses
+of the class, nor does it affect the subclasses or instances of the class
+(except when they have a call chain through the class being modified), or the
+class object itself. Does
+not change the export status of the method; if it was exported before, it will
+be afterwards.
+.SH "CONFIGURING OBJECTS"
+.PP
+The following commands are supported in the \fIdefScript\fR for
+\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
+form:
.TP
\fBexport\fI name \fR?\fIname ...\fR?
.
@@ -217,20 +328,6 @@ This arranges for each of the named methods, \fIname\fR, to be exported
being defined. Note that the methods themselves may be actually defined by a
class or superclass; object exports override class visibility.
.TP
-\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
-.VS
-This slot (see \fBSLOTTED DEFINITIONS\fR below)
-.VE
-sets or updates the list of method names that are used to guard whether a
-method call to the object may be called and what the method's results are.
-Each \fImethodName\fR names a single filtering method (which may be exposed or
-not exposed); it is not an error for a non-existent method to be named. Note
-that the actual list of filters also depends on the filters set upon any
-classes that the object is an instance of.
-.VS
-By default, this slot works by appending.
-.VE
-.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded object method called \fIname\fR. The
@@ -239,8 +336,15 @@ additional arguments, \fIarg\fR etc., added before those arguments specified
by the caller of the method. Forwarded methods should be deleted using the
\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
a lower-case letter, and non-exported otherwise.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this command creates private forwarded methods.
+.VE TIP500
+.RE
.TP
-\fBmethod\fI name argList bodyScript\fR
+\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR
.
This creates, updates or deletes an object method. The name of the method is
\fIname\fR, the formal arguments to the method (defined using the same format
@@ -248,28 +352,45 @@ as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
method will be \fIbodyScript\fR. When the body of the method is evaluated, the
current namespace of the method will be a namespace that is unique to the
object. The method will be exported if \fIname\fR starts with a lower-case
-letter, and non-exported otherwise.
+letter, and non-exported otherwise;
+.VS TIP519
+this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or
+\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the
+\fBexport\fR and \fBunexport\fR definitions.
+.VE TIP519
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command
+creates private procedure-like methods.
+.VE TIP500
+.RE
.TP
\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
-.VS
+.
This slot (see \fBSLOTTED DEFINITIONS\fR below)
-.VE
sets or updates a per-object list of additional classes that are to be
mixed into the object. Each argument, \fIclassName\fR, names a single class
that is to be mixed in.
-.VS
By default, this slot works by replacement.
-.VE
.TP
-\fBrenamemethod\fI fromName toName\fR
-.
-This renames the method called \fIfromName\fR in an object to \fItoName\fR.
-The method must have previously existed in the object, and \fItoName\fR must
-not previously refer to a method in that object. Does not affect the classes
-that the object is an instance of and cannot rename in an instance object the
-methods provided by those classes (though a \fBoo::objdefine forward\fRed
-method may provide an equivalent capability). Does not change the export
-status of the method; if it was exported before, it will be afterwards.
+\fBprivate \fIcmd arg...\fR
+.TP
+\fBprivate \fIscript\fR
+.VS TIP500
+This evaluates the \fIscript\fR (or the list of command and arguments given by
+\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
+current object will be private definitions.
+.RS
+.PP
+The following class definition commands are affected by \fBprivate\fR:
+\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside
+\fBprivate\fR has no cumulative effect; the innermost definition context is
+just a private definition context. All other definition commands have no
+difference in behavior when used in a private definition context.
+.RE
+.VE TIP500
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
@@ -280,36 +401,120 @@ object being defined. Note that the methods themselves may be actually defined
by a class; instance unexports override class visibility.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
-.VS
+.
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made available in the methods declared by the
object being defined. Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
-actually present in the object on which the method is executed. Note that the
+actually present in the namespace of the object on which the method is
+executed. Note that the
variable lists declared by the classes and mixins of which the object is an
instance are completely disjoint; the list of variable names is just for
methods declared by this object. By default, this slot works by appending.
+.RS
+.PP
+.VS TIP500
+If in a private definition context (see the \fBprivate\fR definition command,
+below), this slot manipulates the list of private variable bindings for this
+object. In a private variable binding, the name of the variable within the
+instance object is different to the name given in the definition; the name
+used in the definition is the name that you use to access the variable within
+the methods of this instance object, and the name of the variable in the
+instance namespace has a unique prefix that makes accidental use from
+superclass methods extremely unlikely.
+.VE TIP500
+.RE
+.SS "ADVANCED OBJECT CONFIGURATION OPTIONS"
+.PP
+The following definitions are also supported, but are not required in simple
+programs:
+.TP
+\fBclass\fI className\fR
+.
+This allows the class of an object to be changed after creation. Note that the
+class's constructors are not called when this is done, and so the object may
+well be in an inconsistent state unless additional configuration work is done.
+.TP
+\fBdeletemethod\fI name\fR ?\fIname ...\fR
+.
+This deletes each of the methods called \fIname\fR from an object. The methods
+must have previously existed in that object (e.g., because it was created
+through \fBoo::objdefine method\fR). Does not affect the classes that the
+object is an instance of, or remove the exposure of those class-provided
+methods in the instance of that class.
+.TP
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+sets or updates the list of method names that are used to guard whether a
+method call to the object may be called and what the method's results are.
+Each \fImethodName\fR names a single filtering method (which may be exposed or
+not exposed); it is not an error for a non-existent method to be named. Note
+that the actual list of filters also depends on the filters set upon any
+classes that the object is an instance of.
+By default, this slot works by appending.
+.TP
+\fBrenamemethod\fI fromName toName\fR
+.
+This renames the method called \fIfromName\fR in an object to \fItoName\fR.
+The method must have previously existed in the object, and \fItoName\fR must
+not previously refer to a method in that object. Does not affect the classes
+that the object is an instance of and cannot rename in an instance object the
+methods provided by those classes (though a \fBoo::objdefine forward\fRed
+method may provide an equivalent capability). Does not change the export
+status of the method; if it was exported before, it will be afterwards.
+.TP
+\fBself \fR
+.VS TIP470
+This gives the name of the object currently being configured.
+.VE TIP470
+.SH "PRIVATE METHODS"
+.VS TIP500
+When a class or instance has a private method, that private method can only be
+invoked from within methods of that class or instance. Other callers of the
+object's methods \fIcannot\fR invoke private methods, it is as if the private
+methods do not exist. However, a private method of a class \fIcan\fR be
+invoked from the class's methods when those methods are being used on another
+instance object; this means that a class can use them to coordinate behaviour
+between several instances of itself without interfering with how other
+classes (especially either subclasses or superclasses) interact. Private
+methods precede all mixed in classes in the method call order (as reported by
+\fBself call\fR).
+.VE TIP500
.SH "SLOTTED DEFINITIONS"
Some of the configurable definitions of a class or object are \fIslotted
definitions\fR. This means that the configuration is implemented by a slot
object, that is an instance of the class \fBoo::Slot\fR, which manages a list
of values (class names, variable names, etc.) that comprises the contents of
-the slot. The class defines three operations (as methods) that may be done on
+the slot. The class defines five operations (as methods) that may be done on
the slot:
-.VE
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
-.VS
+.
This appends the given \fImember\fR elements to the slot definition.
-.VE
+.TP
+\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
+.VS TIP558
+This appends the given \fImember\fR elements to the slot definition if they
+do not already exist.
+.VE TIP558
.TP
\fIslot\fR \fB\-clear\fR
-.VS
+.
This sets the slot definition to the empty list.
-.VE
+.TP
+\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
+.VS TIP516
+This prepends the given \fImember\fR elements to the slot definition.
+.VE TIP516
+.TP
+\fIslot\fR \fB\-remove\fR ?\fImember ...\fR?
+.VS TIP516
+This removes the given \fImember\fR elements from the slot definition.
+.VE TIP516
.TP
\fIslot\fR \fB\-set\fR ?\fImember ...\fR?
-.VS
+.
This replaces the slot definition with the given \fImember\fR elements.
.PP
A consequence of this is that any use of a slot's default operation where the
@@ -322,20 +527,55 @@ which is forwarded to the default operation of the slot (thus, for the class
slot, this is forwarded to
.QW "\fBmy \-append\fR" ),
and these methods which provide the implementation interface:
-.VE
.TP
\fIslot\fR \fBGet\fR
-.VS
-Returns a list that is the current contents of the slot. This method must
-always be called from a stack frame created by a call to \fBoo::define\fR or
-\fBoo::objdefine\fR.
-.VE
+.
+Returns a list that is the current contents of the slot, but does not modify
+the slot. This method must always be called from a stack frame created by a
+call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR
+return an error unless it is called from outside a definition context or with
+the wrong number of arguments.
+.RS
+.PP
+.VS TIP516
+The elements of the list should be fully resolved, if that is a meaningful
+concept to the slot.
+.VE TIP516
+.RE
+.TP
+\fIslot\fR \fBResolve\fR \fIslotElement\fR
+.VS TIP516
+Returns \fIslotElement\fR with a resolution operation applied to it, but does
+not modify the slot. For slots of simple strings, this is an operation that
+does nothing, whereas for slots of classes, this maps a class name to its
+fully-qualified class name. This method must always be called from a stack
+frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This
+method \fIshould not\fR return an error unless it is called from outside a
+definition context or with the wrong number of arguments; unresolvable
+arguments should be returned as is (as not all slot operations strictly
+require that values are resolvable to work).
+.RS
+.PP
+Implementations \fIshould not\fR enforce uniqueness and ordering constraints
+in this method; that is the responsibility of the \fBSet\fR method.
+.RE
+.VE TIP516
.TP
\fIslot\fR \fBSet \fIelementList\fR
-.VS
+.
Sets the contents of the slot to the list \fIelementList\fR and returns the
empty string. This method must always be called from a stack frame created by
-a call to \fBoo::define\fR or \fBoo::objdefine\fR.
+a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an
+error if it rejects the change to the slot contents (e.g., because of invalid
+values) as well as if it is called from outside a definition context or with
+the wrong number of arguments.
+.RS
+.PP
+This method \fImay\fR reorder and filter the elements if this is necessary in
+order to satisfy the underlying constraints of the slot. (For example, slots
+of classes enforce a uniqueness constraint that places each element in the
+earliest location in the slot that it can.)
+.RE
.PP
The implementation of these methods is slot-dependent (and responsible for
accessing the correct part of the class or object definition). Slots also have
@@ -343,7 +583,14 @@ an unknown method handler to tie all these pieces together, and they hide
their \fBdestroy\fR method so that it is not invoked inadvertently. It is
\fIrecommended\fR that any user changes to the slot mechanism be restricted to
defining new operations whose names start with a hyphen.
-.VE
+.PP
+.VS TIP516
+Most slot operations will initially \fBResolve\fR their argument list, combine
+it with the results of the \fBGet\fR method, and then \fBSet\fR the result.
+Some operations omit one or both of the first two steps; omitting the third
+would result in an idempotent read-only operation (but the standard mechanism
+for reading from slots is via \fBinfo class\fR and \fBinfo object\fR).
+.VE TIP516
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
\fBoo::objdefine\fR commands (they work in the same way), as well as
@@ -400,6 +647,138 @@ oo::class create B {
inst m1 \fI\(-> prints "red brick"\fR
inst m2 \fI\(-> prints "blue brick"\fR
.CE
+.PP
+.VS TIP478
+This example shows how to create and use class variables. It is a class that
+counts how many instances of itself have been made.
+.PP
+.CS
+oo::class create Counted
+\fBoo::define\fR Counted {
+ \fBinitialise\fR {
+ variable count 0
+ }
+
+ \fBvariable\fR number
+ \fBconstructor\fR {} {
+ classvariable count
+ set number [incr count]
+ }
+
+ \fBmethod\fR report {} {
+ classvariable count
+ puts "This is instance $number of $count"
+ }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+ \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+ \fI\(-> This is instance 2 of 3\fR
+$c report
+ \fI\(-> This is instance 3 of 3\fR
+.CE
+.PP
+This example demonstrates how to use class methods. (Note that the constructor
+for \fBoo::class\fR calls \fBoo::define\fR on the class.)
+.PP
+.CS
+oo::class create DBTable {
+ \fBclassmethod\fR find {description} {
+ puts "DB: locate row from [self] matching $description"
+ return [my new]
+ }
+ \fBclassmethod\fR insert {description} {
+ puts "DB: create row in [self] matching $description"
+ return [my new]
+ }
+ \fBmethod\fR update {description} {
+ puts "DB: update row [self] with $description"
+ }
+ \fBmethod\fR delete {} {
+ puts "DB: delete row [self]"
+ my destroy; # Just delete the object, not the DB row
+ }
+}
+
+oo::class create Users {
+ \fBsuperclass\fR DBTable
+}
+oo::class create Groups {
+ \fBsuperclass\fR DBTable
+}
+
+set u1 [Users insert "username=abc"]
+ \fI\(-> DB: create row from ::Users matching username=abc\fR
+set u2 [Users insert "username=def"]
+ \fI\(-> DB: create row from ::Users matching username=def\fR
+$u2 update "group=NULL"
+ \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR
+$u1 delete
+ \fI\(-> DB: delete row ::oo::Obj123\fR
+set g [Group find "groupname=webadmins"]
+ \fI\(-> DB: locate row ::Group with groupname=webadmins\fR
+$g update "emailaddress=admins"
+ \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR
+.CE
+.VE TIP478
+.PP
+.VS TIP524
+This example shows how to make a custom definition for a class. Note that it
+explicitly includes delegation to the existing definition commands via
+\fBnamespace path\fR.
+.PP
+.CS
+namespace eval myDefinitions {
+ # Delegate to existing definitions where not overridden
+ namespace path \fB::oo::define\fR
+
+ # A custom type of method
+ proc exprmethod {name arguments body} {
+ tailcall \fBmethod\fR $name $arguments [list expr $body]
+ }
+
+ # A custom way of building a constructor
+ proc parameters args {
+ uplevel 1 [list \fBvariable\fR {*}$args]
+ set body [join [lmap a $args {
+ string map [list VAR $a] {
+ set [my varname VAR] [expr {double($VAR)}]
+ }
+ }] ";"]
+ tailcall \fBconstructor\fR $args $body
+ }
+}
+
+# Bind the namespace into a (very simple) metaclass for use
+oo::class create exprclass {
+ \fBsuperclass\fR oo::class
+ \fBdefinitionnamespace\fR myDefinitions
+}
+
+# Use the custom definitions
+exprclass create quadratic {
+ parameters a b c
+ exprmethod evaluate {x} {
+ ($a * $x**2) + ($b * $x) + $c
+ }
+}
+
+# Showing the resulting class and object in action
+quadratic create quad 1 2 3
+for {set x 0} {$x <= 4} {incr x} {
+ puts [format "quad(%d) = %.2f" $x [quad evaluate $x]]
+}
+ \fI\(-> quad(0) = 3.00\fR
+ \fI\(-> quad(1) = 6.00\fR
+ \fI\(-> quad(2) = 11.00\fR
+ \fI\(-> quad(3) = 18.00\fR
+ \fI\(-> quad(4) = 27.00\fR
+.CE
+.VE TIP524
.SH "SEE ALSO"
next(n), oo::class(n), oo::object(n)
.SH KEYWORDS
diff --git a/doc/dict.n b/doc/dict.n
index db4b656..5f5a087 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -27,6 +27,11 @@ key maps to in the dictionary value contained in the given variable,
writing the resulting dictionary value back to that variable.
Non-existent keys are treated as if they map to an empty string. The
updated dictionary value is returned.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the appending operation.
+.VE TIP508
.TP
\fBdict create \fR?\fIkey value ...\fR?
.
@@ -49,10 +54,8 @@ type (which may be abbreviated.) Supported filter types are:
.RS
.TP
\fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR?
-.VS 8.6
The key rule only matches those key/value pairs whose keys match any
of the given patterns (in the style of \fBstring match\fR.)
-.VE 8.6
.TP
\fBdict filter \fIdictionaryValue \fBscript {\fIkeyVariable valueVariable\fB} \fIscript\fR
.
@@ -69,10 +72,8 @@ result. The key/value pairs are tested in the order in which the keys
were inserted into the dictionary.
.TP
\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR?
-.VS 8.6
The value rule only matches those key/value pairs whose values match any
of the given patterns (in the style of \fBstring match\fR.)
-.VE 8.6
.RE
.TP
\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR
@@ -115,6 +116,22 @@ It is an error to attempt to retrieve a value for a key that is not
present in the dictionary.
.RE
.TP
+\fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR
+.TP
+\fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR
+.VS "8.7, TIP342"
+This behaves the same as \fBdict get\fR (with at least one \fIkey\fR
+argument), returning the value that the key path maps to in the
+dictionary \fIdictionaryValue\fR, except that instead of producing an
+error because the \fIkey\fR (or one of the \fIkey\fRs on the key path)
+is absent, it returns the \fIdefault\fR argument instead.
+.RS
+.PP
+Note that there must always be at least one \fIkey\fR provided, and that
+\fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other.
+.RE
+.VE "8.7, TIP342"
+.TP
\fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR?
.
This adds the given increment value (an integer that defaults to 1 if
@@ -124,6 +141,11 @@ resulting dictionary value back to that variable. Non-existent keys
are treated as if they map to 0. It is an error to increment a value
for an existing key if that value is not an integer. The updated
dictionary value is returned.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the incrementing operation.
+.VE TIP508
.TP
\fBdict info \fIdictionaryValue\fR
.
@@ -149,6 +171,11 @@ keys are treated as if they map to an empty list, and it is legal for
there to be no items to append to the list. It is an error for the
value that the key maps to to not be representable as a list. The
updated dictionary value is returned.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the list-appending operation.
+.VE TIP508
.TP
\fBdict map \fR{\fIkeyVariable valueVariable\fR} \fIdictionaryValue body\fR
.
@@ -206,6 +233,11 @@ value and places an updated dictionary value in that variable
containing a mapping from the given key to the given value. When
multiple keys are present, this operation creates or updates a chain
of nested dictionaries. The updated dictionary value is returned.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the value insert/update operation.
+.VE TIP508
.TP
\fBdict size \fIdictionaryValue\fR
.
@@ -221,6 +253,11 @@ through nested dictionaries to the mapping to remove. At least one key
must be specified, but the last key on the key-path need not exist.
All other components on the path must exist. The updated dictionary
value is returned.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the value remove operation.
+.VE TIP508
.TP
\fBdict update \fIdictionaryVariable key varName \fR?\fIkey varName ...\fR? \fIbody\fR
.
@@ -236,6 +273,11 @@ are silently discarded), even if the result of \fIbody\fR is an error
or some other kind of exceptional exit. The result of \fBdict
update\fR is (unless some kind of error occurs) the result of the
evaluation of \fIbody\fR.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the update operation.
+.VE TIP508
.RS
.PP
Each \fIvarName\fR is mapped in the scope enclosing the \fBdict update\fR;
@@ -270,6 +312,11 @@ dictionary be discarded, and this also happens if the contents of
dictionaries no longer exists. The result of \fBdict with\fR is
(unless some kind of error occurs) the result of the evaluation of
\fIbody\fR.
+.VS TIP508
+If \fIdictionaryVariable\fR indicates an element that does not exist of an
+array that has a default value set, the default value and will be used as the
+value of the dictionary prior to the updating operation.
+.VE TIP508
.RS
.PP
The variables are mapped in the scope enclosing the \fBdict with\fR;
diff --git a/doc/encoding.n b/doc/encoding.n
index e78a8e7..c881d26 100644
--- a/doc/encoding.n
+++ b/doc/encoding.n
@@ -8,90 +8,199 @@
.so man.macros
.BS
.SH NAME
-encoding \- Manipulate encodings
+encoding \- Work with encodings
.SH SYNOPSIS
-\fBencoding \fIoption\fR ?\fIarg arg ...\fR?
+\fBencoding \fIoperation\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
-Strings in Tcl are logically a sequence of 16-bit 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 3
-bytes per character), 16-bit
-.QW Unicode
-(which uses 2 bytes per character, with an endianness that is
-dependent on the host architecture), and binary (which uses a single
-byte per character but only handles a restricted range of characters).
-Tcl does not guarantee to always use the same encoding for the same
-string.
-.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.
+In Tcl every string is composed of Unicode values. Text may be encoded into an
+encoding such as cp1252, iso8859-1, Shitf\-JIS, utf-8, utf-16, etc. Not every
+Unicode vealue is encodable in every encoding, and some encodings can encode
+values that are not available in Unicode.
+.PP
+Even though Unicode is for encoding the written texts of human languages, any
+sequence of bytes can be encoded as the first 255 Unicode values. iso8859-1 an
+encoding for a subset of Unicode in which each byte is a Unicode value of 255
+or less. Thus, any sequence of bytes can be considered to be a Unicode string
+encoded in iso8859-1. To work with binary data in Tcl, decode it from
+iso8859-1 when reading it in, and encode it into iso8859-1 when writing it out,
+ensuring that each character in the string has a value of 255 or less.
+Decoding such a string does nothing, and encoding encoding such a string also
+does nothing.
+.PP
+For example, the following is true:
+.CS
+set text {In Tcl binary data is treated as Unicode text and it just works.}
+set encoded [encoding convertto iso8859-1 $text]
+expr {$text eq $encoded}; #-> 1
+.CE
+The following is also true:
+.CS
+set decoded [encoding convertfrom iso8859-1 $text]
+expr {$text eq $decoded}; #-> 1
+.CE
.SH DESCRIPTION
.PP
-Performs one of several encoding related operations, depending on
-\fIoption\fR. The legal \fIoption\fRs are:
+Performs one of the following encoding \fIoperations\fR:
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
+.TP
+\fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding\fR \fIdata\fR
.
-Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The
-characters in \fIdata\fR are treated as binary data where the lower
-8-bits of each character is taken as a single byte. The resulting
-sequence of bytes is treated as a string in the specified
-\fIencoding\fR. If \fIencoding\fR is not specified, the current
-system encoding is used.
+Decodes \fIdata\fR encoded in \fIencoding\fR. If \fIencoding\fR is not
+specified the current system encoding is used.
+
+.VS "TCL8.7 TIP607, TIP656"
+\fB-profile\fR determines how invalid data for the encoding are handled. See
+the \fBPROFILES\fR section below for details. Returns an error if decoding
+fails. However, if \fB-failindex\fR given, returns the result of the
+conversion up to the point of termination, and stores in \fBvar\fR the index of
+the character that could not be converted. If no errors are encountered the
+entire result of the conversion is returned and the value \fB-1\fR is stored in
+\fBvar\fR.
+.VE "TCL8.7 TIP607, TIP656"
.TP
-\fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR
+\fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR
+.TP
+\fBencoding convertto\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding\fR \fIdata\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.
+Converts \fIstring\fR to \fIencoding\fR. If \fIencoding\fR is not given, the
+current system encoding is used.
+
+.VS "TCL8.7 TIP607, TIP656"
+See \fBencoding convertfrom\fR for the meaning of \fB-profile\fR and \fB-failindex\fR.
+.VE "TCL8.7 TIP607, TIP656"
.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
-command returns the current list of directories that make up the
-search path. It is an error for \fIdirectoryList\fR to not be a valid
-list. If, when a search for an encoding data file is happening, an
-element in \fIdirectoryList\fR does not refer to a readable,
-searchable directory, that element is ignored.
+Sets the search path for \fB*.enc\fR encoding data files to the list of
+directories given by \fIdirectoryList\fR. If \fIdirectoryList\fR is not given,
+returns the current list of directories that make up the search path. It is
+not an error for an item in \fIdirectoryList\fR to not refer to a readable,
+searchable directory.
.TP
\fBencoding names\fR
.
-Returns a list containing the names of all of the encodings that are
-currently available.
+Returns a list of the names of available encodings.
The encodings
.QW utf-8
and
.QW iso8859-1
are guaranteed to be present in the list.
+.VS "TCL8.7 TIP656"
+.TP
+\fBencoding profiles\fR
+Returns a list of names of available encoding profiles. See \fBPROFILES\fR
+below.
+.VE "TCL8.7 TIP656"
.TP
\fBencoding system\fR ?\fIencoding\fR?
.
-Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
-omitted then the command returns the current system encoding. The
-system encoding is used whenever Tcl passes strings to system calls.
-.SH EXAMPLE
+Sets the system encoding to \fIencoding\fR. If \fIencoding\fR is not given,
+returns the current system encoding. The system encoding is used to pass
+strings to system calls.
+.\" Do not put .VS on whole section as that messes up the bullet list alignment
+.SH PROFILES
.PP
-The following example converts a byte sequence in Japanese euc-jp encoding to a TCL string:
+.VS "TCL8.7 TIP656"
+Each \fIprofile\fR is a distinct strategy for dealing with invalid data for an
+encoding.
+.PP
+The following profiles are currently implemented.
+.VS "TCL8.7 TIP656"
+.TP
+\fBtcl8\fR
+.
+The default profile. Provides for behaviour identical to that of Tcl 8.6: When
+decoding, for encodings \fBother than utf-8\fR, each invalid byte is interpreted
+as the Unicode value given by that one byte. For example, the byte 0x80, which
+is invalid in the ASCII encoding would be mapped to the Unicode value U+0080.
+For \fButf-8\fR, each invalid byte that is a valid CP1252 character is
+interpreted as the Unicode value for that character, while each byte that is
+not is treated as the Unicode value given by that one byte. For example, byte
+0x80 is defined by CP1252 and is therefore mapped to its Unicode equivalent
+U+20AC while byte 0x81 which is not defined by CP1252 is mapped to U+0081. As
+an additional special case, the sequence 0xC0 0x80 is mapped to U+0000.
+
+When encoding, each character that cannot be represented in the encoding is
+replaced by an encoding-dependent character, usually the question mark \fB?\fR.
+.TP
+\fBstrict\fR
+.
+The operation fails when invalid data for the encoding are encountered.
+.TP
+\fBreplace\fR
+.
+When decoding, invalid bytes are replaced by U+FFFD, the Unicode REPLACEMENT
+CHARACTER.
+
+When encoding, Unicode values that cannot be represented in the target encoding
+are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT
+CHARACTER for UTF targets, and generally `?` for other encodings.
+.VE "TCL8.7 TIP656"
+.SH EXAMPLES
+.PP
+These examples use the utility proc below that prints the Unicode value for
+each character in a string.
.PP
.CS
-set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"]
+proc codepoints s {join [lmap c [split $s {}] {
+ string cat U+ [format %.6X [scan $c %c]]}]
+}
.CE
.PP
-The result is the unicode codepoint:
+Example 1: Convert from euc-jp:
+.PP
+.CS
+% codepoints [\fBencoding convertfrom\fR euc-jp \exA4\exCF]
+U+00306F
+.CE
+.PP
+The result is the Unicode value
.QW "\eu306F" ,
which is the Hiragana letter HA.
+.VS "TCL8.7 TIP607, TIP656"
+.PP
+Example 2: Error handling based on profiles:
+.PP
+The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid
+in ASCII encoding.
+.PP
+.CS
+% codepoints [encoding convertfrom -profile tcl8 ascii A\ex80]
+U+000041 U+000080
+% codepoints [encoding convertfrom -profile replace ascii A\ex80]
+U+000041 U+00FFFD
+% codepoints [encoding convertfrom -profile strict ascii A\ex80]
+unexpected byte sequence starting at index 1: '\ex80'
+.CE
+.PP
+Example 3: Get partial data and the error location:
+.PP
+.CS
+% codepoints [encoding convertfrom -profile strict -failindex idx ascii AB\ex80]
+U+000041 U+000042
+% set idx
+2
+.CE
+.PP
+Example 4: Encode a character that is not representable in ISO8859-1:
+.PP
+.CS
+% encoding convertto iso8859-1 A\eu0141
+A?
+% encoding convertto -profile strict iso8859-1 A\eu0141
+unexpected character at index 1: 'U+000141'
+% encoding convertto -profile strict -failindex idx iso8859-1 A\eu0141
+A
+% set idx
+1
+.CE
+.VE "TCL8.7 TIP607, TIP656"
+.PP
.SH "SEE ALSO"
-Tcl_GetEncoding(3)
+Tcl_GetEncoding(3), fconfigure(n)
.SH KEYWORDS
encoding, unicode
.\" Local Variables:
diff --git a/doc/eof.n b/doc/eof.n
index a150464..0dcf34a 100644
--- a/doc/eof.n
+++ b/doc/eof.n
@@ -59,3 +59,7 @@ while {1} {
file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, end of file
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/exec.n b/doc/exec.n
index a0008ad..01df48b 100644
--- a/doc/exec.n
+++ b/doc/exec.n
@@ -370,7 +370,6 @@ if {[catch {\fBexec\fR grep foo bar.txt} results options]} {
}
}
.CE
-.VS 8.6
.PP
This is more easily written using the \fBtry\fR command, as that makes
it simpler to trap specific types of errors. This is
@@ -384,7 +383,6 @@ try {
set status [lindex [dict get $options -errorcode] 2]
}
.CE
-.VE 8.6
.SS "WORKING WITH QUOTED ARGUMENTS"
.PP
When translating a command from a Unix shell invocation, care should
diff --git a/doc/exit.n b/doc/exit.n
index a005c08..36676b1 100644
--- a/doc/exit.n
+++ b/doc/exit.n
@@ -49,3 +49,7 @@ if {[catch {main} msg options]} {
exec(n)
.SH KEYWORDS
abort, exit, process
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/expr.n b/doc/expr.n
index b2b1d66..dfa77af 100644
--- a/doc/expr.n
+++ b/doc/expr.n
@@ -17,14 +17,14 @@ expr \- Evaluate an expression
.BE
.SH DESCRIPTION
.PP
-Concatenates \fIarg\fRs (adding separator spaces between them),
-evaluates the result as a Tcl expression, and returns the value.
-The operators permitted in Tcl expressions include a subset of
+Concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates
+that expression, returning its value.
+The operators permitted in an expression include a subset of
the operators permitted in C expressions. For those operators
common to both Tcl and C, Tcl applies the same meaning and precedence
as the corresponding C operators.
-Expressions almost always yield numeric results
-(integer or floating-point values).
+The value of an expression is often a numeric result, either an integer or a
+floating-point value, but may also be a non-numeric value.
For example, the expression
.PP
.CS
@@ -32,117 +32,150 @@ For example, the expression
.CE
.PP
evaluates to 14.2.
-Tcl expressions differ from C expressions in the way that
-operands are specified. Also, Tcl expressions support
-non-numeric operands and string comparisons, as well as some
+Expressions differ from C expressions in the way that
+operands are specified. Expressions also support
+non-numeric operands, string comparisons, and some
additional operators not found in C.
+.PP
+When the result of expression is an integer, it is in decimal form, and when
+the result is a floating-point number, it is in the form produced by the
+\fB%g\fR format specifier of \fBformat\fR.
+.PP
+.VS "TIP 582"
+At any point in the expression except within double quotes or braces, \fB#\fR
+is the beginning of a comment, which lasts to the end of the line or
+the end of the expression, whichever comes first.
+.VE "TIP 582"
.SS OPERANDS
.PP
-A Tcl expression consists of a combination of operands, operators,
-parentheses and commas.
-White space may be used between the operands and operators and
-parentheses (or commas); it is ignored by the expression's instructions.
-Where possible, operands are interpreted as integer values.
-Integer values may be specified in decimal (the normal case), in binary
-(if the first two characters of the operand are \fB0b\fR), in octal
-(if the first two characters of the operand are \fB0o\fR), or in hexadecimal
-(if the first two characters of the operand are \fB0x\fR). For
-compatibility with older Tcl releases, an octal integer value is also
-indicated simply when the first character of the operand is \fB0\fR,
-whether or not the second character is also \fBo\fR.
-If an operand does not have one of the integer formats given
-above, then it is treated as a floating-point number if that is
-possible. Floating-point numbers may be specified in any of several
-common formats making use of the decimal digits, the decimal point \fB.\fR,
-the characters \fBe\fR or \fBE\fR indicating scientific notation, and
-the sign characters \fB+\fR or \fB\-\fR. For example, all of the
-following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
-Also recognized as floating point values are the strings \fBInf\fR
-and \fBNaN\fR making use of any case for each character.
-If no numeric interpretation is possible (note that all literal
-operands that are not numeric or boolean must be quoted with either
-braces or with double quotes), then an operand is left as a string
-(and only a limited set of operators may be applied to it).
-.PP
-Operands may be specified in any of the following ways:
-.IP [1]
-As a numeric value, either integer or floating-point.
-.IP [2]
-As a boolean value, using any form understood by \fBstring is\fR
+An expression consists of a combination of operands, operators, parentheses and
+commas, possibly with whitespace between any of these elements, which is
+ignored. Each operand is interpreted as a numeric value if at all possible.
+.PP
+Each operand has one of the following forms:
+.RS
+.PP
+.TP
+A \fBnumeric value\fR
+.PP
+.RS
+.
+Either integer or floating-point. The first two characters of an integer may
+also be \fB0d\fR for decimal, \fB0b\fR for binary, \fB0o\fR for octal or
+\fB0x\fR for hexadicimal. For compatibility with older Tcl releases, an
+operand that begins with \fB0\fR is interpreted as an octal integer even if the
+second character is not \fBo\fR.
+.PP
+A floating-point number may be take any of several
+common decimal formats, and may use the decimal point \fB.\fR,
+\fBe\fR or \fBE\fR for scientific notation, and
+the sign characters \fB+\fR and \fB\-\fR. The
+following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
+The strings \fBInf\fR
+and \fBNaN\fR, in any combination of case, are also recognized as floating point
+values. An operand that doesn't have a numeric interpretation must be quoted
+with either braces or with double quotes.
+.PP
+Digits in any numeric value may be separated with one or more underscore
+characters, "\fB_\fR". A separator may only
+appear between digits, not appear at the start of a
+numeric value, between the leading 0 and radix specifier, or at the
+end of a numeric value. Here are some examples:
+.PP
+.CS
+.ta 9c
+\fBexpr\fR 100_000_000 \fI100000000\fR
+\fBexpr\fR 0xffff_ffff \fI4294967295\fR
+\fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR
+\fBexpr\fR 3_141_592_653_589e-1_2 \fI3.141592653589\fR
+.CE
+.RE
+
+.TP
+A \fBboolean value\fR
+.
+Using any form understood by \fBstring is\fR
\fBboolean\fR.
-.IP [3]
-As a Tcl variable, using standard \fB$\fR notation.
-The variable's value will be used as the operand.
-.IP [4]
-As a string enclosed in double-quotes.
-The expression parser will perform backslash, variable, and
-command substitutions on the information between the quotes,
-and use the resulting value as the operand
-.IP [5]
-As a string enclosed in braces.
-The characters between the open brace and matching close brace
-will be used as the operand without any substitutions.
-.IP [6]
-As a Tcl command enclosed in brackets.
-The command will be executed and its result will be used as
-the operand.
-.IP [7]
-As a mathematical function whose arguments have any of the above
-forms for operands, such as \fBsin($x)\fR. See \fBMATH FUNCTIONS\fR below for
+.TP
+A \fBvariable\fR
+.
+Using standard \fB$\fR notation.
+The value of the variable is the value of the operand.
+.TP
+A string enclosed in \fBdouble-quotes\fR
+.
+Backslash, variable, and command substitution are performed according to the
+rules for \fBTcl\fR.
+.TP
+A string enclosed in \fBbraces\fR.
+The operand is treated as a braced value according to the rule for braces in
+\fBTcl\fR.
+.TP
+A Tcl command enclosed in \fBbrackets\fR
+.
+Command substitution is performed as according to the command substitution rule
+for \fBTcl\fR.
+.TP
+A mathematical function such as \fBsin($x)\fR, whose arguments have any of the above
+forms for operands. See \fBMATH FUNCTIONS\fR below for
a discussion of how mathematical functions are handled.
+.RE
.PP
-Where the above substitutions occur (e.g. inside quoted strings), they
-are performed by the expression's instructions.
-However, the command parser may already have performed one round of
-substitution before the expression processor was called.
-As discussed below, it is usually best to enclose expressions
-in braces to prevent the command parser from performing substitutions
-on the contents.
+Because \fBexpr\fR parses and performs substitutions on values that have
+already been parsed and substituted by \fBTcl\fR, it is usually best to enclose
+expressions in braces to avoid the first round of substitutions by
+\fBTcl\fR.
.PP
-For some examples of simple expressions, suppose the variable
-\fBa\fR has the value 3 and
-the variable \fBb\fR has the value 6.
-Then the command on the left side of each of the lines below
-will produce the value on the right side of the line:
+Below are some examples of simple expressions where the value of \fBa\fR is 3
+and the value of \fBb\fR is 6. The command on the left side of each line
+produces the value on the right side.
.PP
.CS
.ta 9c
\fBexpr\fR {3.1 + $a} \fI6.1\fR
\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR
-\fBexpr\fR {4*[llength "6 2"]} \fI8\fR
+\fBexpr\fR {4*[llength {6 2}]} \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
+.PP
.SS OPERATORS
.PP
-The valid operators (most of which are also available as commands in
-the \fBtcl::mathop\fR namespace; see the \fBmathop\fR(n) manual page
-for details) are listed below, grouped in decreasing order of precedence:
+For operators having both a numeric mode and a string mode, the numeric mode is
+chosen when all operands have a numeric interpretation. The integer
+interpretation of an operand is preferred over the floating-point
+interpretation. To ensure string operations on arbitrary values it is generally a
+good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
+more versatile operators such as \fB==\fR.
+.PP
+Unless otherwise specified, operators accept non-numeric operands. The value
+of a boolean operation is 1 if true, 0 otherwise. See also \fBstring is\fR
+\fBboolean\fR. The valid operators, most of which are also available as
+commands in the \fBtcl::mathop\fR namespace (see \fBmathop\fR(n)), are listed
+below, grouped in decreasing order of precedence:
.TP 20
\fB\-\0\0+\0\0~\0\0!\fR
.
-Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators
-may be applied to string operands, and bit-wise NOT may be
-applied only to integers.
+Unary minus, unary plus, bit-wise NOT, logical NOT. These operators
+may only be applied to numeric operands, and bit-wise NOT may only be
+applied to integers.
.TP 20
\fB**\fR
.
-Exponentiation. Valid for any numeric operands. The maximum exponent value
+Exponentiation. Valid for numeric operands. The maximum exponent value
that Tcl can handle if the first number is an integer > 1 is 268435455.
.TP 20
\fB*\0\0/\0\0%\fR
.
-Multiply, divide, remainder. None of these operators may be
-applied to string operands, and remainder may be applied only
-to integers.
-The remainder will always have the same sign as the divisor and
-an absolute value smaller than the absolute value of the divisor.
+Multiply and divide, which are valid for numeric operands, and remainder, which
+is valid for integers. The remainder, an absolute value smaller than the
+absolute value of the divisor, has the same sign as the divisor.
.RS
.PP
-When applied to integers, the division and remainder operators can be
-considered to partition the number line into a sequence of equal-sized
-adjacent non-overlapping pieces where each piece is the size of the divisor;
-the division result identifies which piece the divisor lay within, and the
-remainder result identifies where within that piece the divisor lay. A
+When applied to integers, division and remainder can be
+considered to partition the number line into a sequence of
+adjacent non-overlapping pieces, where each piece is the size of the divisor;
+the quotient identifies which piece the dividend lies within, and the
+remainder identifies where within that piece the dividend lies. A
consequence of this is that the result of
.QW "-57 \fB/\fR 10"
is always -6, and the result of
@@ -152,183 +185,175 @@ is always 3.
.TP 20
\fB+\0\0\-\fR
.
-Add and subtract. Valid for any numeric operands.
+Add and subtract. Valid for numeric operands.
.TP 20
\fB<<\0\0>>\fR
.
-Left and right shift. Valid for integer operands only.
+Left and right shift. Valid for integers.
A right shift always propagates the sign bit.
.TP 20
\fB<\0\0>\0\0<=\0\0>=\fR
.
-Boolean less, greater, less than or equal, and greater than or equal.
-Each operator produces 1 if the condition is true, 0 otherwise.
-These operators may be applied to strings as well as numeric operands,
-in which case string comparison is used.
+Boolean numeric-preferring comparisons: less than, greater than, less than or
+equal, and greater than or equal. If either argument is not numeric, the
+comparison is done using UNICODE string comparison, as with the string
+comparison operators below, which have the same precedence.
+.TP 20
+\fBlt\0\0gt\0\0le\0\0ge\fR
+.VS "8.7, TIP461"
+Boolean string comparisons: less than, greater than, less than or equal, and
+greater than or equal. These always compare values using their UNICODE strings
+(also see \fBstring compare\fR), unlike with the numeric-preferring
+comparisons abov, which have the same precedence.
+.VE "8.7, TIP461"
.TP 20
\fB==\0\0!=\fR
.
-Boolean equal and not equal. Each operator produces a zero/one result.
-Valid for all operand types.
+Boolean equal and not equal.
.TP 20
\fBeq\0\0ne\fR
.
-Boolean string equal and string not equal. Each operator produces a
-zero/one result. The operand types are interpreted only as strings.
+Boolean string equal and string not equal.
.TP 20
\fBin\0\0ni\fR
.
-List containment and negated list containment. Each operator produces
-a zero/one result and treats its first argument as a string and its
-second argument as a Tcl list. The \fBin\fR operator indicates
-whether the first argument is a member of the second argument list;
-the \fBni\fR operator inverts the sense of the result.
+List containment and negated list containment. The first argument is
+interpreted as a string, the second as a list. \fBin\fR tests for membership
+in the list, and \fBni\fR is the inverse.
.TP 20
\fB&\fR
.
-Bit-wise AND. Valid for integer operands only.
+Bit-wise AND. Valid for integer operands.
.TP 20
\fB^\fR
.
-Bit-wise exclusive OR. Valid for integer operands only.
+Bit-wise exclusive OR. Valid for integer operands.
.TP 20
\fB|\fR
.
-Bit-wise OR. Valid for integer operands only.
+Bit-wise OR. Valid for integer operands.
.TP 20
\fB&&\fR
.
-Logical AND. Produces a 1 result if both operands are non-zero,
-0 otherwise.
-Valid for boolean and numeric (integers or floating-point) operands only.
+Logical AND. If both operands are true, the result is 1, or 0 otherwise.
+This operator evaluates lazily; it only evaluates its second operand if it
+must in order to determine its result.
This operator evaluates lazily; it only evaluates its second operand if it
must in order to determine its result.
.TP 20
\fB||\fR
.
-Logical OR. Produces a 0 result if both operands are zero, 1 otherwise.
-Valid for boolean and numeric (integers or floating-point) operands only.
+Logical OR. If both operands are false, the result is 0, or 1 otherwise.
This operator evaluates lazily; it only evaluates its second operand if it
must in order to determine its result.
.TP 20
\fIx \fB?\fI y \fB:\fI z\fR
.
-If-then-else, as in C. If \fIx\fR
-evaluates to non-zero, then the result is the value of \fIy\fR.
-Otherwise the result is the value of \fIz\fR.
-The \fIx\fR operand must have a boolean or numeric value.
+If-then-else, as in C. If \fIx\fR is false , the result is the value of
+\fIy\fR. Otherwise the result is the value of \fIz\fR.
This operator evaluates lazily; it evaluates only one of \fIy\fR or \fIz\fR.
.PP
-See the C manual for more details on the results
-produced by each operator.
-The exponentiation operator promotes types like the multiply and
-divide operators, and produces a result that is the same as the output
-of the \fBpow\fR function (after any type conversions.)
-All of the binary operators but exponentiation group left-to-right
-within the same precedence level; exponentiation groups right-to-left. For example, the command
+The exponentiation operator promotes types in the same way that the multiply
+and divide operators do, and the result is is the same as the result of
+\fBpow\fR.
+Exponentiation groups right-to-left within a precedence level. Other binary
+operators group left-to-right. For example, the value of
.PP
.PP
.CS
\fBexpr\fR {4*2 < 7}
.CE
.PP
-returns 0, while
+is 0, while the value of
.PP
.CS
\fBexpr\fR {2**3**2}
.CE
.PP
-returns 512.
+is 512.
.PP
-The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have
+As in C, \fB&&\fR, \fB||\fR, and \fB?:\fR feature
.QW "lazy evaluation" ,
-just as in C, which means that operands are not evaluated if they are
-not needed to determine the outcome. For example, in the command
+which means that operands are not evaluated if they are
+not needed to determine the outcome. For example, in
.PP
.CS
\fBexpr\fR {$v?[a]:[b]}
.CE
.PP
-only one of
-.QW \fB[a]\fR
-or
-.QW \fB[b]\fR
-will actually be evaluated,
-depending on the value of \fB$v\fR. Note, however, that this is
-only true if the entire expression is enclosed in braces; otherwise
-the Tcl parser will evaluate both
-.QW \fB[a]\fR
-and
-.QW \fB[b]\fR
-before invoking the \fBexpr\fR command.
+only one of \fB[a]\fR or \fB[b]\fR is evaluated,
+depending on the value of \fB$v\fR. This is not true of the normal Tcl parser,
+so it is normally recommended to enclose the arguments to \fBexpr\fR in braces.
+Without braces, as in
+\fBexpr\fR $v ? [a] : [b]
+both \fB[a]\fR and \fB[b]\fR are evaluated before \fBexpr\fR is even called.
+.PP
+For more details on the results
+produced by each operator, see the documentation for C.
.SS "MATH FUNCTIONS"
.PP
-When the expression parser encounters a mathematical function
-such as \fBsin($x)\fR, it replaces it with a call to an ordinary
-Tcl command in the \fBtcl::mathfunc\fR namespace. The processing
-of an expression such as:
+A mathematical function such as \fBsin($x)\fR is replaced with a call to an ordinary
+Tcl command in the \fBtcl::mathfunc\fR namespace. The evaluation
+of an expression such as
.PP
.CS
\fBexpr\fR {sin($x+$y)}
.CE
.PP
-is the same in every way as the processing of:
+is the same in every way as the evaluation of
.PP
.CS
\fBexpr\fR {[tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]]}
.CE
.PP
-which in turn is the same as the processing of:
+which in turn is the same as the evaluation of
.PP
.CS
tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]
.CE
.PP
-The executor will search for \fBtcl::mathfunc::sin\fR using the usual
-rules for resolving functions in namespaces. Either
-\fB::tcl::mathfunc::sin\fR or \fB[namespace
-current]::tcl::mathfunc::sin\fR will satisfy the request, and others
-may as well (depending on the current \fBnamespace path\fR setting).
+\fBtcl::mathfunc::sin\fR is resolved as described in
+\fBNAMESPACE RESOLUTION\fR in the \fBnamespace\fR(n) documentation. Given the
+default value of \fBnamespace path\fR, \fB[namespace
+current]::tcl::mathfunc::sin\fR or \fB::tcl::mathfunc::sin\fR are the typical
+resolutions.
.PP
-Some mathematical functions have several arguments, separated by commas like in C. Thus:
+As in C, a mathematical function may accept multiple arguments separated by commas. Thus,
.PP
.CS
\fBexpr\fR {hypot($x,$y)}
.CE
.PP
-ends up as
+becomes
.PP
.CS
tcl::mathfunc::hypot $x $y
.CE
.PP
-See the \fBmathfunc\fR(n) manual page for the math functions that are
+See the \fBmathfunc\fR(n) documentation for the math functions that are
available by default.
.SS "TYPES, OVERFLOW, AND PRECISION"
.PP
-All internal computations involving integers are done calling on the
-LibTomMath multiple precision integer library as required so that all
-integer calculations are performed exactly. Note that in Tcl releases
-prior to 8.5, integer calculations were performed with one of the C types
+When needed to guarantee exact performance, internal computations involving
+integers use the LibTomMath multiple precision integer library. In Tcl releases
+prior to 8.5, integer calculations were performed using one of the C types
\fIlong int\fR or \fITcl_WideInt\fR, causing implicit range truncation
in those calculations where values overflowed the range of those types.
-Any code that relied on these implicit truncations will need to explicitly
-add \fBint()\fR or \fBwide()\fR function calls to expressions at the points
-where such truncation is required to take place.
+Any code that relied on these implicit truncations should instead call
+\fBint()\fR or \fBwide()\fR, which do truncate.
.PP
-All internal computations involving floating-point are
-done with the C type \fIdouble\fR.
-When converting a string to floating-point, exponent overflow is
+Internal floating-point computations are
+performed using the \fIdouble\fR C type.
+When converting a string to floating-point value, exponent overflow is
detected and results in the \fIdouble\fR value of \fBInf\fR or
\fB\-Inf\fR as appropriate. Floating-point overflow and underflow
are detected to the degree supported by the hardware, which is generally
-pretty reliable.
+fairly reliable.
.PP
-Conversion among internal representations for integer, floating-point,
-and string operands is done automatically as needed.
-For arithmetic computations, integers are used until some
-floating-point number is introduced, after which floating-point is used.
-For example,
+Conversion among internal representations for integer, floating-point, and
+string operands is done automatically as needed. For arithmetic computations,
+integers are used until some floating-point number is introduced, after which
+floating-point values are used. For example,
.PP
.CS
\fBexpr\fR {5 / 4}
@@ -342,53 +367,35 @@ returns 1, while
.CE
.PP
both return 1.25.
-Floating-point values are always returned with a
+A floating-point result can be distinguished from an integer result by the
+presence of either
.QW \fB.\fR
-or an
+or
.QW \fBe\fR
-so that they will not look like integer values. For example,
+.PP
+. For example,
.PP
.CS
\fBexpr\fR {20.0/5.0}
.CE
.PP
returns \fB4.0\fR, not \fB4\fR.
-.SS "STRING OPERATIONS"
-.PP
-String values may be used as operands of the comparison operators,
-although the expression evaluator tries to do comparisons as integer
-or floating-point when it can,
-i.e., when all arguments to the operator allow numeric interpretations,
-except in the case of the \fBeq\fR and \fBne\fR operators.
-If one of the operands of a comparison is a string and the other
-has a numeric value, a canonical string representation of the numeric
-operand value is generated to compare with the string operand.
-Canonical string representation for integer values is a decimal string
-format. Canonical string representation for floating-point values
-is that produced by the \fB%g\fR format specifier of Tcl's
-\fBformat\fR command. For example, the commands
-.PP
-.CS
-\fBexpr\fR {"0x03" > "2"}
-\fBexpr\fR {"0y" > "0x12"}
-.CE
-.PP
-both return 1. The first comparison is done using integer
-comparison, and the second is done using string comparison.
-Because of Tcl's tendency to treat values as numbers whenever
-possible, it is not generally a good idea to use operators like \fB==\fR
-when you really want string comparison and the values of the
-operands could be arbitrary; it is better in these cases to use
-the \fBeq\fR or \fBne\fR operators, or the \fBstring\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
.PP
-Enclose expressions in braces for the best speed and the smallest
-storage requirements.
-This allows the Tcl bytecode compiler to generate the best code.
-.PP
-As mentioned above, expressions are substituted twice:
-once by the Tcl parser and once by the \fBexpr\fR command.
-For example, the commands
+Where an expression contains syntax that Tcl would otherwise perform
+substitutions on, enclosing an expression in braces or otherwise quoting it
+so that it's a static value allows the Tcl compiler to generate bytecode for
+the expression, resulting in better speed and smaller storage requirements.
+This also avoids issues that can arise if Tcl is allowed to perform
+substitution on the value before \fBexpr\fR is called.
+.PP
+In the following example, the value of the expression is 11 because the Tcl parser first
+substitutes \fB$b\fR and \fBexpr\fR then substitutes \fB$a\fR as part
+of evaluating the expression
+.QW "$a + 2*4" .
+Enclosing the
+expression in braces would result in a syntax error as \fB$b\fR does
+not evaluate to a numeric value.
.PP
.CS
set a 3
@@ -396,25 +403,18 @@ set b {$a + 2}
\fBexpr\fR $b*4
.CE
.PP
-return 11, not a multiple of 4.
-This is because the Tcl parser will first substitute
-.QW "\fB$a + 2\fR"
-for the variable \fBb\fR,
-then the \fBexpr\fR command will evaluate the expression
-.QW "\fB$a + 2*4\fR" .
-.PP
-Most expressions do not require a second round of substitutions.
-Either they are enclosed in braces or, if not,
-their variable and command substitutions yield numbers or strings
-that do not themselves require substitutions.
-However, because a few unbraced expressions
-need two rounds of substitutions,
-the bytecode compiler must emit
-additional instructions to handle this situation.
-The most expensive code is required for
-unbraced expressions that contain command substitutions.
-These expressions must be implemented by generating new code
-each time the expression is executed.
+When an expression is generated at runtime, like the one above is, the bytecode
+compiler must ensure that new code is generated each time the expression
+is evaluated. This is the most costly kind of expression from a performance
+perspective. In such cases, consider directly using the commands described in
+the \fBmathfunc\fR(n) or \fBmathop\fR(n) documentation instead of \fBexpr\fR.
+.PP
+Most expressions are not formed at runtime, but are literal strings or contain
+substitutions that don't introduce other substitutions. To allow the bytecode
+compiler to work with an expression as a string literal at compilation time,
+ensure that it contains no substitutions or that it is enclosed in braces or
+otherwise quoted to prevent Tcl from performing substitutions, allowing
+\fBexpr\fR to perform them instead.
.PP
If it is necessary to include a non-constant expression string within the
wider context of an otherwise-constant expression, the most efficient
@@ -430,11 +430,33 @@ set b {$a + 2}
\fBexpr\fR {[\fBexpr\fR $b] * 4}
.CE
.PP
-When the expression is unbraced to allow the substitution of a function or
-operator, consider using the commands documented in the \fBmathfunc\fR(n) or
-\fBmathop\fR(n) manual pages directly instead.
+In general, you should enclose your expression in braces wherever possible,
+and where not possible, the argument to \fBexpr\fR should be an expression
+defined elsewhere as simply as possible. It is usually more efficient and
+safer to use other techniques (e.g., the commands in the \fBtcl::mathop\fR
+namespace) than it is to do complex expression generation.
.SH EXAMPLES
.PP
+A numeric comparison whose result is 1:
+.PP
+.CS
+\fBexpr\fR {"0x03" > "2"}
+.CE
+.PP
+A string comparison whose result is 1:
+.PP
+.CS
+\fBexpr\fR {"0y" > "0x12"}
+.CE
+.PP
+.VS "8.7, TIP461"
+A forced string comparison whose result is 0:
+.PP
+.CS
+\fBexpr\fR {"0x03" gt "2"}
+.CE
+.VE "8.7, TIP461"
+.PP
Define a procedure that computes an
.QW interesting
mathematical function:
@@ -468,12 +490,14 @@ each other:
puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]"
.CE
.PP
-Set a variable to whether an environment variable is both defined at
-all and also set to a true boolean value:
+Set a variable indicating whether an environment variable is defined and has
+value of true:
.PP
.CS
set isTrue [\fBexpr\fR {
+ # Does the environment variable exist, and...
[info exists ::env(SOME_ENV_VAR)] &&
+ # ...does it contain a proper true value?
[string is true -strict $::env(SOME_ENV_VAR)]
}]
.CE
@@ -487,7 +511,7 @@ set randNum [\fBexpr\fR { int(100 * rand()) }]
array(n), for(n), if(n), mathfunc(n), mathop(n), namespace(n), proc(n),
string(n), Tcl(n), while(n)
.SH KEYWORDS
-arithmetic, boolean, compare, expression, fuzzy comparison
+arithmetic, boolean, compare, expression, fuzzy comparison, integer value
.SH COPYRIGHT
.nf
Copyright \(co 1993 The Regents of the University of California.
diff --git a/doc/fblocked.n b/doc/fblocked.n
index 93cfe87..0a28dcf 100644
--- a/doc/fblocked.n
+++ b/doc/fblocked.n
@@ -65,3 +65,7 @@ vwait forever
gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, nonblocking
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/fconfigure.n b/doc/fconfigure.n
index 2926777..3de22eb 100644
--- a/doc/fconfigure.n
+++ b/doc/fconfigure.n
@@ -103,7 +103,7 @@ system, as returned by \fBencoding system\fR.
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
-\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR
+\fB\-eofchar\fR \fB{\fIchar outChar\fB}\fR
.
This option supports DOS file systems that use Control-z (\ex1A) as an
end of file marker. If \fIchar\fR is not an empty string, then this
@@ -113,8 +113,8 @@ If \fIchar\fR is the empty string, then there is no special end of file
character marker. For read-write channels, a two-element list specifies
the end of file marker for input and output, respectively. As a
convenience, when setting the end-of-file character for a read-write
-channel you can specify a single value that will apply to both reading
-and writing. When querying the end-of-file character of a read-write
+channel you can specify a single value that will apply to reading
+only. When querying the end-of-file character of a read-write
channel, a two-element list will always be returned. The default value
for \fB\-eofchar\fR is the empty string in all cases except for files
under Windows. In that case the \fB\-eofchar\fR is Control-z (\ex1A) for
@@ -122,6 +122,16 @@ reading and the empty string for writing.
The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F;
attempting to set \fB\-eofchar\fR to a value outside of this range will
generate an error.
+.VS "TCL8.7 TIP656"
+.TP
+\fB\-profile\fR \fIprofile\fR
+.
+Specifies the encoding profile to be used on the channel. The encoding
+transforms in use for the channel's input and output will then be subject to the
+rules of that profile. Any failures will result in a channel error. See
+\fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding
+profiles.
+.VE "TCL8.7 TIP656"
.TP
\fB\-translation\fR \fImode\fR
.TP
@@ -278,11 +288,11 @@ set data [read $f $numDataBytes]
close $f
.CE
.SH "SEE ALSO"
-close(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n),
+close(n), encoding(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n),
Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffering, carriage return, end of line, flushing, linemode,
-newline, nonblocking, platform, translation, encoding, filter, byte array,
+newline, nonblocking, platform, profile, translation, encoding, filter, byte array,
binary
'\" Local Variables:
'\" mode: nroff
diff --git a/doc/fcopy.n b/doc/fcopy.n
index d39c803..dc6d8ea 100644
--- a/doc/fcopy.n
+++ b/doc/fcopy.n
@@ -12,7 +12,7 @@
.SH NAME
fcopy \- Copy data from one channel to another
.SH SYNOPSIS
-\fBfcopy \fIinchan\fR \fIoutchan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
+\fBfcopy \fIinputChan\fR \fIoutputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.BE
.SH DESCRIPTION
@@ -20,21 +20,29 @@ fcopy \- Copy data from one channel to another
The \fBfcopy\fR command copies data from one I/O channel, \fIinchan\fR to another I/O channel, \fIoutchan\fR.
The \fBfcopy\fR command leverages the buffering in the Tcl I/O system to
avoid extra copies and to avoid buffering too much data in
-main memory when copying large files to slow destinations like
+main memory when copying large files to destinations like
network sockets.
-.PP
-The \fBfcopy\fR
-command transfers data from \fIinchan\fR until end of file
-or \fIsize\fR bytes or characters have been
-transferred; \fIsize\fR is in bytes if the two channels are using the
-same encoding, and is in characters otherwise.
-If no \fB\-size\fR argument is given,
-then the copy goes until end of file.
-All the data read from \fIinchan\fR is copied to \fIoutchan\fR.
+.
+.SS "DATA QUANTITY"
+All data until \fIEOF\fR is copied.
+In addition, the quantity of copied data may be specified by the option \fB-size\fR.
+The given size is in bytes, if the input channel is in binary mode.
+Otherwise, it is in characters.
+.PP
+The transfer is treated as a binary transfer, if the encoding
+profile is set to
+.QW tcl8
+and the input encoding matches the output encoding.
+In this case, eventual encoding errors are not handled.
+An eventually given size is in bytes in this case.
+This feature is depreciated in TCL 9.
+.
+.SS "BLOCKING OPERATION MODE"
Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete
and returns the number of bytes or characters (using the same rules as
for the \fB\-size\fR option) written to \fIoutchan\fR.
-.PP
+.
+.SS "BACKGROUND OPERATION MODE"
The \fB\-command\fR argument makes \fBfcopy\fR work in the background.
In this case it returns immediately and the \fIcallback\fR is invoked
later when the copy completes.
@@ -66,7 +74,8 @@ copy so those handlers do not interfere with the copy.
Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a
.QW "channel busy"
error.
-.PP
+.
+.SS "CHANNEL TRANSLATION OPTIONS"
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
@@ -77,13 +86,13 @@ can be different than the number of bytes written to \fIoutchan\fR.
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fR or
as the argument to the callback for an asynchronous \fBfcopy\fR.
-.PP
-\fBFcopy\fR obeys the encodings and character translations configured
+.SS "CHANNEL ENCODING OPTIONS"
+\fBFcopy\fR obeys the encodings, profiles and character translations configured
for the channels. This
means that the incoming characters are converted internally first
UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
to. See the manual entry for \fBfconfigure\fR for details on the
-\fB\-encoding\fR and \fB\-translation\fR options. No conversion is
+\fB\-encoding\fR and \fB\-profile\fR options. No conversion is
done if both channels are
set to encoding
.QW binary
@@ -96,6 +105,21 @@ the system will assume that the incoming
bytes are valid UTF-8 characters and convert them according to the
output encoding. The behaviour of the system for bytes which are not
valid UTF-8 characters is undefined in this case.
+.PP
+\fBFcopy\fR may throw encoding errors (error code \fBEILSEQ\fR), if input or output
+channel is configured to the
+.QW strict
+encoding profile.
+.PP
+If an encoding error arises on the input channel, any data before the error byte is
+written to the output channel. The input file pointer is located just before the
+values causing the encoding error.
+Error inspection or recovery is possible by changing the encoding parameters and
+invoking a file command (\fBread\fR, \fBfcopy\fR).
+.PP
+If an encoding error arises on the output channel, the errorneous data is lost.
+To make the difference between the input error case and the output error case, only the
+error message may be inspected (read or write), as both throw the error code \fIEILSEQ\fR.
.SH EXAMPLES
.PP
The first example transfers the contents of one channel exactly to
diff --git a/doc/file.n b/doc/file.n
index 0ea53f4..16b8a77 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -31,6 +31,8 @@ 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
does not exist or its access time cannot be queried or set then an error is
generated. On Windows, FAT file systems do not support access time.
+On \fBzipfs\fR file systems, access time is mapped to the modification
+time.
.TP
\fBfile attributes \fIname\fR
.TP
@@ -81,6 +83,19 @@ clears the readonly attribute of the file. \fB\-rsrclength\fR gives
the length of the resource fork of the file, this attribute can only be
set to the value 0, which results in the resource fork being stripped
off the file.
+.PP
+On all platforms, files in \fBzipfs\fR mounted archives return the following
+attributes. These are all read-only and cannot be directly set.
+\fB-archive\fR gives the path of the mounted ZIP archive containing the file.
+\fB-compsize\fR gives the compressed size of the file within the archive.
+This is \fB0\fR for directories.
+\fB-crc\fR gives the CRC of the file if present, else \fB0\fR.
+\fB-mount\fR gives the path where the containing archive is mounted.
+\fB-offset\fR gives the offset of the file within the archive.
+\fB-uncompsize\fR gives the uncompressed size of the file.
+This is \fB0\fR for directories.
+Other attributes may be present in the returned list. These should
+be ignored.
.RE
.TP
\fBfile channels\fR ?\fIpattern\fR?
@@ -180,6 +195,24 @@ 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.
@@ -251,14 +284,14 @@ symbolic and hard links (the latter for files only). Windows
supports symbolic directory links and hard file links on NTFS drives.
.RE
.TP
-\fBfile lstat \fIname varName\fR
+\fBfile lstat \fIname ?varName?\fR
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
kernel call instead of \fIstat\fR. This means that if \fIname\fR
-refers to a symbolic link the information returned in \fIvarName\fR
-is for the link rather than the file it refers to. On systems that
-do not support symbolic links this option behaves exactly the same
-as the \fBstat\fR option.
+refers to a symbolic link the information returned is for the link
+rather than the file it refers to. On systems that do not support
+symbolic links this option behaves exactly the same as the
+\fBstat\fR option.
.TP
\fBfile mkdir\fR ?\fIdir\fR ...?
.
@@ -277,6 +310,7 @@ the file (equivalent to Unix \fBtouch\fR). The time is measured in the
standard POSIX fashion as seconds from a fixed starting time (often January
1, 1970). If the file does not exist or its modified time cannot be queried
or set then an error is generated.
+On \fBzipfs\fR file systems, modification time cannot be explicitly set.
.TP
\fBfile nativename \fIname\fR
.
@@ -393,19 +427,20 @@ that use the third component do not attempt to perform tilde
substitution.
.RE
.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,
-\fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR,
-\fBuid\fR. Each element except \fBtype\fR is a decimal string with the
-value of the corresponding field from the \fBstat\fR return structure;
-see the manual entry for \fBstat\fR for details on the meanings of the
-values. The \fBtype\fR element gives the type of the file in the same
-form returned by the command \fBfile type\fR. This command returns an
-empty string.
+\fBfile stat \fIname ?varName?\fR
+.
+Invokes the \fBstat\fR kernel call on \fIname\fR, and returns a
+dictionary with the information returned from the kernel call. If
+\fIvarName\fR is given, it uses the variable to hold the information.
+\fIVarName\fR is treated as an array variable, and in such case the
+command returns the empty string. The following elements are set:
+\fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR,
+\fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR, \fBuid\fR. Each element
+except \fBtype\fR is a decimal string with the value of the corresponding
+field from the \fBstat\fR return structure; see the manual entry for
+\fBstat\fR for details on the meanings of the values. The \fBtype\fR
+element gives the type of the file in the same form returned by the
+command \fBfile type\fR.
.TP
\fBfile system \fIname\fR
.
@@ -436,9 +471,38 @@ If \fIname\fR contains no separators then returns \fIname\fR. So,
\fBfile tail a/b\fR, \fBfile tail a/b/\fR and \fBfile tail b\fR all
return \fBb\fR.
.TP
+\fBfile tempdir\fR ?\fItemplate\fR?
+.VS "8.7, TIP 431"
+Creates a temporary directory (guaranteed to be newly created and writable by
+the current script) and returns its name. If \fItemplate\fR is given, it
+specifies one of or both of the existing directory (on a filesystem controlled
+by the operating system) to contain the temporary directory, and the base part
+of the directory name; it is considered to have the location of the directory
+if there is a directory separator in the name, and the base part is everything
+after the last directory separator (if non-empty). The default containing
+directory is determined by system-specific operations, and the default base
+name prefix is
+.QW \fBtcl\fR .
+.RS
+.PP
+The following output is typical and illustrative; the actual output will vary
+between platforms:
+.PP
+.CS
+% \fBfile tempdir\fR
+/var/tmp/tcl_u0kuy5
+ % \fBfile tempdir\fR /tmp/myapp
+/tmp/myapp_8o7r9L
+% \fBfile tempdir\fR /tmp/
+/tmp/tcl_1mOJHD
+% \fBfile tempdir\fR myapp
+/var/tmp/myapp_0ihS0n
+.CE
+.RE
+.VE "8.7, TIP 431"
+.TP
\fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR?
'\" TIP #210
-.VS 8.6
Creates a temporary file and returns a read-write channel opened on that file.
If the \fInameVar\fR is given, it specifies a variable that the name of the
temporary file will be written into; if absent, Tcl will attempt to arrange
@@ -453,7 +517,22 @@ 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
-.VE 8.6
+.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 \fBHOME\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
+\fBHOME\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
.
diff --git a/doc/fileevent.n b/doc/fileevent.n
index 2751040..bbba997 100644
--- a/doc/fileevent.n
+++ b/doc/fileevent.n
@@ -154,3 +154,7 @@ fconfigure(n), gets(n), interp(n), puts(n), read(n), Tcl_StandardChannels(3)
.SH KEYWORDS
asynchronous I/O, blocking, channel, event handler, nonblocking, readable,
script, writable.
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/filename.n b/doc/filename.n
index 31d4fe0..d8a3364 100644
--- a/doc/filename.n
+++ b/doc/filename.n
@@ -47,7 +47,8 @@ absolute, and file names may contain any character other than slash.
The file names \fB\&.\fR and \fB\&..\fR are special and refer to the
current directory and the parent of the current directory respectively.
Multiple adjacent slash characters are interpreted as a single
-separator. Any number of trailing slash characters at the end of a
+separator, except for the first double slash \fB//\fR in absolute paths.
+Any number of trailing slash characters at the end of a
path are simply ignored, so the paths \fBfoo\fR, \fBfoo/\fR and
\fBfoo//\fR are all identical, and in particular \fBfoo/\fR does not
necessarily mean a directory is being referred.
@@ -118,6 +119,13 @@ 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
+.TP
+\fBZipfs\fR
+.RS
+On all platforms where \fBzipfs\fR support is enabled, paths within mounted
+ZIP archives begin with the string returned by the \fBzipfs root\fR command.
+Zipfs paths are case-sensitive on all platforms.
+.RE
.SH "TILDE SUBSTITUTION"
.PP
In addition to the file name rules described above, Tcl also supports
@@ -170,7 +178,11 @@ or dots with trailing characters
.QW .....abc
is illegal.
.SH "SEE ALSO"
-file(n), glob(n)
+file(n), glob(n), zipfs(n)
.SH KEYWORDS
current directory, absolute file name, relative file name,
volume-relative file name, portability
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/flush.n b/doc/flush.n
index 6b98ab7..1d84383 100644
--- a/doc/flush.n
+++ b/doc/flush.n
@@ -43,3 +43,7 @@ puts "Hello there, $name!"
file(n), open(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffer, channel, flush, nonblocking, output
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/foreach.n b/doc/foreach.n
index 925ec1f..43f961a 100644
--- a/doc/foreach.n
+++ b/doc/foreach.n
@@ -102,3 +102,7 @@ for(n), while(n), break(n), continue(n)
.SH KEYWORDS
foreach, iteration, list, loop
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/format.n b/doc/format.n
index 1c511e8..eb64491 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -83,12 +83,15 @@ Specifies that the number should be padded on the left with
zeroes instead of spaces.
.TP 10
\fB#\fR
-Requests an alternate output form. For \fBo\fR
-conversions it guarantees that the first digit is always \fB0\fR.
-For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
+Requests an alternate output form. For \fBo\fR conversions,
+\fB0o\fR will be added to the beginning of the result unless
+it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR
will be added to the beginning of the result unless it is zero.
For \fBb\fR conversions, \fB0b\fR
will be added to the beginning of the result unless it is zero.
+For \fBd\fR conversions, \fB0d\fR there is no effect unless
+the \fB0\fR specifier is used as well: In that case, \fB0d\fR
+will be added to the beginning.
For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR,
\fBg\fR, and \fBG\fR) it guarantees that the result always
has a decimal point.
@@ -130,7 +133,7 @@ it must be a numeric string.
.SS "OPTIONAL SIZE MODIFIER"
.PP
The fifth part of a conversion specifier is a size modifier,
-which must be \fBll\fR, \fBh\fR, or \fBl\fR.
+which must be \fBll\fR, \fBh\fR, \fBl\fR, or \fBL\fR.
If it is \fBll\fR it specifies that an integer value is taken
without truncation for conversion to a formatted substring.
If it is \fBh\fR it specifies that an integer value is
@@ -138,7 +141,9 @@ truncated to a 16-bit range before converting. This option is rarely useful.
If it is \fBl\fR it specifies that the integer value is
truncated to the same range as that produced by the \fBwide()\fR
function of the \fBexpr\fR command (at least a 64-bit range).
-If neither \fBh\fR nor \fBl\fR are present, the integer value is
+If it is \fBL\fR it specifies that an integer or double value is taken
+without truncation for conversion to a formatted substring.
+If neither \fBh\fR nor \fBl\fR nor \fBL\fR are present, the integer value is
truncated to the same range as that produced by the \fBint()\fR
function of the \fBexpr\fR command (at least a 32-bit range, but
determined by the value of the \fBwordSize\fR element of the
@@ -198,8 +203,19 @@ precision, then convert number as for \fB%e\fR or
Otherwise convert as for \fB%f\fR.
Trailing zeroes and a trailing decimal point are omitted.
.TP 10
+\fBa\fR or \fBA\fR
+Convert double to hexadecimal notation in the form
+\fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is
+determined by the precision (default: 13).
+If the \fBA\fR form is used then the hex characters
+are printed in uppercase.
+.TP 10
\fB%\fR
No conversion: just insert \fB%\fR.
+.TP 10
+\fBp\fR
+Shorthand form for \fB0x%zx\fR, so it outputs the integer in
+hexadecimal form with \fB0x\fR prefix.
.SH "DIFFERENCES FROM ANSI SPRINTF"
.PP
The behavior of the format command is the same as the
@@ -208,13 +224,12 @@ differences:
.IP [1]
Tcl guarantees that it will be working with UNICODE characters.
.IP [2]
-\fB%p\fR and \fB%n\fR specifiers are not supported.
+\fB%n\fR specifier is not supported.
.IP [3]
For \fB%c\fR conversions the argument must be an integer value,
which will then be converted to the corresponding character value.
.IP [4]
The size modifiers are ignored when formatting floating-point values.
-The \fBll\fR modifier has no \fBsprintf\fR counterpart.
The \fBb\fR specifier has no \fBsprintf\fR counterpart.
.SH EXAMPLES
.PP
diff --git a/doc/fpclassify.n b/doc/fpclassify.n
new file mode 100644
index 0000000..22d365e
--- /dev/null
+++ b/doc/fpclassify.n
@@ -0,0 +1,83 @@
+'\"
+'\" Copyright (c) 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved
+'\" Copyright (c) 2019 Donal Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH fpclassify n 8.7 Tcl "Tcl Float Classifier"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+fpclassify \- Floating point number classification of Tcl values
+.SH SYNOPSIS
+package require \fBtcl 8.7\fR
+.sp
+\fBfpclassify \fIvalue\fR
+.BE
+.SH DESCRIPTION
+The \fBfpclassify\fR command takes a floating point number, \fIvalue\fR, and
+returns one of the following strings that describe it:
+.TP
+\fBzero\fR
+.
+\fIvalue\fR is a floating point zero.
+.TP
+\fBsubnormal\fR
+.
+\fIvalue\fR is the result of a gradual underflow.
+.TP
+\fBnormal\fR
+.
+\fIvalue\fR is an ordinary floating-point number (not zero, subnormal,
+infinite, nor NaN).
+.TP
+\fBinfinite\fR
+.
+\fIvalue\fR is a floating-point infinity.
+.TP
+\fBnan\fR
+.
+\fIvalue\fR is Not-a-Number.
+.PP
+The \fBfpclassify\fR command throws an error if value is not a floating-point
+value and cannot be converted to one.
+.SH EXAMPLE
+.PP
+This shows how to check whether the result of a computation is numerically
+safe or not. (Note however that it does not guard against numerical errors;
+just against representational problems.)
+.PP
+.CS
+set value [command-that-computes-a-value]
+switch [\fBfpclassify\fR $value] {
+ normal - zero {
+ puts "Result is $value"
+ }
+ infinite {
+ puts "Result is infinite"
+ }
+ subnormal {
+ puts "Result is $value - WARNING! precision lost"
+ }
+ nan {
+ puts "Computation completely failed"
+ }
+}
+.CE
+.SH "SEE ALSO"
+expr(n), mathfunc(n)
+.SH KEYWORDS
+floating point
+.SH STANDARDS
+This command depends on the \fBfpclassify\fR() C macro conforming to
+.QW "ISO C99"
+(i.e., to ISO/IEC 9899:1999).
+.SH COPYRIGHT
+.nf
+Copyright \(co 2018 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved
+.fi
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/gets.n b/doc/gets.n
index 57532c0..29355a4 100644
--- a/doc/gets.n
+++ b/doc/gets.n
@@ -47,6 +47,43 @@ produce the same results as if there were an input line consisting
only of the end-of-line character(s).
The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish
these three cases.
+.SH "ENCODING ERRORS"
+.PP
+Encoding errors may exist, if the encoding profile \fBstrict\fR is used.
+Encoding errors are special, as an eventual introspection or recovery is
+possible by changing to an encoding which accepts the data.
+An encoding error is reported by the POSIX error code \fBEILSEQ\fR.
+The file pointer is unchanged in the error case.
+.PP
+Here is an example with an encoding error in UTF-8 encoding, which is then
+introspected by a switch to the binary encoding. The test file contains a not
+continued multi-byte sequence at position 1 (\fBA \\xC3 B\fR):
+.PP
+File creation for example
+.CS
+% set f [open test_A_195_B.txt wb]; puts -nonewline $f A\\xC3B; close $f
+.CE
+Encoding error example
+.CS
+% set f [open test_A_195_B.txt r]
+file384b6a8
+% fconfigure $f -encoding utf-8 -profile strict
+% catch {gets $f} e d
+1
+% set d
+-code 1 -level 0
+-errorstack {INNER {invokeStk1 gets file384b6a8}}
+-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
+-errorinfo {...} -errorline 1
+% tell $f
+0
+% fconfigure $f -encoding binary -profile strict
+% gets $f
+AÃB
+.CE
+Compared to \fBread\fR, any already decoded data is not consumed.
+The file position is still at 0 and the recovery \fBgets\fR returns also the
+already well decoded leading data.
.SH "EXAMPLE"
This example reads a file one line at a time and prints it out with
the current line number attached to the start of each line.
diff --git a/doc/global.n b/doc/global.n
index 9848817..e6d2678b 100644
--- a/doc/global.n
+++ b/doc/global.n
@@ -56,3 +56,7 @@ proc accum {string} {
namespace(n), upvar(n), variable(n)
.SH KEYWORDS
global, namespace, procedure, variable
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/history.n b/doc/history.n
index 0391948..05d936e 100644
--- a/doc/history.n
+++ b/doc/history.n
@@ -100,3 +100,7 @@ the \fBevent\fR operation to retrieve some event,
and the \fBadd\fR operation to add it to history and execute it.
.SH KEYWORDS
event, history, record
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/http.n b/doc/http.n
index c3ce165..ff2307e 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -6,17 +6,17 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH "http" n 2.9 http "Tcl Bundled Packages"
+.TH "http" n 2.10 http "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
http \- Client-side implementation of the HTTP/1.1 protocol
.SH SYNOPSIS
-\fBpackage require http ?2.9?\fR
+\fBpackage require http\fR ?\fB2.10\fR?
.\" See Also -useragent option documentation in body!
.sp
-\fB::http::config ?\fI\-option value\fR ...?
+\fB::http::config\fR ?\fI\-option value\fR ...?
.sp
\fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...?
.sp
@@ -32,36 +32,67 @@ http \- Client-side implementation of the HTTP/1.1 protocol
.sp
\fB::http::size \fItoken\fR
.sp
-\fB::http::code \fItoken\fR
+\fB::http::error \fItoken\fR
.sp
-\fB::http::ncode \fItoken\fR
+\fB::http::postError \fItoken\fR
.sp
-\fB::http::meta \fItoken\fR
+\fB::http::cleanup \fItoken\fR
.sp
-\fB::http::data \fItoken\fR
+\fB::http::requestLine\fR \fItoken\fR
.sp
-\fB::http::error \fItoken\fR
+\fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR?
.sp
-\fB::http::cleanup \fItoken\fR
+\fB::http::requestHeaderValue\fR \fItoken\fR \fIheaderName\fR
+.sp
+\fB::http::responseLine\fR \fItoken\fR
+.sp
+\fB::http::responseCode\fR \fItoken\fR
+.sp
+\fB::http::reasonPhrase\fR \fIcode\fR
+.sp
+\fB::http::responseHeaders\fR \fItoken\fR ?\fIheaderName\fR?
+.sp
+\fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR
+.sp
+\fB::http::responseInfo\fR \fItoken\fR
+.sp
+\fB::http::responseBody\fR \fItoken\fR
.sp
\fB::http::register \fIproto port command\fR
.sp
\fB::http::registerError \fIport\fR ?\fImessage\fR?
.sp
\fB::http::unregister \fIproto\fR
+.sp
+\fB::http::code \fItoken\fR
+.sp
+\fB::http::data \fItoken\fR
+.sp
+\fB::http::meta \fItoken\fR ?\fIheaderName\fR?
+.sp
+\fB::http::metaValue\fR \fItoken\fR \fIheaderName\fR
+.sp
+\fB::http::ncode \fItoken\fR
.SH "EXPORTED COMMANDS"
.PP
Namespace \fBhttp\fR exports the commands \fBconfig\fR, \fBformatQuery\fR,
-\fBgeturl\fR, \fBquoteString\fR, \fBregister\fR, \fBregisterError\fR,
+\fBgeturl\fR, \fBpostError\fR, \fBquoteString\fR, \fBreasonPhrase\fR,
+\fBregister\fR,
+\fBregisterError\fR, \fBrequestHeaders\fR, \fBrequestHeaderValue\fR,
+\fBrequestLine\fR, \fBresponseBody\fR, \fBresponseCode\fR,
+\fBresponseHeaders\fR, \fBresponseHeaderValue\fR, \fBresponseInfo\fR,
+\fBresponseLine\fR,
\fBreset\fR, \fBunregister\fR, and \fBwait\fR.
.PP
It does not export the commands \fBcleanup\fR, \fBcode\fR, \fBdata\fR,
-\fBerror\fR, \fBmeta\fR, \fBncode\fR, \fBsize\fR, or \fBstatus\fR.
+\fBerror\fR, \fBmeta\fR, \fBmetaValue\fR, \fBncode\fR,
+\fBsize\fR, or \fBstatus\fR.
.BE
.SH DESCRIPTION
.PP
The \fBhttp\fR package provides the client side of the HTTP/1.1
-protocol, as defined in RFC 7230 to RFC 7235, which supersede RFC 2616.
+protocol, as defined in RFC 9110 to 9112, which supersede RFC 7230
+to RFC 7235, which in turn supersede RFC 2616.
The package implements the GET, POST, and HEAD operations
of HTTP/1.1. It allows configuration of a proxy host to get through
firewalls. The package is compatible with the \fBSafesock\fR security
@@ -74,14 +105,13 @@ The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.
The return value of \fB::http::geturl\fR is a token for the transaction.
-The value is also the name of an array in the ::http namespace
-that contains state information about the transaction. The elements
-of this array are described in the \fBSTATE ARRAY\fR section.
+The token can be supplied as an argument to other commands, to manage the
+transaction and examine its results.
.PP
If the \fB\-command\fR option is specified, then
the HTTP operation is done in the background.
\fB::http::geturl\fR returns immediately after generating the
-HTTP request and the callback is invoked
+HTTP request and the \fB\-command\fR callback is invoked
when the transaction completes. For this to work, the Tcl event loop
must be active. In Tk applications this is always true. For pure-Tcl
applications, the caller can use \fB::http::wait\fR after calling
@@ -90,6 +120,15 @@ applications, the caller can use \fB::http::wait\fR after calling
\fBNote:\fR The event queue is even used without the \fB\-command\fR option.
As a side effect, arbitrary commands may be processed while \fBhttp::geturl\fR
is running.
+.PP
+When the HTTP server has replied to the request, call the command
+\fB::http::responseInfo\fR, which
+returns a \fBdict\fR of metadata that is essential for identifying a
+successful transaction and making use of the response. See
+section \fBMETADATA\fR for details of the information returned.
+The response itself is returned by command \fB::http::responseBody\fR,
+unless it has been redirected to a file by the \fI\-channel\fR option
+of \fB::http::geturl\fR.
.SH COMMANDS
.TP
\fB::http::config\fR ?\fIoptions\fR?
@@ -111,6 +150,15 @@ comma-separated list of mime type patterns that you are
willing to receive. For example,
.QW "image/gif, image/jpeg, text/*" .
.TP
+\fB\-cookiejar\fR \fIcommand\fR
+.VS TIP406
+The cookie store for the package to use to manage HTTP cookies.
+\fIcommand\fR is a command prefix list; if the empty list (the
+default value) is used, no cookies will be sent by requests or stored
+from responses. The command indicated by \fIcommand\fR, if supplied,
+must obey the \fBCOOKIE JAR PROTOCOL\fR described below.
+.VE TIP406
+.TP
\fB\-pipeline\fR \fIboolean\fR
.
Specifies whether HTTP/1.1 transactions on a persistent socket will be
@@ -124,14 +172,15 @@ fresh socket, overriding the \fB\-keepalive\fR option of
command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for
details. The default is 0.
.TP
-\fB\-proxyhost\fR \fIhostname\fR
-.
-The name of the proxy host, if any. If this value is the
-empty string, the URL host is contacted directly.
-.TP
-\fB\-proxyport\fR \fInumber\fR
+\fB\-proxyauth\fR \fIstring\fR
.
-The proxy port number.
+If non-empty, the string is supplied to the proxy server as the value of the
+request header Proxy-Authorization. This option can be used for HTTP Basic
+Authentication. If the proxy server requires authentication by another
+technique, e.g. Digest Authentication, the \fB\-proxyauth\fR option is not
+useful. In that case the caller must expect a 407 response from the proxy,
+compute the authentication value to be supplied, and use the \fB\-headers\fR
+option to supply it as the value of the Proxy-Authorization header.
.TP
\fB\-proxyfilter\fR \fIcommand\fR
.
@@ -140,18 +189,46 @@ The command is a callback that is made during
to determine if a proxy is required for a given host. One argument, a
host name, is added to \fIcommand\fR when it is invoked. If a proxy
is required, the callback should return a two-element list containing
-the proxy server and proxy port. Otherwise the filter should return
-an empty list. The default filter returns the values of the
-\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
-non-empty.
+the proxy server and proxy port. Otherwise the filter command should return
+an empty list.
.RS
.PP
+The default value of \fB\-proxyfilter\fR is \fBhttp::ProxyRequired\fR, and
+this command returns the values of the \fB\-proxyhost\fR and
+\fB\-proxyport\fR settings if they are non-empty. The options
+\fB\-proxyhost\fR, \fB\-proxyport\fR, and \fB\-proxynot\fR are used only
+by \fBhttp::ProxyRequired\fR, and nowhere else in \fB::http::geturl\fR.
+A user-supplied \fB\-proxyfilter\fR command may use these options, or
+alternatively it may obtain values from elsewhere in the calling script.
+In the latter case, any values provided for \fB\-proxyhost\fR,
+\fB\-proxyport\fR, and \fB\-proxynot\fR are unused.
+.PP
The \fB::http::geturl\fR command runs the \fB\-proxyfilter\fR callback inside
a \fBcatch\fR command. Therefore an error in the callback command does
not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for
details.
.RE
.TP
+\fB\-proxyhost\fR \fIhostname\fR
+.
+The host name or IP address of the proxy server, if any. If this value is
+the empty string, the URL host is contacted directly. See
+\fB\-proxyfilter\fR for how the value is used.
+.TP
+\fB\-proxynot\fR \fIlist\fR
+.
+A Tcl list of domain names and IP addresses that should be accessed directly,
+not through the proxy server. The target hostname is compared with each list
+element using a case-insensitive \fBstring match\fR. It is often convenient
+to use the wildcard "*" at the start of a domain name (e.g. *.example.com) or
+at the end of an IP address (e.g. 192.168.0.*). See \fB\-proxyfilter\fR for
+how the value is used.
+.TP
+\fB\-proxyport\fR \fInumber\fR
+.
+The port number of the proxy server. See \fB\-proxyfilter\fR for how the
+value is used.
+.TP
\fB\-repost\fR \fIboolean\fR
.
Specifies what to do if a POST request over a persistent connection fails
@@ -164,16 +241,29 @@ 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. Prior to http 2.5 this was unspecified, and that behavior can be
-returned by specifying the empty string (\fB{}\fR), although
-\fIiso8859-1\fR is recommended to restore similar behavior but without the
-\fB::http::formatQuery\fR or \fB::http::quoteString\fR
-throwing an error processing non-latin-1 characters.
+The default is \fButf-8\fR, as specified by RFC 2718.
.TP
\fB\-useragent\fR \fIstring\fR
.
@@ -188,21 +278,22 @@ numbers of \fBhttp\fR and \fBTcl\fR.
\fB\-zip\fR \fIboolean\fR
.
If the value is boolean \fBtrue\fR, then by default requests will send a header
-.QW "\fBAccept-Encoding: gzip,deflate,compress\fR" .
-If the value is boolean \fBfalse\fR, then by default this header will not be
-sent. In either case the default can be overridden for an individual request by
+.QW "\fBAccept-Encoding: gzip,deflate\fR" .
+If the value is boolean \fBfalse\fR, then by default requests will send a header
+.QW "\fBAccept-Encoding: identity\fR" .
+In either case the default can be overridden for an individual request by
supplying a custom \fBAccept-Encoding\fR header in the \fB\-headers\fR option
-of \fBhttp::geturl\fR. The default is 1.
+of \fBhttp::geturl\fR. The default value is 1.
.RE
.TP
\fB::http::geturl\fR \fIurl\fR ?\fIoptions\fR?
.
The \fB::http::geturl\fR command is the main procedure in the package.
-The \fB\-query\fR option causes a POST operation and
+The \fB\-query\fR or \fB\-querychannel\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed. The \fB::http::geturl\fR command
-returns a \fItoken\fR value that can be used to get
-information about the transaction. See the \fBSTATE ARRAY\fR and
+returns a \fItoken\fR value that can be passed as an argument to other commands
+to get information about the transaction. See the \fBMETADATA\fR and
\fBERRORS\fR section for
details. The \fB::http::geturl\fR command blocks until the operation
completes, unless the \fB\-command\fR option specifies a callback
@@ -214,7 +305,7 @@ that is invoked when the HTTP transaction completes.
.
Specifies whether to force interpreting the URL data as binary. Normally
this is auto-detected (anything not beginning with a \fBtext\fR content
-type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
+type or whose content encoding is \fBgzip\fR or \fBdeflate\fR is
considered binary data).
.TP
\fB\-blocksize\fR \fIsize\fR
@@ -226,13 +317,14 @@ At most \fIsize\fR bytes are read at once. After each block, a call to the
\fB\-channel\fR \fIname\fR
.
Copy the URL contents to channel \fIname\fR instead of saving it in
-\fBstate(body)\fR.
+a Tcl variable for retrieval by \fB::http::responseBody\fR.
.TP
\fB\-command\fR \fIcallback\fR
.
-Invoke \fIcallback\fR after the HTTP transaction completes.
-This option causes \fB::http::geturl\fR to return immediately.
-The \fIcallback\fR gets an additional argument that is the \fItoken\fR returned
+The presence of this option causes \fB::http::geturl\fR to return immediately.
+After the HTTP transaction completes, the value of \fIcallback\fR is expanded,
+an additional argument is added, and the resulting command is evaluated.
+The additional argument is the \fItoken\fR returned
from \fB::http::geturl\fR. This token is the name of an array that is
described in the \fBSTATE ARRAY\fR section. Here is a template for the
callback:
@@ -240,8 +332,10 @@ callback:
.PP
.CS
proc httpCallback {token} {
- upvar #0 $token state
- # Access state as a Tcl array
+ upvar 0 $token state
+ # Access state as a Tcl array defined in this proc
+ ...
+ return
}
.CE
.PP
@@ -251,11 +345,30 @@ not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for
details.
.RE
.TP
+\fB\-guesstype\fR \fIboolean\fR
+.
+Attempt to guess the \fBContent-Type\fR and character set when a misconfigured
+server provides no information. The default value is \fIfalse\fR (do
+nothing). If boolean \fItrue\fR then, if the server does not send a
+\fBContent-Type\fR header, or if it sends the value "application/octet-stream",
+\fBhttp::geturl\fR will attempt to guess appropriate values. This is not
+intended to become a general-purpose tool, and currently it is limited to
+detecting XML documents that begin with an XML declaration. In this case
+the \fBContent-Type\fR is changed to "application/xml", the binary flag
+state(binary) is changed to 0, and the character set is changed to
+the one specified by the "encoding" tag of the XML line, or to utf-8 if no
+encoding is specified. Not used if a \fI\-channel\fR is specified.
+.TP
\fB\-handler\fR \fIcallback\fR
.
-Invoke \fIcallback\fR whenever HTTP data is available; if present, nothing
-else will be done with the HTTP data. This procedure gets two additional
-arguments: the socket for the HTTP data and the \fItoken\fR returned from
+If this option is absent, \fBhttp::geturl\fR processes incoming data itself,
+either appending it to the state(body) variable or writing it to the -channel.
+But if the \fB\-handler\fR option is present, \fBhttp::geturl\fR does not do
+this processing and instead calls \fIcallback\fR.
+Whenever HTTP data is available, the value of \fIcallback\fR is expanded, an
+additional two arguments are added, and the resulting command is evaluated.
+The two additional
+arguments are: the socket for the HTTP data and the \fItoken\fR returned from
\fB::http::geturl\fR. The token is the name of a global array that is
described in the \fBSTATE ARRAY\fR section. The procedure is expected
to return the number of bytes read from the socket. Here is a
@@ -264,8 +377,8 @@ template for the callback:
.PP
.CS
proc httpHandlerCallback {socket token} {
- upvar #0 $token state
- # Access socket, and state as a Tcl array
+ upvar 0 $token state
+ # Access socket, and state as a Tcl array defined in this proc
# For example...
...
set data [read $socket 1000]
@@ -278,8 +391,9 @@ proc httpHandlerCallback {socket token} {
The \fBhttp::geturl\fR code for the \fB\-handler\fR option is not compatible
with either compression or chunked transfer-encoding. If \fB\-handler\fR is
specified, then to work around these issues \fBhttp::geturl\fR will reduce the
-HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will not
-send the header "\fBAccept-Encoding: gzip,deflate,compress\fR").
+HTTP protocol to 1.0, and override the \fB\-zip\fR option (i.e. it will
+send the header \fBAccept-Encoding: identity\fR instead
+of \fBAccept-Encoding: gzip,deflate\fR).
.PP
If options \fB\-handler\fR and \fB\-channel\fR are used together, the handler
is responsible for copying the data from the HTTP socket to the specified
@@ -325,7 +439,10 @@ It is the caller's responsibility to ensure that the headers and request body
(if any) conform to the requirements of the request method. For example, if
using \fB\-method\fR \fIPOST\fR to send a POST with an empty request body, the
caller must also supply the option
-.QW "\-headers {Content-Length 0}" .
+.PP
+.CS
+\-headers {Content-Length 0}
+.CE
.RE
.TP
\fB\-myaddr\fR \fIaddress\fR
@@ -335,18 +452,26 @@ multiple interfaces are available.
.TP
\fB\-progress\fR \fIcallback\fR
.
-The \fIcallback\fR is made after each transfer of data from the URL.
-The callback gets three additional arguments: the \fItoken\fR from
+If the \fB\-progress\fR option is present,
+then the \fIcallback\fR is made after each transfer of data from the URL.
+The value of \fIcallback\fR is expanded, an additional three arguments are
+added, and the resulting command is evaluated.
+The three additional arguments are: the \fItoken\fR returned from
\fB::http::geturl\fR, the expected total size of the contents from the
-\fBContent-Length\fR meta-data, and the current number of bytes
-transferred so far. The expected total size may be unknown, in which
+\fBContent-Length\fR response header, and the current number of bytes
+transferred so far. The token is the name of a global array that is
+described in the \fBSTATE ARRAY\fR section. The expected total size may
+be unknown, in which
case zero is passed to the callback. Here is a template for the
progress callback:
.RS
.PP
.CS
proc httpProgress {token total current} {
- upvar #0 $token state
+ upvar 0 $token state
+ # Access state as a Tcl array defined in this proc
+ ...
+ return
}
.CE
.RE
@@ -390,20 +515,24 @@ This flag causes \fB::http::geturl\fR to do a POST request that passes the
data contained in \fIchannelID\fR to the server. The data contained in
\fIchannelID\fR must be an x-url-encoding
formatted query unless the \fB\-type\fR option below is used.
-If a Content-Length header is not specified via the \fB\-headers\fR options,
-\fB::http::geturl\fR attempts to determine the size of the post data
+If a \fBContent-Length\fR header is not specified via the \fB\-headers\fR
+options, \fB::http::geturl\fR attempts to determine the size of the post data
in order to create that header. If it is
unable to determine the size, it returns an error.
.TP
\fB\-queryprogress\fR \fIcallback\fR
.
-The \fIcallback\fR is made after each transfer of data to the URL
-(i.e. POST) and acts exactly like the \fB\-progress\fR option (the
-callback format is the same).
+If the \fB\-queryprogress\fR option is present,
+then the \fIcallback\fR is made after each transfer of data to the URL
+in a POST request (i.e. a call to \fB::http::geturl\fR with
+option \fB\-query\fR or \fB\-querychannel\fR) and acts exactly like
+the \fB\-progress\fR option (the callback format is the same).
.TP
\fB\-strict\fR \fIboolean\fR
.
-Whether to enforce RFC 3986 URL validation on the request. Default is 1.
+If true then the command will test that the URL complies with RFC 3986, i.e.
+that it has no characters that should be "x-url-encoded" (e.g. a space should
+be encoded to "%20"). Default value is 1.
.TP
\fB\-timeout\fR \fImilliseconds\fR
.
@@ -411,7 +540,8 @@ If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout
to occur after the specified number of milliseconds.
A timeout results in a call to \fB::http::reset\fR and to
the \fB\-command\fR callback, if specified.
-The return value of \fB::http::status\fR is \fBtimeout\fR
+The return value of \fB::http::status\fR (and the value of the \fIstatus\fR key
+in the dictionary returned by \fB::http::responseInfo\fR) is \fBtimeout\fR
after a timeout has occurred.
.TP
\fB\-type\fR \fImime-type\fR
@@ -423,10 +553,11 @@ POST operation.
\fB\-validate\fR \fIboolean\fR
.
If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD
-request. This request returns meta information about the URL, but the
-contents are not returned. The meta information is available in the
-\fBstate(meta) \fR variable after the transaction. See the
-\fBSTATE ARRAY\fR section for details.
+request. This server returns the same status line and response headers as it
+would for a HTTP GET request, but omits the response entity
+(the URL "contents"). The response headers are available after the
+transaction using command \fB::http::responseHeaders\fR or, for selected
+information, \fB::http::responseInfo\fR.
.RE
.TP
\fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...?
@@ -450,7 +581,7 @@ This sets the \fBstate(status)\fR value to \fIwhy\fR, which defaults to
.TP
\fB::http::wait\fR \fItoken\fR
.
-This is a convenience procedure that blocks and waits for the
+This command blocks and waits for the
transaction to complete. This only works in trusted code because it
uses \fBvwait\fR. Also, it is not useful for the case where
\fB::http::geturl\fR is called \fIwithout\fR the \fB\-command\fR option
@@ -458,54 +589,206 @@ because in this case the \fB::http::geturl\fR call does not return
until the HTTP transaction is complete, and thus there is nothing to
wait for.
.TP
-\fB::http::data\fR \fItoken\fR
-.
-This is a convenience procedure that returns the \fBbody\fR element
-(i.e., the URL data) of the state array.
-.TP
-\fB::http::error\fR \fItoken\fR
-.
-This is a convenience procedure that returns the \fBerror\fR element
-of the state array.
-.TP
\fB::http::status\fR \fItoken\fR
.
-This is a convenience procedure that returns the \fBstatus\fR element of
-the state array.
-.TP
-\fB::http::code\fR \fItoken\fR
-.
-This is a convenience procedure that returns the \fBhttp\fR element of the
-state array.
+This command returns a description of the status of the HTTP transaction.
+The return value is the empty string until the HTTP transaction is
+completed; after completion it has one of the values ok, eof, error,
+timeout, and reset. The meaning of these values is described in the
+section \fBERRORS\fR (below).
+.PP
+.RS
+The name "status" is not related to the terms "status line" and
+"status code" that are defined for a HTTP response.
+.RE
.TP
-\fB::http::ncode\fR \fItoken\fR
+\fB::http::size\fR \fItoken\fR
.
-This is a convenience procedure that returns just the numeric return
-code (200, 404, etc.) from the \fBhttp\fR element of the state array.
+This command returns the number of bytes
+received so far from the URL in the \fB::http::geturl\fR call.
.TP
-\fB::http::size\fR \fItoken\fR
+\fB::http::error\fR \fItoken\fR
.
-This is a convenience procedure that returns the \fBcurrentsize\fR
-element of the state array, which represents the number of bytes
-received from the URL in the \fB::http::geturl\fR call.
+This command returns the error information if the HTTP transaction failed,
+or the empty string if there was no error. The information is a Tcl list of
+the error message, stack trace, and error code.
.TP
-\fB::http::meta\fR \fItoken\fR
+\fB::http::postError\fR \fItoken\fR
.
-This is a convenience procedure that returns the \fBmeta\fR
-element of the state array which contains the HTTP response
-headers. See below for an explanation of this element.
+A POST request is a call to \fB::http::geturl\fR with either
+the \fB\-query\fR or \fB\-querychannel\fR option.
+The \fB::http::postError\fR command returns the error information generated
+when a HTTP POST request sends its request-body to the server; or the empty
+string if there was no error. The information is a Tcl list of the error
+message, stack trace, and error code. When this type of error occurs,
+the \fB::http::geturl\fR command continues the transaction and attempts to
+receive a response from the server.
.TP
\fB::http::cleanup\fR \fItoken\fR
.
This procedure cleans up the state associated with the connection
identified by \fItoken\fR. After this call, the procedures
-like \fB::http::data\fR cannot be used to get information
+like \fB::http::responseBody\fR cannot be used to get information
about the operation. It is \fIstrongly\fR recommended that you call
this function after you are done with a given HTTP request. Not doing
so will result in memory not being freed, and if your app calls
\fB::http::geturl\fR enough times, the memory leak could cause a
performance hit...or worse.
.TP
+\fB::http::requestLine\fR \fItoken\fR
+.
+This command returns the "request line" sent to the server.
+The "request line" is the first line of a HTTP client request, and has three
+elements separated by spaces: the HTTP method, the URL relative to the server,
+and the HTTP version. Examples:
+.PP
+.RS
+GET / HTTP/1.1
+GET /introduction.html?subject=plumbing HTTP/1.1
+POST /forms/order.html HTTP/1.1
+.RE
+.TP
+\fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR?
+.
+This command returns the HTTP request header names and values, in the
+order that they were sent to the server, as a Tcl list of the form
+?name value ...? Header names are case-insensitive and are converted to lower
+case. The return value is not a \fBdict\fR because some header names may occur
+more than once. If one argument is supplied, all request headers
+are returned. If two arguments are supplied, the
+second provides the value of a header name. Only headers with the requested
+name (converted to lower case) are returned. If no such headers are found,
+an empty list is returned.
+.TP
+\fB::http::requestHeaderValue\fR \fItoken\fR \fIheaderName\fR
+.
+This command returns the value of the HTTP request header named
+\fIheaderName\fR. Header names are case-insensitive and are converted to
+lower case. If no such header exists, the return value is the empty string.
+If there are multiple headers named \fIheaderName\fR, the result is obtained
+by joining the individual values with the string ", " (comma and space),
+preserving their order.
+.TP
+\fB::http::responseLine\fR \fItoken\fR
+.
+This command returns the first line of the server response: the
+HTTP "status line". The "status line" has three
+elements separated by spaces: the HTTP version, a three-digit numerical
+"status code", and a "reason phrase". Only the reason phrase may contain
+spaces. Examples:
+.PP
+.RS
+HTTP/1.1 200 OK
+HTTP/1.0 404 Not Found
+.RE
+.RS
+The "status code" is a three-digit number in the range 100 to 599.
+A value of 200 is the normal return from a GET request, and its matching
+"reason phrase" is "OK". Codes beginning with 4 or 5 indicate errors.
+Codes beginning with 3 are redirection errors. In this case the
+\fBLocation\fR response header specifies a new URL that contains the
+requested information.
+.PP
+The "reason phrase" is a textual description of the "status code": it may
+vary from server to server,
+and can be changed without affecting the HTTP protocol. The recommended
+values (RFC 7231 and IANA assignments) for each code are provided by the
+command \fB::http::reasonPhrase\fR.
+.RE
+.TP
+\fB::http::responseCode\fR \fItoken\fR
+.
+This command returns the "status code" (200, 404, etc.) of the server
+"status line". If a three-digit code cannot be found, the full status
+line is returned. See command \fB::http::responseLine\fR for more information
+on the "status line".
+.TP
+\fB::http::reasonPhrase\fR \fIcode\fR
+.
+This command returns the IANA recommended "reason phrase" for a particular
+"status code" returned by a HTTP server. The argument \fIcode\fR is a valid
+status code, and therefore is an integer in the range 100 to 599 inclusive.
+For numbers in this range with no assigned meaning, the command returns the
+value "Unassigned". Several status codes are used only in response to the
+methods defined by HTTP extensions such as WebDAV, and not in response to a
+HEAD, GET, or POST request method.
+.PP
+.RS
+The "reason phrase" returned by a HTTP server may differ from the recommended
+value, without affecting the HTTP protocol. The value returned by
+\fB::http::geturl\fR can be obtained by calling either command
+\fB::http::responseLine\fR (which returns the full status line) or command
+\fB::http::responseInfo\fR (which returns a dictionary, with
+the "reason phrase" stored in key \fIreasonPhrase\fR).
+.PP
+A registry of valid status codes is maintained at
+https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
+.RE
+.TP
+\fB::http::responseHeaders\fR \fItoken\fR ?\fIheaderName\fR?
+.
+The response from a HTTP server includes metadata headers that describe the
+response body and the transaction itself.
+This command returns the HTTP response header names and values, in the
+order that they were received from the server, as a Tcl list of the form
+?name value ...? Header names are case-insensitive and are converted to lower
+case. The return value is not a \fBdict\fR because some header names may occur
+more than once, notably \fBSet-Cookie\fR. If the second argument is not
+supplied, all response headers are returned. If the second argument is
+supplied, it provides the value of a header name. Only headers with the
+requested name (converted to lower case) are returned. If no such headers
+are found, an empty list is returned. See section \fBMETADATA\fR for more
+information.
+.TP
+\fB::http::responseHeaderValue\fR \fItoken\fR \fIheaderName\fR
+.
+This command returns the value of the HTTP response header named
+\fIheaderName\fR. Header names are case-insensitive and are converted to
+lower case. If no such header exists, the return value is the empty string.
+If there are multiple headers named \fIheaderName\fR, the result is obtained
+by joining the individual values with the string ", " (comma and space),
+preserving their order. Multiple headers with the same name may be processed
+in this manner, except \fBSet-Cookie\fR which does not conform to the
+comma-separated-list syntax and cannot be combined into a single value.
+Each \fBSet-Cookie\fR header must be treated individually, e.g. by processing
+the return value of \fB::http::responseHeaders\fR \fItoken\fR \fBSet-Cookie\fR.
+.TP
+\fB::http::responseInfo\fR \fItoken\fR
+.
+This command returns a \fBdict\fR of selected response metadata that are
+essential for identifying a successful transaction and making use of the
+response, along with other metadata that are informational. The keys of
+the \fBdict\fR are \fIstage\fR, \fIstatus\fR, \fIresponseCode\fR,
+\fIreasonPhrase\fR, \fIcontentType\fR, \fIbinary\fR, \fIredirection\fR,
+\fIupgrade\fR, \fIerror\fR, \fIpostError\fR, \fImethod\fR, \fIcharset\fR,
+\fIcompression\fR, \fIhttpRequest\fR, \fIhttpResponse\fR, \fIurl\fR,
+\fIconnectionRequest\fR, \fIconnectionResponse\fR, \fIconnectionActual\fR,
+\fItransferEncoding\fR, \fItotalPost\fR, \fIcurrentPost\fR, \fItotalSize\fR,
+and \fIcurrentSize\fR. The meaning of these keys is described in the
+section \fBMETADATA\fR below.
+.RS
+.PP
+It is always worth checking the value of \fIbinary\fR after a HTTP transaction,
+to determine whether a misconfigured server has caused http to interpret a
+text resource as a binary, or vice versa.
+.PP
+After a POST transaction, check the value of \fIpostError\fR to verify that
+the request body was uploaded without error.
+.RE
+.TP
+\fB::http::responseBody\fR \fItoken\fR
+.
+This command returns the entity sent by the HTTP server (unless
+\fI-channel\fR was used, in which case the entity was delivered to the
+channel, and the command returns the empty string).
+.RS
+.PP
+Other terms for
+"entity", with varying precision, include "representation of resource",
+"resource", "response body after decoding", "payload",
+"message body after decoding", "content(s)", and "file".
+.RE
+.TP
\fB::http::register\fR \fIproto port command\fR
.
This procedure allows one to provide custom HTTP transport types
@@ -541,18 +824,34 @@ registered via \fB::http::register\fR, returning a two-item list of
the default port and handler command that was previously installed
(via \fB::http::register\fR) if there was such a handler, and an error if
there was no such handler.
+.TP
+\fB::http::code\fR \fItoken\fR
+.
+An alternative name for the command \fB::http::responseLine\fR
+.TP
+\fB::http::data\fR \fItoken\fR
+.
+An alternative name for the command \fB::http::responseBody\fR.
+.TP
+\fB::http::meta\fR \fItoken\fR ?\fIheaderName\fR?
+.
+An alternative name for the command \fB::http::responseHeaders\fR
+.TP
+\fB::http::ncode\fR \fItoken\fR
+.
+An alternative name for the command \fB::http::responseCode\fR
.SH ERRORS
The \fB::http::geturl\fR procedure will raise errors in the following cases:
invalid command line options,
-an invalid URL,
-a URL on a non-existent host,
-or a URL at a bad port on an existing host.
+or an invalid URL.
These errors mean that it
cannot even start the network transaction.
-It will also raise an error if it gets an I/O error while
-writing out the HTTP request header.
For synchronous \fB::http::geturl\fR calls (where \fB\-command\fR is
-not specified), it will raise an error if it gets an I/O error while
+not specified), it will raise an error if
+the URL is on a non-existent host
+or at a bad port on an existing host.
+It will also raise an error for any I/O errors while
+writing out the HTTP request line and headers, or
reading the HTTP reply headers or data. Because \fB::http::geturl\fR
does not return a token in these cases, it does all the required
cleanup and there is no issue of your app having to call
@@ -564,13 +863,12 @@ HTTP reply headers or data, no exception is thrown. This is because
after writing the HTTP headers, \fB::http::geturl\fR returns, and the
rest of the HTTP transaction occurs in the background. The command
callback can check if any error occurred during the read by calling
-\fB::http::status\fR to check the status and if its \fIerror\fR,
-calling \fB::http::error\fR to get the error message.
+\fB::http::responseInfo\fR to check the transaction status.
.PP
Alternatively, if the main program flow reaches a point where it needs
to know the result of the asynchronous HTTP request, it can call
\fB::http::wait\fR and then check status and error, just as the
-callback does.
+synchronous call does.
.PP
The \fB::http::geturl\fR command runs the \fB\-command\fR, \fB\-handler\fR,
and \fB\-proxyfilter\fR callbacks inside a \fBcatch\fR command. Therefore
@@ -584,15 +882,17 @@ In any case, you must still call
\fB::http::cleanup\fR to delete the state array when you are done.
.PP
There are other possible results of the HTTP transaction
-determined by examining the status from \fB::http::status\fR.
+determined by examining the status from \fB::http::status\fR (or the value
+of the \fIstatus\fR key in the dictionary returned
+by \fB::http::responseInfo\fR).
These are described below.
.TP
\fBok\fR
.
If the HTTP transaction completes entirely, then status will be \fBok\fR.
-However, you should still check the \fB::http::code\fR value to get
-the HTTP status. The \fB::http::ncode\fR procedure provides just
-the numeric error (e.g., 200, 404 or 500) while the \fB::http::code\fR
+However, you should still check the \fB::http::responseLine\fR value to get
+the HTTP status. The \fB::http::responseCode\fR procedure provides just
+the numeric error (e.g., 200, 404 or 500) while the \fB::http::responseLine\fR
procedure returns a value like
.QW "HTTP 404 File not found" .
.TP
@@ -603,147 +903,447 @@ is raised, but the status of the transaction will be \fBeof\fR.
.TP
\fBerror\fR
.
-The error message will also be stored in the \fBerror\fR status
-array element, accessible via \fB::http::error\fR.
+The error message, stack trace, and error code are accessible
+via \fB::http::error\fR. The error message is also provided by the value of
+the \fIerror\fR key in the dictionary returned by \fB::http::responseInfo\fR.
.TP
\fBtimeout\fR
.
-A timeout occurred before the transaction could complete
+A timeout occurred before the transaction could complete.
.TP
\fBreset\fR
.
-user-reset
-.PP
-Another error possibility is that \fB::http::geturl\fR is unable to
-write all the post query data to the server before the server
-responds and closes the socket.
-The error message is saved in the \fBposterror\fR status array
-element and then \fB::http::geturl\fR attempts to complete the
-transaction.
-If it can read the server's response
-it will end up with an \fBok\fR status, otherwise it will have
-an \fBeof\fR status.
+The user has called \fB::http::reset\fR.
+.TP
+\fB""\fR
+.
+(empty string) The transaction has not yet finished.
+.PP
+Another error possibility is that \fB::http::geturl\fR failed to
+write the whole of the POST request body (\fB-query\fR or \fB-querychannel\fR
+data) to the server. \fB::http::geturl\fR stores the error message for later
+retrieval by the \fB::http::postError\fR or \fB::http::responseInfo\fR
+commands, and then attempts to complete the transaction.
+If it can read the server's response the status will be \fBok\fR, but it is
+important to call \fB::http::postError\fR or \fB::http::responseInfo\fR after
+every POST to check that the data was sent in full.
+If the server has closed the connection the status will be \fBeof\fR.
+.SH "METADATA"
+.PP
+.SS "MOST USEFUL METADATA"
+When a HTTP server responds to a request, it supplies not only the entity
+requested, but also metadata. This is provided by the first line (the
+"status line") of the response, and by a number of HTTP headers. Further
+metadata relates to how \fB::http::geturl\fR has processed the response
+from the server.
+.PP
+The most important metadata can be accessed with the command
+\fB::http::responseInfo\fR.
+This command returns a \fBdict\fR of metadata that are essential for
+identifying a successful transaction and making use of the response,
+along with other metadata that are informational. The keys of
+the \fBdict\fR are:
+.PP
+.RS
+.RS
+\fB===== Essential Values =====\fR
+.RE
+.RE
+.TP
+\fBstage\fR
+.
+This value, set by \fB::http::geturl\fR, describes the stage that the
+transaction has reached. Values, in order of the transaction lifecycle,
+are: "created", "connecting", "header", "body", and "complete". The
+other \fBdict\fR keys will not be available until the value of \fBstage\fR
+is "body" or "complete". The key \fBcurrentSize\fR has its final value only
+when \fBstage\fR is "complete".
+.TP
+\fBstatus\fR
+.
+This value, set by \fB::http::geturl\fR, is "ok" for a successful transaction;
+"eof", "error", "timeout", or "reset" for an unsuccessful transaction; or ""
+if the transaction is still in progress. The value is the same as that
+returned by command \fB::http::status\fR. The meaning of these values is
+described in the section \fBERRORS\fR (above).
+.TP
+\fBresponseCode\fR
+.
+The "HTTP status code" sent by the server in the first line (the "status line")
+of the response. If the value cannot be extracted from the status line, the
+full status line is returned.
+.TP
+\fBreasonPhrase\fR
+.
+The "reason phrase" sent by the server as a description of the HTTP status code.
+If the value cannot be extracted from the status line, the full status
+line is returned.
+.TP
+\fBcontentType\fR
+.
+The value of the \fBContent-Type\fR response header or, if the header was not
+supplied, the default value "application/octet-stream".
+.TP
+\fBbinary\fR
+.
+This boolean value, set by \fB::http::geturl\fR, describes how the command
+has interpreted the entity returned by the server (after decoding any
+compression specified by the \fBContent-Encoding\fR response header).
+This decoded entity is accessible as the return value of the
+command \fB::http::responseBody\fR.
+.PP
+.RS
+The value is \fBtrue\fR if http has interpreted the decoded entity as binary.
+The value returned by \fB::http::responseBody\fR is a Tcl binary string.
+This is a suitable format for image data, zip files, etc.
+\fB::http::geturl\fR chooses this value if the user has requested a binary
+interpretation by passing the option \fI\-binary\fR to the command, or if the
+server has supplied a binary content type in a \fBContent-Type\fR response
+header, or if the server has not supplied any \fBContent-Type\fR header.
+.PP
+The value is \fBfalse\fR in other cases, and this means that http has
+interpreted the decoded entity as text. The text has been converted, from the
+character set notified by the server, into Tcl's internal Unicode format;
+the value returned by \fB::http::responseBody\fR is an ordinary Tcl string.
+.PP
+It is always worth checking the value of "binary" after a HTTP transaction,
+to determine whether a misconfigured server has caused http to interpret a
+text resource as a binary, or vice versa.
+.RE
+.TP
+\fBredirection\fR
+.
+The URL that is the redirection target. The value is that of the \fBLocation\fR
+response header. This header is sent when a response has status code
+3XX (redirection).
+.TP
+\fBupgrade\fR
+.
+If not empty, the value indicates the protocol(s) to which the server will
+switch after completion of this transaction, while continuing to use the
+same connection. When the server intends to switch protocols, it will also
+send the value "101" as the status code (the \fBresponseCode\fR key), and the
+word "upgrade" as an element of the \fBConnection\fR response header (the
+\fBconnectionResponse\fR key), and it will not send a response body.
+See the section \fBPROTOCOL UPGRADES\fR for more information.
+.TP
+\fBerror\fR
+.
+The error message, if there is one. Further information, including a stack
+trace and error code, are available from command \fB::http::error\fR.
+.TP
+\fBpostError\fR
+.
+The error message (if any) generated when a HTTP POST request sends its
+request-body to the server. Further information, including a stack trace
+and error code, are available from command \fB::http::postError\fR. A POST
+transaction may appear complete, according to the
+keys \fBstage\fR, \fBstatus\fR, and \fBresponseCode\fR, but it is important
+to check this \fBpostError\fR key in case an error occurred when uploading
+the request-body.
+.PP
+.RS
+.RS
+\fB===== Informational Values =====\fR
+.RE
+.RE
+.TP
+\fBmethod\fR
+.
+The HTTP method used in the request.
+.TP
+\fBcharset\fR
+.
+The value of the charset attribute of the \fBContent-Type\fR response header.
+The charset value is used only for a text resource. If the server did not
+specify a charset, the value defaults to that of the
+variable \fB::http::defaultCharset\fR, which unless it has been deliberately
+modified by the caller is \fBiso8859-1\fR. Incoming text data is automatically
+converted from the character set defined by \fBcharset\fR to Tcl's internal
+Unicode representation, i.e. to a Tcl string.
+.TP
+\fBcompression\fR
+.
+A copy of the \fBContent-Encoding\fR response-header value.
+.TP
+\fBhttpRequest\fR
+.
+The version of HTTP specified in the request (i.e. sent in the request line).
+The value is that of the option \fB\-protocol\fR supplied
+to \fB::http::geturl\fR (default value "1.1"), unless the command reduced the
+value to "1.0" because it was passed the \fB\-handler\fR option.
+.TP
+\fBhttpResponse\fR
+.
+The version of HTTP used by the server (obtained from the response
+"status line"). The server uses this version of HTTP in its response, but
+ensures that this response is compatible with the HTTP version specified in the
+client's request. If the value cannot be extracted from the status line, the
+full status line is returned.
+.TP
+\fBurl\fR
+.
+The requested URL, typically the URL supplied as an argument
+to \fB::http::geturl\fR but without its "fragment" (the final part of the URL
+beginning with "#").
+.TP
+\fBconnectionRequest\fR
+.
+The value, if any, sent to the server in \fBConnection\fR request header(s).
+.TP
+\fBconnectionResponse\fR
+.
+The value, if any, received from the server in \fBConnection\fR response
+header(s).
+.TP
+\fBconnectionActual\fR
+.
+This value, set by \fB::http::geturl\fR, reports whether the connection was
+closed after the transaction (value "close"), or left open (value "keep-alive").
+.TP
+\fBtransferEncoding\fR
+.
+The value of the Transfer-Encoding response header, if it is present.
+The value is either "chunked" (indicating HTTP/1.1 "chunked encoding") or
+the empty string.
+.TP
+\fBtotalPost\fR
+.
+The total length of the request body in a POST request.
+.TP
+\fBcurrentPost\fR
+.
+The number of bytes of the POST request body sent to the server so far.
+The value is the same as that returned by command \fB::http::size\fR.
+.TP
+\fBtotalSize\fR
+.
+A copy of the \fBContent-Length\fR response-header value.
+The number of bytes specified in a \fBContent-Length\fR header, if one
+was sent. If none was sent, the value is 0. A correctly configured server
+omits this header if the transfer-encoding is "chunked", or (for older
+servers) if the server closes the connection when it reaches the end of
+the resource.
+.TP
+\fBcurrentSize\fR
+.
+The number of bytes fetched from the server so far.
+.PP
+.SS "MORE METADATA"
+The dictionary returned by \fB::http::responseInfo\fR is the most useful
+subset of the available metadata. Other metadata include:
+.PP
+1. The full "status line" of the response, available as the return value
+of command \fB::http::responseLine\fR.
+.PP
+2. The full response headers, available as the return value of
+command \fB::http::responseHeaders\fR. This return value is a list of the
+response-header names and values, in the order that they were received from
+the server.
+.PP
+The return value is not a \fBdict\fR because some header names may
+occur more than once, notably \fBSet-Cookie\fR. If the value is read
+into a \fBdict\fR or into an array (using array set), only the last header
+with each name will be preserved.
+.PP
+.RS
+Some of the header names (metadata keys) are listed below, but the HTTP
+standard defines several more, and servers are free to add their own.
+When a dictionary key is mentioned below, this refers to the \fBdict\fR
+value returned by command \fB::http::responseInfo\fR.
+.TP
+\fBContent-Type\fR
+.
+The content type of the URL contents. Examples include \fBtext/html\fR,
+\fBimage/gif,\fR \fBapplication/postscript\fR and
+\fBapplication/x-tcl\fR. Text values typically specify a character set, e.g.
+\fBtext/html; charset=UTF-8\fR. Dictionary key \fIcontentType\fR.
+.TP
+\fBContent-Length\fR
+.
+The advertised size in bytes of the contents, available as dictionary
+key \fItotalSize\fR. The actual number of bytes read by \fB::http::geturl\fR
+so far is available as dictionary key \fBcurrentSize\fR.
+.TP
+\fBContent-Encoding\fR
+.
+The compression algorithm used for the contents.
+Examples include \fBgzip\fR, \fBdeflate\fR.
+Dictionary key \fIcontent\fR.
+.TP
+\fBLocation\fR
+.
+This header is sent when a response has status code 3XX (redirection).
+It provides the URL that is the redirection target.
+Dictionary key \fIredirection\fR.
+.TP
+\fBSet-Cookie\fR
+.
+This header is sent to offer a cookie to the client. Cookie management is
+done by the \fB::http::config\fR option \fI\-cookiejar\fR, and so
+the \fBSet-Cookie\fR headers need not be parsed by user scripts.
+See section \fBCOOKIE JAR PROTOCOL\fR.
+.TP
+\fBConnection\fR
+.
+The value can be supplied as a comma-separated list, or by multiple headers.
+The list often has only one element, either "close" or "keep-alive".
+The value "upgrade" indicates a successful upgrade request and is typically
+combined with the status code 101, an \fBUpgrade\fR response header, and no
+response body. Dictionary key \fIconnectionResponse\fR.
+.TP
+\fBUpgrade\fR
+.
+The value indicates the protocol(s) to which the server will switch
+immediately after the empty line that terminates the 101 response headers.
+Dictionary key \fIupgrade\fR.
+.RE
+.PP
+.SS "EVEN MORE METADATA"
+.PP
+1. Details of the HTTP request. The request is determined by the options
+supplied to \fB::http::geturl\fR and \fB::http::config\fR. However, it is
+sometimes helpful to examine what \fB::http::geturl\fR actually sent to the
+server, and this information is available through
+commands \fB::http::requestHeaders\fR and \fB::http::requestLine\fR.
+.PP
+2. The state array: the internal variables of \fB::http::geturl\fR.
+It may sometimes be helpful to examine this array.
+Details are given in the next section.
.SH "STATE ARRAY"
-The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to
-get to the state of the HTTP transaction in the form of a Tcl array.
-Use this construct to create an easy-to-use array variable:
+The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used
+as an argument to other \fB::http::*\fR commands, which examine and manage
+the state of the HTTP transaction. For most purposes these commands are
+sufficient. The \fItoken\fR can also be used to access
+the internal state of the transaction, which is stored in a Tcl array.
+This facility is most useful when writing callback commands for the
+options \fB\-command\fR, \fB\-handler\fR, \fB\-progress\fR,
+or \fB\-queryprogress\fR.
+Use the following command inside the proc to define an easy-to-use
+array \fIstate\fR as a local variable within the proc
.PP
.CS
-upvar #0 $token state
+upvar 0 $token state
.CE
.PP
Once the data associated with the URL is no longer needed, the state
array should be unset to free up storage.
The \fB::http::cleanup\fR procedure is provided for that purpose.
-The following elements of
-the array are supported:
+.PP
+The following elements of the array are supported, and are the origin of the
+values returned by commands as described below. When a dictionary key is
+mentioned below, this refers to the \fBdict\fR value returned by
+command \fB::http::responseInfo\fR.
.RS
.TP
\fBbinary\fR
.
-This is boolean \fBtrue\fR if (after decoding any compression specified
-by the
-.QW "Content-Encoding"
-response header) the HTTP response is binary. It is boolean \fBfalse\fR
-if the HTTP response is text.
+For dictionary key \fIbinary\fR.
.TP
\fBbody\fR
.
-The contents of the URL. This will be empty if the \fB\-channel\fR
-option has been specified. This value is returned by the \fB::http::data\fR
-command.
+For command \fB::http::responseBody\fR.
.TP
\fBcharset\fR
.
-The value of the charset attribute from the \fBContent-Type\fR meta-data
-value. If none was specified, this defaults to the RFC standard
-\fBiso8859-1\fR, or the value of \fB$::http::defaultCharset\fR. Incoming
-text data will be automatically converted from this charset to utf-8.
+For dictionary key \fIcharset\fR.
.TP
\fBcoding\fR
.
-A copy of the \fBContent-Encoding\fR meta-data value.
+For dictionary key \fIcompression\fR.
+.TP
+\fBconnection\fR
+.
+For dictionary key \fIconnectionActual\fR.
.TP
\fBcurrentsize\fR
.
-The current number of bytes fetched from the URL.
-This value is returned by the \fB::http::size\fR command.
+For command \fB::http::size\fR; and for dictionary key \fIcurrentSize\fR.
.TP
\fBerror\fR
.
-If defined, this is the error string seen when the HTTP transaction
-was aborted.
+For command \fB::http::error\fR; part is used in dictionary key \fIerror\fR.
.TP
\fBhttp\fR
.
-The HTTP status reply from the server. This value
-is returned by the \fB::http::code\fR command. The format of this value is:
-.RS
-.PP
-.CS
-\fIHTTP/1.1 code string\fR
-.CE
-.PP
-The \fIcode\fR is a three-digit number defined in the HTTP standard.
-A code of 200 is OK. Codes beginning with 4 or 5 indicate errors.
-Codes beginning with 3 are redirection errors. In this case the
-\fBLocation\fR meta-data specifies a new URL that contains the
-requested information.
-.RE
+For command \fB::http::responseLine\fR.
+.TP
+\fBhttpResponse\fR
+.
+For dictionary key \fIhttpResponse\fR.
.TP
\fBmeta\fR
.
-The HTTP protocol returns meta-data that describes the URL contents.
-The \fBmeta\fR element of the state array is a list of the keys and
-values of the meta-data. This is in a format useful for initializing
-an array that just contains the meta-data:
-.RS
-.PP
-.CS
-array set meta $state(meta)
-.CE
-.PP
-Some of the meta-data keys are listed below, but the HTTP standard defines
-more, and servers are free to add their own.
+For command \fB::http::responseHeaders\fR. Further discussion above in the
+section \fBMORE METADATA\fR.
.TP
-\fBContent-Type\fR
+\fBmethod\fR
.
-The type of the URL contents. Examples include \fBtext/html\fR,
-\fBimage/gif,\fR \fBapplication/postscript\fR and
-\fBapplication/x-tcl\fR.
+For dictionary key \fImethod\fR.
.TP
-\fBContent-Length\fR
+\fBposterror\fR
.
-The advertised size of the contents. The actual size obtained by
-\fB::http::geturl\fR is available as \fBstate(currentsize)\fR.
+For dictionary key \fIpostError\fR.
.TP
-\fBLocation\fR
+\fBpostErrorFull\fR
.
-An alternate URL that contains the requested data.
-.RE
+For command \fB::http::postError\fR.
.TP
-\fBposterror\fR
+\fB\-protocol\fR
.
-The error, if any, that occurred while writing
-the post query data to the server.
+For dictionary key \fIhttpRequest\fR.
+.TP
+\fBquerylength\fR
+.
+For dictionary key \fItotalPost\fR.
+.TP
+\fBqueryoffset\fR
+.
+For dictionary key \fIcurrentPost\fR.
+.TP
+\fBreasonPhrase\fR
+.
+For dictionary key \fIreasonPhrase\fR.
+.TP
+\fBrequestHeaders\fR
+.
+For command \fB::http::requestHeaders\fR.
+.TP
+\fBrequestLine\fR
+.
+For command \fB::http::requestLine\fR.
+.TP
+\fBresponseCode\fR
+.
+For dictionary key \fIresponseCode\fR.
+.TP
+\fBstate\fR
+.
+For dictionary key \fIstage\fR.
.TP
\fBstatus\fR
.
-See description in the chapter \fBERRORS\fR above for a
-list and description of \fBstatus\fR.
-During the transaction this value is the empty string.
+For command \fB::http::status\fR; and for dictionary key \fIstatus\fR.
.TP
\fBtotalsize\fR
.
-A copy of the \fBContent-Length\fR meta-data value.
+For dictionary key \fItotalSize\fR.
+.TP
+\fBtransfer\fR
+.
+For dictionary key \fItransferEncoding\fR.
.TP
\fBtype\fR
.
-A copy of the \fBContent-Type\fR meta-data value.
+For dictionary key \fIcontentType\fR.
+.TP
+\fBupgrade\fR
+.
+For dictionary key \fIupgrade\fR.
.TP
\fBurl\fR
.
-The requested URL.
+For dictionary key \fIurl\fR.
.RE
.SH "PERSISTENT CONNECTIONS"
.PP
@@ -842,28 +1442,133 @@ that fails because it uses a persistent connection that the server has
half-closed (an
.QW "asynchronous close event" ).
Subsequent GET and HEAD requests in a failed pipeline will also be retried.
-\fIThe \-repost option should be used only if the application understands
+\fIThe \fB\-repost\fI option should be used only if the application understands
that the retry is appropriate\fR - specifically, the application must know
that if the failed POST successfully modified the state of the server, a repeat
POST would have no adverse effect.
+.VS TIP406
+.SH "COOKIE JAR PROTOCOL"
+.PP
+Cookies are short key-value pairs used to implement sessions within the
+otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not
+implement the Cookie2 protocol as that is rarely seen in the wild.)
+.PP
+Cookie storage managment commands \(em
+.QW "cookie jars"
+\(em must support these subcommands which form the HTTP cookie storage
+management protocol. Note that \fIcookieJar\fR below does not have to be a
+command name; it is properly a command prefix (a Tcl list of words that will
+be expanded in place) and admits many possible implementations.
+.PP
+Though not formally part of the protocol, it is expected that particular
+values of \fIcookieJar\fR will correspond to sessions; it is up to the caller
+of \fB::http::config\fR to decide what session applies and to manage the
+deletion of said sessions when they are no longer desired (which should be
+when they not configured as the current cookie jar).
+.TP
+\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR
+.
+This command asks the cookie jar what cookies should be supplied for a
+particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or
+\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR
+argument to \fB::http::geturl\fR) and return a list of cookie keys and values
+that describe the cookies to supply to the remote host. The list must have an
+even number of elements.
+.RS
+.PP
+There should only ever be at most one cookie with a particular key for any
+request (typically the one with the most specific \fIhost\fR/domain match and
+most specific \fIrequestPath\fR/path match), but there may be many cookies
+with different names in any request.
+.RE
+.TP
+\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR
+.
+This command asks the cookie jar to store a particular cookie that was
+returned by a request; the result of this command is ignored. The cookie
+(which will have been parsed by the http package) is described by a
+dictionary, \fIcookieDictionary\fR, that may have the following keys:
+.RS
+.TP
+\fBdomain\fR
+.
+This is always present. Its value describes the domain hostname \fIor
+prefix\fR that the cookie should be returned for. The checking of the domain
+against the origin (below) should be careful since sites that issue cookies
+should only do so for domains related to themselves. Cookies that do not obey
+a relevant origin matching rule should be ignored.
+.TP
+\fBexpires\fR
+.
+This is optional. If present, the cookie is intended to be a persistent cookie
+and the value of the option is the Tcl timestamp (in seconds from the same
+base as \fBclock seconds\fR) of when the cookie expires (which may be in the
+past, which should result in the cookie being deleted immediately). If absent,
+the cookie is intended to be a session cookie that should be not persisted
+beyond the lifetime of the cookie jar.
+.TP
+\fBhostonly\fR
+.
+This is always present. Its value is a boolean that describes whether the
+cookie is a single host cookie (true) or a domain-level cookie (false).
+.TP
+\fBhttponly\fR
+.
+This is always present. Its value is a boolean that is true when the site
+wishes the cookie to only ever be used with HTTP (or HTTPS) traffic.
+.TP
+\fBkey\fR
+.
+This is always present. Its value is the \fIkey\fR of the cookie, which is
+part of the information that must be return when sending this cookie back in a
+future request.
+.TP
+\fBorigin\fR
+.
+This is always present. Its value describes where the http package believes it
+received the cookie from, which may be useful for checking whether the
+cookie's domain is valid.
+.TP
+\fBpath\fR
+.
+This is always present. Its value describes the path prefix of requests to the
+cookie domain where the cookie should be returned.
+.TP
+\fBsecure\fR
+.
+This is always present. Its value is a boolean that is true when the cookie
+should only used on requests sent over secure channels (typically HTTPS).
+.TP
+\fBvalue\fR
+.
+This is always present. Its value is the value of the cookie, which is part of
+the information that must be return when sending this cookie back in a future
+request.
+.PP
+Other keys may always be ignored; they have no meaning in this protocol.
+.RE
+.VE TIP406
.SH "PROTOCOL UPGRADES"
.PP
-The HTTP/1.1 \fBConnection\fR and \fBUpgrade\fR client headers inform the server
-that the client wishes to change the protocol used over the existing connection
-(RFC 7230). This mechanism can be used to request a WebSocket (RFC 6455), a
+The HTTP/1.1 \fBConnection\fR and \fBUpgrade\fR request headers inform the
+server that the client wishes to change the protocol used over the existing
+connection (RFC 7230).
+This mechanism can be used to request a WebSocket (RFC 6455), a
higher version of the HTTP protocol (HTTP 2), or TLS encryption. If the
server accepts the upgrade request, its response code will be 101.
.PP
-To request a protocol upgrade when calling \fBhttp::geturl\fR, the \fB\-headers\fR
-option must supply appropriate values for \fBConnection\fR and \fBUpgrade\fR, and
+To request a protocol upgrade when calling \fBhttp::geturl\fR,
+the \fB\-headers\fR option must supply appropriate values for \fBConnection\fR
+and \fBUpgrade\fR, and
the \fB\-command\fR option must supply a command that implements the requested
protocol and can also handle the server response if the server refuses the
protocol upgrade. For upgrade requests \fBhttp::geturl\fR ignores the value of
option \fB\-keepalive\fR, and always uses the value \fB0\fR so that the upgrade
-request is not made over a connection that is intended for multiple HTTP requests.
+request is not made over a connection that is intended for multiple HTTP
+requests.
.PP
-The Tcllib library \fBwebsocket\fR implements WebSockets, and makes the necessary
-calls to commands in the \fBhttp\fR package.
+The Tcllib library \fBwebsocket\fR implements WebSockets, and makes the
+necessary calls to commands in the \fBhttp\fR package.
.PP
There is currently no native Tcl client library for HTTP/2.
.PP
@@ -874,16 +1579,59 @@ protocols such as Internet Printing Protocol (IPP) that are built on top of
traffic.
.PP
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.
+\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 \fI\-async\fR 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 \fI\-threadlevel\fR and the availability
+of package Thread.
+.PP
+.SS "WITH TLS (HTTPS)"
+.PP
+The same \fI\-threadlevel\fR 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 \fI\-threadlevel\fR values only if the script runs in the main
+interpreter. A child interpreter must use \fI\-threadlevel 0\fR unless the
+parent interpreter has provided alternative facilities. The main parent
+interpreter may grant full \fI\-threadlevel\fR 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.
+progress meter, and prints the response headers associated with the URL.
.PP
.CS
proc httpcopy { url file {chunk 4096} } {
@@ -895,7 +1643,7 @@ proc httpcopy { url file {chunk 4096} } {
# This ends the line started by httpCopyProgress
puts stderr ""
- upvar #0 $token state
+ upvar 0 $token state
set max 0
foreach {name value} $state(meta) {
if {[string length $name] > $max} {
diff --git a/doc/idna.n b/doc/idna.n
new file mode 100644
index 0000000..744bf67
--- /dev/null
+++ b/doc/idna.n
@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 2014-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.
+'\"
+.TH "idna" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::idna \- Support for normalization of Internationalized Domain Names
+.SH SYNOPSIS
+.nf
+package require tcl::idna 1.0
+
+\fBtcl::idna decode\fR \fIhostname\fR
+\fBtcl::idna encode\fR \fIhostname\fR
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna version\fR
+.fi
+.SH DESCRIPTION
+This package provides an implementation of the punycode scheme used in
+Internationalised Domain Names, and some access commands. (See RFC 3492 for a
+description of punycode.)
+.TP
+\fBtcl::idna decode\fR \fIhostname\fR
+.
+This command takes the name of a host that potentially contains
+punycode-encoded character sequences, \fIhostname\fR, and returns the hostname
+as might be displayed to the user. Note that there are often UNICODE
+characters that have extremely similar glyphs, so care should be taken with
+displaying hostnames to users.
+.TP
+\fBtcl::idna encode\fR \fIhostname\fR
+.
+This command takes the name of a host as might be displayed to the user,
+\fIhostname\fR, and returns the version of the hostname with characters not
+permitted in basic hostnames encoded with punycode.
+.TP
+\fBtcl::idna puny\fR \fIsubcommand ...\fR
+.
+This command provides direct access to the basic punycode encoder and
+decoder. It supports two \fIsubcommand\fRs:
+.RS
+.TP
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command decodes the punycode-encoded string, \fIstring\fR, and returns
+the result. If \fIcase\fR is provided, it is a boolean to make the case be
+folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is
+false) during the decoding process; if omitted, no case transformation is
+applied.
+.TP
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command encodes the string, \fIstring\fR, and returns the
+punycode-encoded version of the string. If \fIcase\fR is provided, it is a
+boolean to make the case be folded to upper case (if \fIcase\fR is true) or
+lower case (if \fIcase\fR is false) during the encoding process; if omitted,
+no case transformation is applied.
+.RE
+.TP
+\fBtcl::idna version\fR
+.
+This returns the version of the \fBtcl::idna\fR package.
+.SH "EXAMPLE"
+.PP
+This is an example of how punycoding of a string works:
+.PP
+.CS
+package require tcl::idna
+
+puts [\fBtcl::idna puny encode\fR "abc\(->def"]
+# prints: \fIabcdef-kn2c\fR
+puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"]
+# prints: \fIabc\(->def\fR
+.CE
+'\" TODO: show how it handles a real domain name
+.SH "SEE ALSO"
+http(n), cookiejar(n)
+.SH KEYWORDS
+internet, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/incr.n b/doc/incr.n
index b4be95c..f491903 100644
--- a/doc/incr.n
+++ b/doc/incr.n
@@ -27,6 +27,11 @@ and also returned as result.
Starting with the Tcl 8.5 release, the variable \fIvarName\fR passed
to \fBincr\fR may be unset, and in that case, it will be set to
the value \fIincrement\fR or to the default increment value of \fB1\fR.
+.VS TIP508
+If \fIvarName\fR indicate an element that does not exist of an array that has
+a default value set, the sum of the default value and the \fIincrement\fR (or
+1) will be stored in the array element.
+.VE TIP508
.SH EXAMPLES
.PP
Add one to the contents of the variable \fIx\fR:
@@ -59,3 +64,7 @@ an error if it is not):
expr(n), set(n)
.SH KEYWORDS
add, increment, variable, value
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/info.n b/doc/info.n
index 94141b4..b84b2c7 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -13,95 +13,100 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-info \- Return information about the state of the Tcl interpreter
+info \- Information about the state of the Tcl interpreter
.SH SYNOPSIS
\fBinfo \fIoption \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
-This command provides information about various internals of the Tcl
-interpreter.
-The legal \fIoption\fRs (which may be abbreviated) are:
+Available commands:
.TP
\fBinfo args \fIprocname\fR
.
-Returns a list containing the names of the arguments to procedure
-\fIprocname\fR, in order. \fIProcname\fR must be the name of a
-Tcl command procedure.
+Returns the names of the parameters to the procedure named \fIprocname\fR.
.TP
\fBinfo body \fIprocname\fR
.
-Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be
-the name of a Tcl command procedure.
+Returns the body of the procedure named \fIprocname\fR.
.TP
\fBinfo class\fI subcommand class\fR ?\fIarg ...\fR
-.VS 8.6
-Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are
-described in \fBCLASS INTROSPECTION\fR below.
-.VE 8.6
+.
+Returns information about the class named \fIclass\fR.
+See \fBCLASS INTROSPECTION\fR below.
.TP
\fBinfo cmdcount\fR
.
-Returns a count of the total number of commands that have been invoked
-in this interpreter.
+Returns the total number of commands evaluated in this interpreter.
+.TP
+\fBinfo cmdtype \fIcommandName\fR
+.VS TIP426
+Returns a the type of the command named \fIcommandName\fR.
+Built-in types are:
+.RS
+.IP \fBalias\fR
+\fIcommandName\fR was created by \fBinterp alias\fR.
+In a safe interpreter an alias is only visible if both the alias and the
+target are visible.
+.IP \fBcoroutine\fR
+\fIcommandName\fR was created by \fBcoroutine\fR.
+.IP \fBensemble\fR
+\fIcommandName\fR was created by \fBnamespace ensemble\fR.
+.IP \fBimport\fR
+\fIcommandName\fR was created by \fBnamespace import\fR.
+.IP \fBnative\fR
+\fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR
+interface directly without further registration of the type of command.
+.IP \fBobject\fR
+\fIcommandName\fR is the public command that represents an
+instance of \fBoo::object\fR or one of its subclasses.
+.IP \fBprivateObject\fR
+\fIcommandName\fR is the private command, \fBmy\fR by default,
+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?
.
-If \fIpattern\fR is not specified,
-returns a list of names of all the Tcl commands visible
-(i.e. executable without using a qualified name) to the current namespace,
-including both the built-in commands written in C and
-the command procedures defined using the \fBproc\fR command.
-If \fIpattern\fR is specified,
-only those names matching \fIpattern\fR are returned.
-Matching is determined using the same rules as for \fBstring match\fR.
-\fIpattern\fR can be a qualified name like \fBFoo::print*\fR.
-That is, it may specify a particular namespace
-using a sequence of namespace names separated by double colons (\fB::\fR),
-and may have pattern matching special characters
-at the end to specify a set of commands in that namespace.
-If \fIpattern\fR is a qualified name,
-the resulting list of command names has each one qualified with the name
-of the specified namespace, and only the commands defined in the named
-namespace are returned.
-.\" Technically, most of this hasn't changed; that's mostly just the
-.\" way it always worked. Hardly anyone knew that though.
+Returns the names of all commands visible in the current namespace. If
+\fIpattern\fR is given, returns only those names that match according to
+\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern.
+Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the
+\fBnamespace\fR(n) documentation.
.TP
\fBinfo complete \fIcommand\fR
.
-Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of
-having no unclosed quotes, braces, brackets or array element names.
-If the command does not appear to be complete then 0 is returned.
-This command is typically used in line-oriented input environments
-to allow users to type in commands that span multiple lines; if the
-command is not complete, the script can delay evaluating it until additional
-lines have been typed to complete the command.
+Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise.
+Typically used in line-oriented input environments
+to allow users to type in commands that span multiple lines.
.TP
\fBinfo coroutine\fR
-.VS 8.6
-Returns the name of the currently executing \fBcoroutine\fR, or the empty
-string if either no coroutine is currently executing, or the current coroutine
-has been deleted (but has not yet returned or yielded since deletion).
-.VE 8.6
+.
+Returns the name of the current \fBcoroutine\fR, or the empty
+string if there is no current coroutine or the current coroutine
+has been deleted.
.TP
-\fBinfo default \fIprocname arg varname\fR
+\fBinfo default \fIprocname parameter varname\fR
.
-\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR
-must be the name of an argument to that procedure. If \fIarg\fR
-does not have a default value then the command returns \fB0\fR.
-Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
-into variable \fIvarname\fR.
+If the parameter \fIparameter\fR for the procedure named \fIprocname\fR has a
+default value, stores that value in \fIvarname\fR and returns \fB1\fR.
+Otherwise, returns \fB0\fR.
.TP
\fBinfo errorstack \fR?\fIinterp\fR?
-.VS 8.6
-Returns, in a form that is programmatically easy to parse, the function names
-and arguments at each level from the call stack of the last error in the given
-\fIinterp\fR, or in the current one if not specified.
+.
+Returns a description of the active command at each level for the
+last error in the current interpreter, or in the interpreter named
+\fIinterp\fR if given.
.RS
.PP
-This form is an even-sized list alternating tokens and parameters. Tokens are
+The description is a dictionary of tokens and parameters. Tokens are
currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be
-introduced in the future. \fBCALL\fR indicates a procedure call, and its
+introduced in the future. \fBCALL\fR indicates a command call, and its
parameter is the corresponding \fBinfo level\fR \fB0\fR. \fBUP\fR indicates a
shift in variable frames generated by \fBuplevel\fR or similar, and applies to
the previous \fBCALL\fR item. Its parameter is the level offset. \fBINNER\fR
@@ -109,127 +114,103 @@ identifies the
.QW "inner context" ,
which is the innermost atomic command or bytecode instruction that raised the
error, along with its arguments when available. While \fBCALL\fR and \fBUP\fR
-allow to follow complex call paths, \fBINNER\fR homes in on the offending
-operation in the innermost procedure call, even going to sub-expression
+provide a trail of the call path, \fBINNER\fR provides details of the offending
+operation in the innermost procedure call, even to sub-expression
granularity.
.PP
This information is also present in the \fB\-errorstack\fR entry of the
options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
is a convenient way of retrieving it for uncaught errors at top-level in an
-interactive \fBtclsh\fR.
+interactive \fBinterpreter\fR.
.RE
-.VE 8.6
.TP
\fBinfo exists \fIvarName\fR
.
-Returns \fB1\fR if the variable named \fIvarName\fR exists in the
-current context (either as a global or local variable) and has been
-defined by being given a value, returns \fB0\fR otherwise.
+Returns \fB1\fR if a variable named \fIvarName\fR is visible and has been
+defined, and \fB0\fR otherwise.
.TP
-\fBinfo frame\fR ?\fInumber\fR?
+\fBinfo frame\fR ?\fIdepth\fR?
.
-This command provides access to all frames on the stack, even those
-hidden from \fBinfo level\fR. If \fInumber\fR is not specified, this
-command returns a number giving the frame level of the command. This
-is 1 if the command is invoked at top-level. If \fInumber\fR is
-specified, then the result is a dictionary containing the location
-information for the command at the \fInumber\fRed level on the stack.
+Returns the depth of the call to \fBinfo frame\fR itself. Otherwise, returns a
+dictionary describing the active command at the \fIdepth\fR, which counts all
+commands visible to \fBinfo level\fR, plus commands that don't create a new
+level, such as \fBeval\fR, \fBsource\fR, or \fIuplevel\fR. The frame depth is
+always greater than the current level.
.RS
.PP
-If \fInumber\fR is positive (> 0) then it selects a particular stack
-level (1 refers to the outer-most active command, 2 to the command it
-called, and so on, up to the current frame level which refers to
-\fBinfo frame\fR itself); otherwise it gives a level relative to the
-current command (0 refers to the current command, i.e., \fBinfo
-frame\fR itself, -1 to its caller, and so on).
-.PP
-This is similar to how \fBinfo level\fR works, except that this
-subcommand reports all frames, like \fBsource\fRd scripts,
-\fBeval\fRs, \fBuplevel\fRs, etc.
+If \fIdepth\fR is greater than \fB0\fR it is the frame at that depth. Otherwise
+it is the number of frames up from the current frame.
.PP
-Note that for nested commands, like
+As with \fBinfo level\fR and error traces, for nested commands like
.QW "foo [bar [x]]" ,
only
.QW x
-will be seen by an \fBinfo frame\fR invoked within
+is seen by \fBinfo frame\fR invoked within
.QW x .
-This is the same as for \fBinfo level\fR and error stack traces.
.PP
-The result dictionary may contain the keys listed below, with the
-specified meanings for their values:
+The dictionary may contain the following keys:
.TP
\fBtype\fR
.
-This entry is always present and describes the nature of the location
-for the command. The recognized values are \fBsource\fR, \fBproc\fR,
+Always present. Possible values are \fBsource\fR, \fBproc\fR,
\fBeval\fR, and \fBprecompiled\fR.
.RS
.TP
\fBsource\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in a script loaded by the \fBsource\fR
+A script loaded via the \fBsource\fR
command.
.TP
\fBproc\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in dynamically created procedure body.
+The body of a procedure that could not be traced back to a
+line in a particular script.
.TP
\fBeval\fR\0\0\0\0\0\0\0\0
.
-means that the command is executed by \fBeval\fR or \fBuplevel\fR.
+The body of a script provided to \fBeval\fR or \fBuplevel\fR.
.TP
\fBprecompiled\fR\0\0\0\0\0\0\0\0
.
-means that the command is found in a precompiled script (loadable by
-the package \fBtbcload\fR), and no further information will be
-available.
+A precompiled script (loadable by the package
+\fBtbcload\fR), and no further information is available.
.RE
.TP
\fBline\fR
.
-This entry provides the number of the line the command is at inside of
-the script it is a part of. This information is not present for type
-\fBprecompiled\fR. For type \fBsource\fR this information is counted
-relative to the beginning of the file, whereas for the last two types
-the line is counted relative to the start of the script.
+The line number of of the command inside its script. Not available for
+\fBprecompiled\fR commands. When the type is \fBsource\fR, the line number is
+relative to the beginning of the file, whereas for the last two types it is
+relative to the start of the script.
.TP
\fBfile\fR
.
-This entry is present only for type \fBsource\fR. It provides the
-normalized path of the file the command is in.
+For type \fBsource\fR, provides the normalized path of the file that contains
+the command.
.TP
\fBcmd\fR
.
-This entry provides the string representation of the command. This is
-usually the unsubstituted form, however for commands which are a
-canonically-constructed list (e.g., as produced by the \fBlist\fR command)
-executed by \fBeval\fR it is the substituted form as they have no other
-string representation. Care is taken that the canonicality property of
-the latter is not spoiled.
+The command before substitutions were performed.
.TP
\fBproc\fR
.
-This entry is present only if the command is found in the body of a
-regular Tcl procedure. It then provides the name of that procedure.
+For type \fBprod\fR, the name of the procedure containing the command.
.TP
\fBlambda\fR
.
-This entry is present only if the command is found in the body of an
-anonymous Tcl procedure, i.e. a lambda. It then provides the entire
-definition of the lambda in question.
+For a command in a script evaluated as the body of an unnamed routine via the
+\fBapply\fR command, the definition of that routine.
.TP
\fBlevel\fR
.
-This entry is present only if the queried frame has a corresponding
-frame returned by \fBinfo level\fR. It provides the index of this
-frame, relative to the current level (0 and negative numbers).
+For a frame that corresponds to a level, (to be determined).
.PP
-A thing of note is that for procedures statically defined in files the
-locations of commands in their bodies will be reported with type
-\fBsource\fR and absolute line numbers, and not as type
-\fBproc\fR. The same is true for procedures nested in statically
-defined procedures, and literal eval scripts in files or statically
-defined procedures.
+When a command can be traced to its literal definition in some script, e.g.
+procedures nested in statically defined procedures, and literal eval scripts in
+files or statically defined procedures, its type is \fBsource\fR and its
+location is the absolute line number in the script. Otherwise, its type is
+\fBproc\fR and its location is its line number within the body of the
+procedure.
.PP
In contrast, procedure definitions and \fBeval\fR within a dynamically
\fBeval\fRuated environment count line numbers relative to the start of
@@ -237,7 +218,7 @@ their script, even if they would be able to count relative to the
start of the outer dynamic script. That type of number usually makes
more sense.
.PP
-A different way of describing this behaviour is that file based
+A different way of describing this behaviour is that file-based
locations are tracked as deeply as possible, and where this is not
possible the lines are counted based on the smallest possible
\fBeval\fR or procedure body, as that scope is usually easier to find
@@ -251,167 +232,129 @@ counted relative to the start of each word (smallest scope)
.TP
\fBinfo functions \fR?\fIpattern\fR?
.
-If \fIpattern\fR is not specified, returns a list of all the math
+If \fIpattern\fR is not given, returns a list of all the math
functions currently defined.
-If \fIpattern\fR is specified, only those functions whose name matches
-\fIpattern\fR are returned. Matching is determined using the same
-rules as for \fBstring match\fR.
+If \fIpattern\fR is given, returns only those names that match
+\fIpattern\fR according to \fBstring match\fR.
.TP
\fBinfo globals \fR?\fIpattern\fR?
.
-If \fIpattern\fR is not specified, returns a list of all the names
+If \fIpattern\fR is not given, returns a list of all the names
of currently-defined global variables.
Global variables are variables in the global namespace.
-If \fIpattern\fR is specified, only those names matching \fIpattern\fR
+If \fIpattern\fR is given, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo hostname\fR
.
-Returns the name of the computer on which this invocation is being
-executed.
-Note that this name is not guaranteed to be the fully qualified domain
-name of the host. Where machines have several different names (as is
+Returns the name of the current host.
+
+This name is not guaranteed to be the fully-qualified domain
+name of the host. Where machines have several different names, as is
common on systems with both TCP/IP (DNS) and NetBIOS-based networking
-installed,) it is the name that is suitable for TCP/IP networking that
+installed, it is the name that is suitable for TCP/IP networking that
is returned.
.TP
-\fBinfo level\fR ?\fInumber\fR?
+\fBinfo level\fR ?\fIlevel\fR?
.
-If \fInumber\fR is not specified, this command returns a number
-giving the stack level of the invoking procedure, or 0 if the
-command is invoked at top-level. If \fInumber\fR is specified,
-then the result is a list consisting of the name and arguments for the
-procedure call at level \fInumber\fR on the stack. If \fInumber\fR
-is positive then it selects a particular stack level (1 refers
-to the top-most active procedure, 2 to the procedure it called, and
-so on); otherwise it gives a level relative to the current level
-(0 refers to the current procedure, -1 to its caller, and so on).
-See the \fBuplevel\fR command for more information on what stack
-levels mean.
+If \fInumber\fR is not given, the level this routine was called from.
+Otherwise returns the complete command active at the given level. If
+\fInumber\fR is greater than \fB0\fR, it is the desired level. Otherwise, it
+is \fInumber\fR levels up from the current level. A complete command is the
+words in the command, with all subsitutions performed, meaning that it is a
+list. See \fBuplevel\fR for more information on levels.
.TP
\fBinfo library\fR
.
-Returns the name of the library directory in which standard Tcl
-scripts are stored.
-This is actually the value of the \fBtcl_library\fR
-variable and may be changed by setting \fBtcl_library\fR.
+Returns the value of \fBtcl_library\fR, which is the name of the library
+directory in which the scripts distributed with Tcl scripts are stored.
.TP
-\fBinfo loaded \fR?\fIinterp\fR?
+\fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR?
.
-Returns a list describing all of the packages that have been loaded into
-\fIinterp\fR with the \fBload\fR command.
-Each list element is a sub-list with two elements consisting of the
-name of the file from which the package was loaded and the name of
-the package.
-For statically-loaded packages the file name will be an empty string.
-If \fIinterp\fR is omitted then information is returned for all packages
-loaded in any interpreter in the process.
-To get a list of just the packages in the current interpreter, specify
-an empty string for the \fIinterp\fR argument.
+Returns the name of each file loaded in \fIinterp\fR va \fBload\fR as part of
+\fIpackage\fR . If \fIpackage\fR is not given, returns a list where each item
+is the name of the loaded file and the name of the package for which the file
+was loaded. For a statically-loaded package the name of the file is the empty
+string. For \fIinterp\fR, the empty string is the current interpreter.
.TP
\fBinfo locals \fR?\fIpattern\fR?
.
-If \fIpattern\fR is not specified, returns a list of all the names
-of currently-defined local variables, including arguments to the
-current procedure, if any.
-Variables defined with the \fBglobal\fR, \fBupvar\fR and
-\fBvariable\fR commands will not be returned.
-If \fIpattern\fR is specified, only those names matching \fIpattern\fR
-are returned. Matching is determined using the same rules as for
-\fBstring match\fR.
+If \fIpattern\fR is given, returns the name of each local variable matching
+\fIpattern\fR according to \fBstring match\fR. Otherwise, returns the name of
+each local variable. A variables defined with the \fBglobal\fR, \fBupvar\fR or
+\fBvariable\fR is not local.
+
.TP
\fBinfo nameofexecutable\fR
.
-Returns the full path name of the binary file from which the application
-was invoked. If Tcl was unable to identify the file, then an empty
-string is returned.
+Returns the absolute pathname of the program for the current interpreter. If
+such a file can not be identified an empty string is returned.
.TP
\fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
-.VS 8.6
-Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are
-described in \fBOBJECT INTROSPECTION\fR below.
-.VE 8.6
+.
+Returns information about the object named \fIobject\fR. \fIsubcommand\fR is
+described \fBOBJECT INTROSPECTION\fR below.
.TP
\fBinfo patchlevel\fR
.
-Returns the value of the global variable \fBtcl_patchLevel\fR, which holds
-the exact version of the Tcl library by default.
+Returns the value of the global variable \fBtcl_patchLevel\fR, in which the
+exact version of the Tcl library initially stored.
.TP
\fBinfo procs \fR?\fIpattern\fR?
.
-If \fIpattern\fR is not specified, returns a list of all the
-names of Tcl command procedures in the current namespace.
-If \fIpattern\fR is specified,
-only those procedure names in the current namespace
-matching \fIpattern\fR are returned.
-Matching is determined using the same rules as for
-\fBstring match\fR.
-If \fIpattern\fR contains any namespace separators, they are used to
-select a namespace relative to the current namespace (or relative to
-the global namespace if \fIpattern\fR starts with \fB::\fR) to match
-within; the matching pattern is taken to be the part after the last
-namespace separator.
+Returns the names of all visible procedures. If \fIpattern\fR is given, returns
+only those names that match according to \fBstring match\fR. Only the final
+component in \fIpattern\fR is actually considered a pattern. Any qualifying
+components simply select a namespace. See \fBNAMESPACE RESOLUTION\fR in the
+\fBnamespace\fR(n) documentation.
.TP
\fBinfo script\fR ?\fIfilename\fR?
.
-If a Tcl script file is currently being evaluated (i.e. there is a
-call to \fBTcl_EvalFile\fR active or there is an active invocation
-of the \fBsource\fR command), then this command returns the name
-of the innermost file being processed. If \fIfilename\fR is specified,
-then the return value of this command will be modified for the
-duration of the active invocation to return that name. This is
-useful in virtual file system applications.
-Otherwise the command returns an empty string.
+Returns the pathname of the innermost script currently being evaluated, or the
+empty string if no pathname can be determined. If \fIfilename\fR is given,
+sets the return value of any future calls to \fBinfo script\fR for the duration
+of the innermost active script. This is useful in virtual file system
+applications.
.TP
\fBinfo sharedlibextension\fR
.
-Returns the extension used on this platform for the names of files
-containing shared libraries (for example, \fB.so\fR under Solaris).
-If shared libraries are not supported on this platform then an empty
-string is returned.
+Returns the extension used on this platform for names of shared libraries, e.g.
+\fB.so\fR under Solaris. Returns the empty string if shared libraries are not
+supported on this platform.
.TP
\fBinfo tclversion\fR
.
-Returns the value of the global variable \fBtcl_version\fR, which holds the
-major and minor version of the Tcl library by default.
+Returns the value of the global variable \fBtcl_version\fR, in which the
+major and minor version of the Tcl library are stored.
.TP
\fBinfo vars\fR ?\fIpattern\fR?
.
-If \fIpattern\fR is not specified,
-returns a list of all the names of currently-visible variables.
-This includes locals and currently-visible globals.
-If \fIpattern\fR is specified, only those names matching \fIpattern\fR
-are returned. Matching is determined using the same rules as for
-\fBstring match\fR.
-\fIpattern\fR can be a qualified name like \fBFoo::option*\fR.
-That is, it may specify a particular namespace
-using a sequence of namespace names separated by double colons (\fB::\fR),
-and may have pattern matching special characters
-at the end to specify a set of variables in that namespace.
-If \fIpattern\fR is a qualified name,
-the resulting list of variable names
-has each matching namespace variable qualified with the name
-of its namespace.
-Note that a currently-visible variable may not yet
-.QW exist
-if it has not
-been set (e.g. a variable declared but not set by \fBvariable\fR).
+If \fIpattern\fR is not given, returns the names of all visible variables. If
+\fIpattern\fR is given, returns only those names that match according to
+\fBstring match\fR. Only the last component of \fIpattern\fR is a pattern.
+Other components identify a namespace. See \fBNAMESPACE RESOLUTION\fR in the
+\fBnamespace\fR(n) documentation. When \fIpattern\fR is a qualified name,
+results are fully qualified.
+
+A variable that has declared but not yet defined is included in the results.
.SS "CLASS INTROSPECTION"
-.VS 8.6
.PP
The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
-.VE 8.6
.TP
\fBinfo class call\fI class method\fR
-.VS
+.
Returns a description of the method implementations that are used to provide a
stereotypical instance of \fIclass\fR's implementation of \fImethod\fR
(stereotypical instances being objects instantiated by a class without having
any object-specific definitions added). This consists of a list of lists of
four elements, where each sublist consists of a word that describes the
general type of method implementation (being one of \fBmethod\fR for an
-ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+ordinary method, \fBfilter\fR for an applied filter,
+.VS TIP500
+\fBprivate\fR for a private method,
+.VE TIP500
+and \fBunknown\fR for a
method that is invoked as part of unknown method handling), a word giving the
name of the particular method invoked (which is always the same as
\fImethod\fR for the \fBmethod\fR type, and
@@ -422,122 +365,190 @@ implementation (see \fBinfo class methodtype\fR).
.RS
.PP
Note that there is no inspection of whether the method implementations
-actually use \fBnext\fR to transfer control along the call chain.
+actually use \fBnext\fR to transfer control along the call chain,
+.VS TIP500
+and the call chains that this command files do not actually contain private
+methods.
+.VE TIP500
.RE
-.VE 8.6
.TP
\fBinfo class constructor\fI class\fR
-.VS 8.6
+.
This subcommand returns a description of the definition of the constructor of
class \fIclass\fR. The definition is described as a two element list; the first
element is the list of arguments to the constructor in a form suitable for
passing to another call to \fBproc\fR or a method definition, and the second
element is the body of the constructor. If no constructor is present, this
returns the empty list.
-.VE 8.6
.TP
\fBinfo class definition\fI class method\fR
-.VS 8.6
+.
This subcommand returns a description of the definition of the method named
\fImethod\fR of class \fIclass\fR. The definition is described as a two element
list; the first element is the list of arguments to the method in a form
suitable for passing to another call to \fBproc\fR or a method definition, and
the second element is the body of the method.
-.VE 8.6
+.TP
+\fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR?
+.VS TIP524
+This subcommand returns the definition namespace for \fIkind\fR definitions of
+the class \fIclass\fR; the definition namespace only affects the instances of
+\fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either
+\fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or
+\fB\-instance\fR to return the definition namespace used for
+\fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only
+actually useful on classes that are subclasses of \fBoo::class\fR).
+.RS
+.PP
+If \fIclass\fR does not provide a definition namespace of the given kind,
+this command returns the empty string. In those circumstances, the
+\fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition
+namespace to use using the class inheritance hierarchy.
+.RE
+.VE TIP524
.TP
\fBinfo class destructor\fI class\fR
-.VS 8.6
+.
This subcommand returns the body of the destructor of class \fIclass\fR. If no
destructor is present, this returns the empty string.
-.VE 8.6
.TP
\fBinfo class filters\fI class\fR
-.VS 8.6
+.
This subcommand returns the list of filter methods set on the class.
-.VE 8.6
.TP
\fBinfo class forward\fI class method\fR
-.VS 8.6
+.
This subcommand returns the argument list for the method forwarding called
\fImethod\fR that is set on the class called \fIclass\fR.
-.VE 8.6
.TP
\fBinfo class instances\fI class\fR ?\fIpattern\fR?
-.VS 8.6
+.
This subcommand returns a list of instances of class \fIclass\fR. If the
optional \fIpattern\fR argument is present, it constrains the list of returned
instances to those that match it according to the rules of \fBstring match\fR.
-.VE 8.6
.TP
\fBinfo class methods\fI class\fR ?\fIoptions...\fR?
-.VS 8.6
+.
This subcommand returns a list of all public (i.e. exported) methods of the
class called \fIclass\fR. Any of the following \fIoption\fRs may be
-specified, controlling exactly which method names are returned:
+given, controlling exactly which method names are returned:
.RS
-.VE 8.6
.TP
\fB\-all\fR
-.VS 8.6
-If the \fB\-all\fR flag is given, the list of methods will include those
+.
+If the \fB\-all\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will include those
methods defined not just by the class, but also by the class's superclasses
and mixins.
-.VE 8.6
.TP
\fB\-private\fR
-.VS 8.6
-If the \fB\-private\fR flag is given, the list of methods will also include
-the private (i.e. non-exported) methods of the class (and superclasses and
+.
+If the \fB\-private\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will also include
+the non-exported methods of the class (and superclasses and
mixins, if \fB\-all\fR is also given).
+.VS TIP500
+Note that this naming is an unfortunate clash with true private methods; this
+option name is retained for backward compatibility.
+.VE TIP500
+.TP
+\fB\-scope\fI scope\fR
+.VS TIP500
+Returns a list of all methods on \fIclass\fR that have the given visibility
+\fIscope\fR. When this option is supplied, both the \fB\-all\fR and
+\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
+.RS
+.IP \fBpublic\fR 3
+Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance
+of this class) are to be returned.
+.IP \fBunexported\fR 3
+Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
+be returned.
+.IP \fBprivate\fR 3
+Only methods with \fIprivate\fR scope (i.e., only callable from within this class's
+methods) are to be returned.
+.RE
+.VE TIP500
.RE
-.VE 8.6
.TP
\fBinfo class methodtype\fI class method\fR
-.VS 8.6
+.
This subcommand returns a description of the type of implementation used for
the method named \fImethod\fR of class \fIclass\fR. When the result is
\fBmethod\fR, further information can be discovered with \fBinfo class
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo class forward\fR.
-.VE 8.6
.TP
\fBinfo class mixins\fI class\fR
-.VS 8.6
+.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.
-.VE 8.6
+.TP
+\fBinfo class properties\fI class\fR ?\fIoptions...\fR
+.VS "TIP 558"
+This subcommand returns a sorted list of properties defined on the class named
+\fIclass\fR. The \fIoptions\fR define exactly which properties are returned:
+.RS
+.TP
+\fB\-all\fR
+.
+With this option, the properties from the superclasses and mixins of the class
+are also returned.
+.TP
+\fB\-readable\fR
+.
+This option (the default behavior) asks for the readable properties to be
+returned. Only readable or writable properties are returned, not both.
+.TP
+\fB\-writable\fR
+.
+This option asks for the writable properties to be returned. Only readable or
+writable properties are returned, not both.
+.RE
+.VE "TIP 558"
.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
-.VS 8.6
+.
This subcommand returns a list of direct subclasses of class \fIclass\fR. If
the optional \fIpattern\fR argument is present, it constrains the list of
returned classes to those that match it according to the rules of
\fBstring match\fR.
-.VE 8.6
.TP
\fBinfo class superclasses\fI class\fR
-.VS 8.6
+.
This subcommand returns a list of direct superclasses of class \fIclass\fR in
inheritance precedence order.
-.VE 8.6
.TP
-\fBinfo class variables\fI class\fR
-.VS 8.6
+\fBinfo class variables\fI class\fR ?\fB\-private\fR?
+.
This subcommand returns a list of all variables that have been declared for
the class named \fIclass\fR (i.e. that are automatically present in the
class's methods, constructor and destructor).
+.VS TIP500
+If the \fB\-private\fR option is given, this lists the private variables
+declared instead.
+.VE TIP500
.SS "OBJECT INTROSPECTION"
.PP
The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
-.VE 8.6
.TP
\fBinfo object call\fI object method\fR
-.VS 8.6
+.
Returns a description of the method implementations that are used to provide
\fIobject\fR's implementation of \fImethod\fR. This consists of a list of
lists of four elements, where each sublist consists of a word that describes
the general type of method implementation (being one of \fBmethod\fR for an
-ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+ordinary method, \fBfilter\fR for an applied filter,
+.VS TIP500
+\fBprivate\fR for a private method,
+.VE TIP500
+and \fBunknown\fR for a
method that is invoked as part of unknown method handling), a word giving the
name of the particular method invoked (which is always the same as
\fImethod\fR for the \fBmethod\fR type, and
@@ -549,128 +560,184 @@ implementation (see \fBinfo object methodtype\fR).
.RS
.PP
Note that there is no inspection of whether the method implementations
-actually use \fBnext\fR to transfer control along the call chain.
+actually use \fBnext\fR to transfer control along the call chain,
+.VS TIP500
+and the call chains that this command files do not actually contain private
+methods.
+.VE TIP500
.RE
-.VE 8.6
.TP
\fBinfo object class\fI object\fR ?\fIclassName\fR?
-.VS 8.6
-If \fIclassName\fR is unspecified, this subcommand returns class of the
+.
+If \fIclassName\fR is not given, this subcommand returns class of the
\fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a
boolean value indicating whether the \fIobject\fR is of that class.
-.VE 8.6
+.TP
+\fBinfo object creationid\fI object\fR
+.VS TIP500
+Returns the unique creation identifier for the \fIobject\fR object. This
+creation identifier is unique to the object (within a Tcl interpreter) and
+cannot be controlled at object creation time or altered afterwards.
+.RS
+.PP
+\fIImplementation note:\fR the creation identifier is used to generate unique
+identifiers associated with the object, especially for private variables.
+.RE
+.VE TIP500
.TP
\fBinfo object definition\fI object method\fR
-.VS 8.6
+.
This subcommand returns a description of the definition of the method named
\fImethod\fR of object \fIobject\fR. The definition is described as a two
element list; the first element is the list of arguments to the method in a
form suitable for passing to another call to \fBproc\fR or a method definition,
and the second element is the body of the method.
-.VE 8.6
.TP
\fBinfo object filters\fI object\fR
-.VS 8.6
+.
This subcommand returns the list of filter methods set on the object.
-.VE 8.6
.TP
\fBinfo object forward\fI object method\fR
-.VS 8.6
+.
This subcommand returns the argument list for the method forwarding called
\fImethod\fR that is set on the object called \fIobject\fR.
-.VE 8.6
.TP
\fBinfo object isa\fI category object\fR ?\fIarg\fR?
-.VS 8.6
+.
This subcommand tests whether an object belongs to a particular category,
returning a boolean value that indicates whether the \fIobject\fR argument
meets the criteria for the category. The supported categories are:
-.VE 8.6
.RS
.TP
\fBinfo object isa class\fI object\fR
-.VS 8.6
+.
This returns whether \fIobject\fR is a class (i.e. an instance of
\fBoo::class\fR or one of its subclasses).
-.VE 8.6
.TP
\fBinfo object isa metaclass\fI object\fR
-.VS 8.6
+.
This returns whether \fIobject\fR is a class that can manufacture classes
(i.e. is \fBoo::class\fR or a subclass of it).
-.VE 8.6
.TP
\fBinfo object isa mixin\fI object class\fR
-.VS 8.6
+.
This returns whether \fIclass\fR is directly mixed into \fIobject\fR.
-.VE 8.6
.TP
\fBinfo object isa object\fI object\fR
-.VS 8.6
+.
This returns whether \fIobject\fR really is an object.
-.VE 8.6
.TP
\fBinfo object isa typeof\fI object class\fR
-.VS 8.6
+.
This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether
\fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether
direct or indirect).
.RE
-.VE 8.6
.TP
\fBinfo object methods\fI object\fR ?\fIoption...\fR?
-.VS 8.6
+.
This subcommand returns a list of all public (i.e. exported) methods of the
object called \fIobject\fR. Any of the following \fIoption\fRs may be
-specified, controlling exactly which method names are returned:
+given, controlling exactly which method names are returned:
.RS
-.VE 8.6
.TP
\fB\-all\fR
-.VS 8.6
-If the \fB\-all\fR flag is given, the list of methods will include those
+.
+If the \fB\-all\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will include those
methods defined not just by the object, but also by the object's class and
mixins, plus the superclasses of those classes.
-.VE 8.6
.TP
\fB\-private\fR
-.VS 8.6
-If the \fB\-private\fR flag is given, the list of methods will also include
-the private (i.e. non-exported) methods of the object (and classes, if
+.
+If the \fB\-private\fR flag is given,
+.VS TIP500
+and the \fB\-scope\fR flag is not given,
+.VE TIP500
+the list of methods will also include
+the non-exported methods of the object (and classes, if
\fB\-all\fR is also given).
+.VS TIP500
+Note that this naming is an unfortunate clash with true private methods; this
+option name is retained for backward compatibility.
+.VE TIP500
+.TP
+\fB\-scope\fI scope\fR
+.VS TIP500
+Returns a list of all methods on \fIobject\fR that have the given visibility
+\fIscope\fR. When this option is supplied, both the \fB\-all\fR and
+\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
+.RS
+.IP \fBpublic\fR 3
+Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be
+returned.
+.IP \fBunexported\fR 3
+Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
+be returned.
+.IP \fBprivate\fR 3
+Only methods with \fIprivate\fR scope (i.e., only callable from within this object's
+instance methods) are to be returned.
+.RE
+.VE TIP500
.RE
-.VE 8.6
.TP
\fBinfo object methodtype\fI object method\fR
-.VS 8.6
+.
This subcommand returns a description of the type of implementation used for
the method named \fImethod\fR of object \fIobject\fR. When the result is
\fBmethod\fR, further information can be discovered with \fBinfo object
definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo object forward\fR.
-.VE 8.6
.TP
\fBinfo object mixins\fI object\fR
-.VS 8.6
+.
This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
-.VE 8.6
.TP
\fBinfo object namespace\fI object\fR
-.VS 8.6
+.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
-.VE 8.6
.TP
-\fBinfo object variables\fI object\fR
-.VS 8.6
+\fBinfo object properties\fI object\fR ?\fIoptions...\fR
+.VS "TIP 558"
+This subcommand returns a sorted list of properties defined on the object
+named \fIobject\fR. The \fIoptions\fR define exactly which properties are
+returned:
+.RS
+.TP
+\fB\-all\fR
+.
+With this option, the properties from the class, superclasses and mixins of
+the object are also returned.
+.TP
+\fB\-readable\fR
+.
+This option (the default behavior) asks for the readable properties to be
+returned. Only readable or writable properties are returned, not both.
+.TP
+\fB\-writable\fR
+.
+This option asks for the writable properties to be returned. Only readable or
+writable properties are returned, not both.
+.RE
+.VE "TIP 558"
+.TP
+\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
+.
This subcommand returns a list of all variables that have been declared for
the object named \fIobject\fR (i.e. that are automatically present in the
object's methods).
-.VE 8.6
+.VS TIP500
+If the \fB\-private\fR option is given, this lists the private variables
+declared instead.
+.VE TIP500
.TP
\fBinfo object vars\fI object\fR ?\fIpattern\fR?
-.VS 8.6
+.
This subcommand returns a list of all variables in the private namespace of
the object named \fIobject\fR. If the optional \fIpattern\fR argument is
given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
@@ -679,7 +746,6 @@ from the list returned by \fBinfo object variables\fR; that can include
variables that are currently unset, whereas this can include variables that
are not automatically included by any of \fIobject\fR's methods (or those of
its class, superclasses or mixins).
-.VE 8.6
.SH EXAMPLES
.PP
This command prints out a procedure suitable for saving in a Tcl
@@ -702,7 +768,6 @@ proc printProc {procName} {
}
.CE
.SS "EXAMPLES WITH OBJECTS"
-.VS 8.6
.PP
Every object necessarily knows what its class is; this information is
trivially extractable through introspection:
@@ -723,8 +788,10 @@ method and get how it is defined. This procedure illustrates how:
proc getDef {obj method} {
foreach inf [\fBinfo object call\fR $obj $method] {
lassign $inf calltype name locus methodtype
+
# Assume no forwards or filters, and hence no $calltype
# or $methodtype checks...
+
if {$locus eq "object"} {
return [\fBinfo object definition\fR $obj $name]
} else {
@@ -747,7 +814,9 @@ proc getDef {obj method} {
# Assume no forwards
return [\fBinfo object definition\fR $obj $method]
}
+
set cls [\fBinfo object class\fR $obj]
+
while {$method ni [\fBinfo class methods\fR $cls]} {
# Assume the simple case
set cls [lindex [\fBinfo class superclass\fR $cls] 0]
@@ -755,22 +824,17 @@ proc getDef {obj method} {
error "no definition for $method"
}
}
+
# Assume no forwards
return [\fBinfo class definition\fR $cls $method]
}
.CE
-.VE 8.6
.SH "SEE ALSO"
-.VS 8.6
global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n),
-.VE 8.6
tcl_library(n), tcl_patchLevel(n), tcl_version(n)
.SH KEYWORDS
command, information, interpreter, introspection, level, namespace,
-.VS 8.6
-object,
-.VE 8.6
-procedure, variable
+object, procedure, variable
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
diff --git a/doc/interp.n b/doc/interp.n
index 1127632..08bed1c 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -154,7 +154,6 @@ what to set the interpreter's background exception handler to. See the
\fBBACKGROUND EXCEPTION HANDLING\fR section for more details.
.TP
\fBinterp\fR \fBcancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\fR?
-.VS 8.6
Cancels the script being evaluated in the interpreter identified by
\fIpath\fR. Without the \fB\-unwind\fR switch the evaluation stack for
the interpreter is unwound until an enclosing catch command is found or
@@ -167,7 +166,6 @@ switches; it may be needed if \fIpath\fR is an unusual value such
as \fB\-safe\fR. If \fIresult\fR is present, it will be used as the
error message string; otherwise, a default error message string will be
used.
-.VE 8.6
.TP
\fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR?
.
@@ -236,7 +234,7 @@ attempts are silently ignored. This is needed to maintain the
consistency of the underlying interpreter's state.
.RE
.TP
-\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
+\fBinterp\fR \fBdelete \fR?\fIpath ...\fR?
.
Deletes zero or more interpreters given by the optional \fIpath\fR
arguments, and for each interpreter, it also deletes its children. The
@@ -371,17 +369,15 @@ Both interpreters must close it to close the underlying IO channel; IO
channels accessible in an interpreter are automatically closed when an
interpreter is destroyed.
.TP
-\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
+\fBinterp\fR \fBchildren\fR ?\fIpath\fR?
.
Returns a Tcl list of the names of all the child interpreters associated
with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted,
the invoking interpreter is used.
-.VS "TIP 581"
.TP
-\fBinterp\fR \fBchildren\fR ?\fIpath\fR?
+\fBinterp\fR \fBslaves\fR ?\fIpath\fR?
.
-Synonym for . \fBinterp\fR \fBslaves\fR ?\fIpath\fR?
-.VE "TIP 581"
+Synonym for . \fBinterp\fR \fBchildren\fR ?\fIpath\fR?
.TP
\fBinterp\fR \fBtarget\fR \fIpath alias\fR
.
@@ -399,7 +395,7 @@ The target command does not have to be defined at the time of this invocation.
Causes the IO channel identified by \fIchannelId\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
-.SH "child COMMAND"
+.SH "CHILD COMMAND"
.PP
For each child interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the parent interpreter with the same
@@ -411,7 +407,7 @@ general form:
\fIchild command \fR?\fIarg arg ...\fR?
.CE
.PP
-\fIchild\fR is the name of the interpreter, and \fIcommand\fR
+\fIChild\fR is the name of the interpreter, and \fIcommand\fR
and the \fIarg\fRs determine the exact behavior of the command.
The valid forms of this command are:
.TP
@@ -595,16 +591,16 @@ built-in commands:
\fBflush\fR \fBfor\fR \fBforeach\fR \fBformat\fR
\fBgets\fR \fBglobal\fR \fBif\fR \fBincr\fR
\fBinfo\fR \fBinterp\fR \fBjoin\fR \fBlappend\fR
-\fBlassign\fR \fBlindex\fR \fBlinsert\fR \fBlist\fR
-\fBllength\fR \fBlrange\fR \fBlrepeat\fR \fBlreplace\fR
-\fBlsearch\fR \fBlset\fR \fBlsort\fR \fBnamespace\fR
-\fBpackage\fR \fBpid\fR \fBproc\fR \fBputs\fR
-\fBread\fR \fBregexp\fR \fBregsub\fR \fBrename\fR
-\fBreturn\fR \fBscan\fR \fBseek\fR \fBset\fR
-\fBsplit\fR \fBstring\fR \fBsubst\fR \fBswitch\fR
-\fBtell\fR \fBtime\fR \fBtrace\fR \fBunset\fR
-\fBupdate\fR \fBuplevel\fR \fBupvar\fR \fBvariable\fR
-\fBvwait\fR \fBwhile\fR
+\fBlassign\fR \fBledit\fR \fBlindex\fR \fBlinsert\fR
+\fBlist\fR \fBllength\fR \fBlrange\fR \fBlrepeat\fR
+\fBlreplace\fR \fBlsearch\fR \fBlseq\fR \fBlset\fR
+\fBlsort\fR \fBnamespace\fR \fBpackage\fR \fBpid\fR
+\fBproc\fR \fBputs\fR \fBread\fR \fBregexp\fR
+\fBregsub\fR \fBrename\fR \fBreturn\fR \fBscan\fR
+\fBseek\fR \fBset\fR \fBsplit\fR \fBstring\fR
+\fBsubst\fR \fBswitch\fR \fBtell\fR \fBtime\fR
+\fBtrace\fR \fBunset\fR \fBupdate\fR \fBuplevel\fR
+\fBupvar\fR \fBvariable\fR \fBvwait\fR \fBwhile\fR
.DE
The following commands are hidden by \fBinterp create\fR when it
creates a safe interpreter:
diff --git a/doc/join.n b/doc/join.n
index 23a7697..7dcde98 100644
--- a/doc/join.n
+++ b/doc/join.n
@@ -42,3 +42,7 @@ set data {1 {2 3} 4 {5 {6 7} 8}}
list(n), lappend(n), split(n)
.SH KEYWORDS
element, join, list, separator
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/lappend.n b/doc/lappend.n
index 80d075a..3fbda79 100644
--- a/doc/lappend.n
+++ b/doc/lappend.n
@@ -22,6 +22,12 @@ and appends each of the \fIvalue\fR arguments to that list as a separate
element, with spaces between elements.
If \fIvarName\fR does not exist, it is created as a list with elements
given by the \fIvalue\fR arguments.
+.VS TIP508
+If \fIvarName\fR indicate an element that does not exist of an array that has
+a default value set, list that is comprised of the default value with all the
+\fIvalue\fR arguments appended as elements will be stored in the array
+element.
+.VE TIP508
\fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs
are appended as list elements rather than raw text.
This command provides a relatively efficient way to build up
@@ -43,7 +49,12 @@ Using \fBlappend\fR to build up a list of numbers.
1 2 3 4 5
.CE
.SH "SEE ALSO"
-list(n), lindex(n), linsert(n), llength(n), lset(n),
-lsort(n), lrange(n)
+list(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
append, element, list, variable
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/lassign.n b/doc/lassign.n
index 5620de6..d23509a 100644
--- a/doc/lassign.n
+++ b/doc/lassign.n
@@ -52,7 +52,9 @@ command in many shell languages like this:
set ::argv [\fBlassign\fR $::argv argumentToReadOff]
.CE
.SH "SEE ALSO"
-lindex(n), list(n), lrange(n), lset(n), set(n)
+list(n), lappend(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
assign, element, list, multiple, set, variable
'\"Local Variables:
diff --git a/doc/ledit.n b/doc/ledit.n
new file mode 100644
index 0000000..48bc608
--- /dev/null
+++ b/doc/ledit.n
@@ -0,0 +1,91 @@
+'\"
+'\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. 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 ledit n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+ledit \- Replace elements of a list stored in variable
+.SH SYNOPSIS
+\fBledit \fIlistVar first last \fR?\fIvalue value ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+The command fetches the list value in variable \fIlistVar\fR and replaces the
+elements in the range given by indices \fIfirst\fR to \fIlast\fR (inclusive)
+with the \fIvalue\fR arguments. The resulting list is then stored back in
+\fIlistVar\fR and returned as the result of the command.
+.PP
+Arguments \fIfirst\fR and \fIlast\fR are index values specifying the first and
+last elements of the range to replace. They are interpreted
+the same as index values for the command \fBstring index\fR,
+supporting simple index arithmetic and indices relative to the
+end of the list. The index \fB0\fR refers to the first element of the
+list, and \fBend\fR refers to the last element of the list.
+.PP
+If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to
+refer to the position before the first element of the list. This allows
+elements to be prepended.
+.PP
+If either \fIfirst\fR or \fIlast\fR indicates a position greater than the
+index of the last element of the list, it is treated as if it is an
+index one greater than the last element. This allows elements to be appended.
+.PP
+If \fIlast\fR is less than \fIfirst\fR, then any specified elements
+will be inserted into the list before the element specified by \fIfirst\fR
+with no elements being deleted.
+.PP
+The \fIvalue\fR arguments specify zero or more new elements to
+be added to the list in place of those that were deleted.
+Each \fIvalue\fR argument will become a separate element of
+the list. If no \fIvalue\fR arguments are specified, then the elements
+between \fIfirst\fR and \fIlast\fR are simply deleted.
+.SH EXAMPLES
+.PP
+Prepend to a list.
+.PP
+.CS
+set lst {c d e f g}
+ \fI\(-> c d e f g\fR
+\fBledit\fR lst -1 -1 a b
+ \fI\(-> a b c d e f g\fR
+.CE
+.PP
+Append to the list.
+.PP
+.CS
+\fBledit\fR lst end+1 end+1 h i
+ \fI\(-> a b c d e f g h i\fR
+.CE
+.PP
+Delete third and fourth elements.
+.PP
+.CS
+\fBledit\fR lst 2 3
+ \fI\(-> a b e f g h i\fR
+.CE
+.PP
+Replace two elements with three.
+.PP
+.CS
+\fBledit\fR lst 2 3 x y z
+ \fI\(-> a b x y z g h i\fR
+set lst
+ \fI\(-> a b x y z g h i\fR
+.CE
+.PP
+.SH "SEE ALSO"
+list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
+string(n)
+.SH KEYWORDS
+element, list, replace
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/library.n b/doc/library.n
index f14e8e0..0342cbe 100644
--- a/doc/library.n
+++ b/doc/library.n
@@ -25,6 +25,11 @@ auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, tcl
\fBtcl_startOfPreviousWord \fIstr start\fR
\fBtcl_wordBreakAfter \fIstr start\fR
\fBtcl_wordBreakBefore \fIstr start\fR
+.VS "Tcl 8.7, TIP 670"
+\fBforeachLine \fIfilename varName body\fR
+\fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR?
+\fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR
+.VE "Tcl 8.7, TIP 670"
.BE
.SH INTRODUCTION
.PP
@@ -58,6 +63,7 @@ the auto-load mechanism defined below.
The following procedures are provided in the Tcl library:
.TP
\fBauto_execok \fIcmd\fR
+.
Determines whether there is an executable file or shell builtin
by the name \fIcmd\fR. If so, it returns a list of arguments to be
passed to \fBexec\fR to execute the executable file or shell builtin
@@ -70,8 +76,30 @@ remembers information about previous searches in an array named
\fBauto_execs\fR; this avoids the path search in future calls for the
same \fIcmd\fR. The command \fBauto_reset\fR may be used to force
\fBauto_execok\fR to forget its cached information.
+.RS
+.PP
+For example, to run the \fIumask\fR shell builtin on Linux, you would do:
+.PP
+.CS
+exec {*}[\fBauto_execok\fR umask]
+.CE
+.PP
+To run the \fIDIR\fR shell builtin on Windows, you would do:
+.PP
+.CS
+exec {*}[\fBauto_execok\fR dir]
+.CE
+.PP
+To discover if there is a \fIfrobnicate\fR binary on the user's PATH,
+you would do:
+.PP
+.CS
+set mayFrob [expr {[llength [\fBauto_execok\fR frobnicate]] > 0}]
+.CE
+.RE
.TP
\fBauto_import \fIpattern\fR
+.
\fBAuto_import\fR is invoked during \fBnamespace import\fR to see if
the imported commands specified by \fIpattern\fR reside in an
autoloaded library. If so, the commands are loaded so that they will
@@ -79,13 +107,18 @@ be available to the interpreter for creating the import links. If the
commands do not reside in an autoloaded library, \fBauto_import\fR
does nothing. The pattern matching is performed according to the
matching rules of \fBnamespace import\fR.
+.RS
+.PP
+It is not normally necessary to call this command directly.
+.RE
.TP
\fBauto_load \fIcmd\fR
+.
This command attempts to load the definition for a Tcl command named
\fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is
a list of one or more directories. The auto-load path is given by the
global variable \fBauto_path\fR if it exists. If there is no
-\fBauto_path\fR variable, then the TCLLIBPATH environment variable is
+\fBauto_path\fR variable, then the \fBTCLLIBPATH\fR environment variable is
used, if it exists. Otherwise the auto-load path consists of just the
Tcl library directory. Within each directory in the auto-load path
there must be a file \fBtclIndex\fR that describes one or more
@@ -104,6 +137,11 @@ the array \fBauto_index\fR; future calls to \fBauto_load\fR check for
cached index information may be deleted with the command
\fBauto_reset\fR. This will force the next \fBauto_load\fR command to
reload the index database from disk.
+.RS
+.PP
+It is not normally necessary to call this command directly; the
+default \fBunknown\fR handler will do so.
+.RE
.TP
\fBauto_mkindex \fIdir pattern pattern ...\fR
.
@@ -156,6 +194,7 @@ listed in the auto-load index, so that fresh copies of them will be
loaded the next time that they are used.
.TP
\fBauto_qualify \fIcommand namespace\fR
+.
Computes a list of fully qualified names for \fIcommand\fR. This list
mirrors the path a standard Tcl interpreter follows for command
lookups: first it looks for the command in the current namespace, and
@@ -175,6 +214,7 @@ performing the actual auto-loading of functions at runtime.
.RE
.TP
\fBtcl_findLibrary \fIbasename version patch initScript enVarName varName\fR
+.
This is a standard search procedure for use by extensions during
their initialization. They call this procedure to look for their
script library in several standard directories.
@@ -197,17 +237,28 @@ relative to the executable file in the current build tree;
relative to the executable file in a parallel build tree.
.TP
\fBparray \fIarrayName\fR ?\fIpattern\fR?
+.
Prints on standard output the names and values of all the elements in the
array \fIarrayName\fR, or just the names that match \fIpattern\fR (using the
matching rules of \fBstring match\fR) and their values if \fIpattern\fR is
given.
\fIArrayName\fR must be an array accessible to the caller of \fBparray\fR.
It may be either local or global.
+The result of this command is the empty string.
+.RS
+.PP
+For example, to print the contents of the \fBtcl_platform\fR array, do:
+.PP
+.CS
+\fBparray\fR tcl_platform
+.CE
+.RE
.SS "WORD BOUNDARY HELPERS"
.PP
These procedures are mainly used internally by Tk.
.TP
\fBtcl_endOfWord \fIstr start\fR
+.
Returns the index of the first end-of-word location that occurs after
a starting index \fIstart\fR in the string \fIstr\fR. An end-of-word
location is defined to be the first non-word character following the
@@ -218,19 +269,35 @@ for more details on how Tcl determines which characters are word
characters.
.TP
\fBtcl_startOfNextWord \fIstr start\fR
+.
Returns the index of the first start-of-word location that occurs
after a starting index \fIstart\fR in the string \fIstr\fR. A
start-of-word location is defined to be the first word character
following a non-word character. Returns \-1 if there are no more
start-of-word locations after the starting point.
+.RS
+.PP
+For example, to print the indices of the starts of each word in a
+string according to platform rules:
+.PP
+.CS
+set theString "The quick brown fox"
+for {set idx 0} {$idx >= 0} {
+ set idx [\fBtcl_startOfNextWord\fR $theString $idx]} {
+ puts "Word start index: $idx"
+}
+.CE
+.RE
.TP
\fBtcl_startOfPreviousWord \fIstr start\fR
+.
Returns the index of the first start-of-word location that occurs
before a starting index \fIstart\fR in the string \fIstr\fR. Returns
\-1 if there are no more start-of-word locations before the starting
point.
.TP
\fBtcl_wordBreakAfter \fIstr start\fR
+.
Returns the index of the first word boundary after the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries after the starting point in the given string. The index
@@ -238,11 +305,47 @@ returned refers to the second character of the pair that comprises a
boundary.
.TP
\fBtcl_wordBreakBefore \fIstr start\fR
+.
Returns the index of the first word boundary before the starting index
\fIstart\fR in the string \fIstr\fR. Returns \-1 if there are no more
boundaries before the starting point in the given string. The index
returned refers to the second character of the pair that comprises a
boundary.
+.TP
+\fBforeachLine \fIvarName filename body\fR
+.VS "Tcl 8.7, TIP 670"
+This reads in the text file named \fIfilename\fR one line at a time
+(using system defaults for reading text files). It writes that line to the
+variable named by \fIvarName\fR and then executes \fIbody\fR for that line.
+The result value of \fIbody\fR is ignored, but \fBerror\fR, \fBreturn\fR,
+\fBbreak\fR and \fBcontinue\fR may be used within it to produce an error,
+return from the calling context, stop the loop, or go to the next line
+respectively.
+The overall result of \fBforeachLine\fR is the empty string (assuming no
+errors from I/O or from evaluating the body of the loop); the file will be
+closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
+.TP
+\fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR?
+.VS "Tcl 8.7, TIP 670"
+Reads in the file named in \fIfilename\fR and returns its contents.
+The second argument says how to read in the file, either as \fBtext\fR
+(using the system defaults for reading text files) or as \fBbinary\fR
+(as uninterpreted bytes). The default is \fBtext\fR. When read as text, this
+will include any trailing newline.
+The file will be closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
+.TP
+\fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR
+.VS "Tcl 8.7, TIP 670"
+Writes the \fIcontents\fR to the file named in \fIfilename\fR.
+The optional second argument says how to write to the file, either as
+\fBtext\fR (using the system defaults for writing text files) or as
+\fBbinary\fR (as uninterpreted bytes). The default is \fBtext\fR.
+If a trailing newline is required, it will need to be provided in
+\fIcontents\fR. The result of this command is the empty string; the file will
+be closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
.SH "VARIABLES"
.PP
The following global variables are defined or used by the procedures in
@@ -251,18 +354,30 @@ commands and packages, and determining what are words.
.SS "AUTOLOADING AND PACKAGE MANAGEMENT VARIABLES"
.TP
\fBauto_execs\fR
+.
Used by \fBauto_execok\fR to record information about whether
particular commands exist as executable files.
+.RS
+.PP
+Not normally usefully accessed directly by user code.
+.RE
.TP
\fBauto_index\fR
+.
Used by \fBauto_load\fR to save the index information read from
disk.
+.RS
+.PP
+Not normally usefully accessed directly by user code.
+.RE
.TP
\fBauto_noexec\fR
+.
If set to any value, then \fBunknown\fR will not attempt to auto-exec
any commands.
.TP
\fBauto_noload\fR
+.
If set to any value, then \fBunknown\fR will not attempt to auto-load
any commands.
.TP
@@ -278,42 +393,70 @@ the parent directory of \fBtcl_library\fR,
the directories listed in the \fBtcl_pkgPath\fR variable.
Additional locations to look for files and package indices should
normally be added to this variable using \fBlappend\fR.
+.RS
+.PP
+For example, to add the \fIlib\fR directory next to the running
+script, you would do:
+.PP
+.CS
+lappend \fBauto_path\fR [file dirname [info script]]/lib
+.CE
+.PP
+Note that if the script uses \fBcd\fR, it is advisable to ensure that
+entries on the \fBauto_path\fR are \fBfile normalize\fRd.
+.RE
.TP
\fBenv(TCL_LIBRARY)\fR
+.
If set, then it specifies the location of the directory containing
library scripts (the value of this variable will be
assigned to the \fBtcl_library\fR variable and therefore returned by
the command \fBinfo library\fR). If this variable is not set then
a default value is used.
+.RS
+.PP
+Use of this environment variable is not recommended outside of testing.
+Tcl installations should already know where to find their own script
+files, as the value is baked in during the build or installation.
+.RE
.TP
\fBenv(TCLLIBPATH)\fR
+.
If set, then it must contain a valid Tcl list giving directories to
search during auto-load operations. Directories must be specified in
Tcl format, using
.QW /
as the path separator, regardless of platform.
This variable is only used when initializing the \fBauto_path\fR variable.
+.RS
+.PP
+A key consequence of this variable is that it gives a way to let the user
+of a script specify the list of places where that script may use
+\fBpackage require\fR to read packages from. It is not normally usefully
+settable within a Tcl script itself \fIexcept\fR to influence where other
+interpreters load from (whether made with \fBinterp create\fR or launched
+as their own threads or subprocesses).
+.RE
.SS "WORD BOUNDARY DETERMINATION VARIABLES"
These variables are only used in the \fBtcl_endOfWord\fR,
\fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR,
\fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands.
.TP
\fBtcl_nonwordchars\fR
+.
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
-considered to be a non-word character. On Windows platforms, spaces,
-tabs, and newlines are considered non-word characters. Under Unix,
-everything but numbers, letters and underscores are considered
-non-word characters.
+considered to be a non-word character. The default value is
+.QW "\\W" .
.TP
\fBtcl_wordchars\fR
+.
This variable contains a regular expression that is used by routines
like \fBtcl_endOfWord\fR to identify whether a character is part of a
word or not. If the pattern matches a character, the character is
-considered to be a word character. On Windows platforms, words are
-comprised of any character that is not a space, tab, or newline. Under
-Unix, words are comprised of numbers, letters or underscores.
+considered to be a word character. The default value is
+.QW "\\w" .
.SH "SEE ALSO"
env(n), info(n), re_syntax(n)
.SH KEYWORDS
diff --git a/doc/lindex.n b/doc/lindex.n
index 5b04b26..d4d845d 100644
--- a/doc/lindex.n
+++ b/doc/lindex.n
@@ -13,7 +13,7 @@
.SH NAME
lindex \- Retrieve an element from a list
.SH SYNOPSIS
-\fBlindex \fIlist ?index ...?\fR
+\fBlindex \fIlist\fR ?\fIindex ...\fR?
.BE
.SH DESCRIPTION
.PP
@@ -115,8 +115,9 @@ set idx 3
\fI\(-> f\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), linsert(n), llength(n), lsearch(n),
-lset(n), lsort(n), lrange(n), lreplace(n),
+list(n), lappend(n), lassign(n), ledit(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, index, list
diff --git a/doc/link.n b/doc/link.n
new file mode 100644
index 0000000..a11c261
--- /dev/null
+++ b/doc/link.n
@@ -0,0 +1,124 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 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.
+'\"
+.TH link n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+link \- create link from command to method of object
+.SH SYNOPSIS
+.nf
+package require tcl::oo
+
+\fBlink\fR \fImethodName\fR ?\fI...\fR?
+\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBlink\fR command is available within methods. It takes a series of one
+or more method names (\fImethodName ...\fR) and/or pairs of command- and
+method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods
+available as commands without requiring the explicit use of the name of the
+object or the \fBmy\fR command. The method does not need to exist at the time
+that the link is made; if the link command is invoked when the method does not
+exist, the standard \fBunknown\fR method handling system is used.
+.PP
+The command name under which the method becomes available defaults to the
+method name, except where explicitly specified through an alias/method pair.
+Formally, every argument must be a list; if the list has two elements, the
+first element is the name of the command to create and the second element is
+the name of the method of the current object to which the command links;
+otherwise, the name of the command and the name of the method are the same
+string (the first element of the list).
+.PP
+If the name of the command is not a fully-qualified command name, it will be
+resolved with respect to the current namespace (i.e., the object namespace).
+.SH EXAMPLES
+This demonstrates linking a single method in various ways. First it makes a
+simple link, then a renamed link, then an external link. Note that the method
+itself is unexported, but that it can still be called directly from outside
+the class.
+.PP
+.CS
+oo::class create ABC {
+ method Foo {} {
+ puts "This is Foo in [self]"
+ }
+
+ constructor {} {
+ \fBlink\fR Foo
+ # The method Foo is now directly accessible as Foo here
+ \fBlink\fR {bar Foo}
+ # The method Foo is now directly accessible as bar
+ \fBlink\fR {::ExternalCall Foo}
+ # The method Foo is now directly accessible in the global
+ # namespace as ExternalCall
+ }
+
+ method grill {} {
+ puts "Step 1:"
+ Foo
+ puts "Step 2:"
+ bar
+ }
+}
+
+ABC create abc
+abc grill
+ \fI\(-> Step 1:\fR
+ \fI\(-> This is Foo in ::abc\fR
+ \fI\(-> Step 2:\fR
+ \fI\(-> This is Foo in ::abc\fR
+# Direct access via the linked command
+puts "Step 3:"; ExternalCall
+ \fI\(-> Step 3:\fR
+ \fI\(-> This is Foo in ::abc\fR
+.CE
+.PP
+This example shows that multiple linked commands can be made in a call to
+\fBlink\fR, and that they can handle arguments.
+.PP
+.CS
+oo::class create Ex {
+ constructor {} {
+ \fBlink\fR a b c
+ # The methods a, b, and c (defined below) are all now
+ # directly accessible within methods under their own names.
+ }
+
+ method a {} {
+ puts "This is a"
+ }
+ method b {x} {
+ puts "This is b($x)"
+ }
+ method c {y z} {
+ puts "This is c($y,$z)"
+ }
+
+ method call {p q r} {
+ a
+ b $p
+ c $q $r
+ }
+}
+
+set o [Ex new]
+$o 3 5 7
+ \fI\(-> This is a\fR
+ \fI\(-> This is b(3)\fR
+ \fI\(-> This is c(5,7)\fR
+.CE
+.SH "SEE ALSO"
+interp(n), my(n), oo::class(n), oo::define(n)
+.SH KEYWORDS
+command, method, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/linsert.n b/doc/linsert.n
index 91db726..014f9cd 100644
--- a/doc/linsert.n
+++ b/doc/linsert.n
@@ -45,8 +45,9 @@ set newList [\fBlinsert\fR $midList end-1 lazy]
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), llength(n), lsearch(n),
-lset(n), lsort(n), lrange(n), lreplace(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, insert, list
diff --git a/doc/list.n b/doc/list.n
index a182fc8..08a6fe7 100644
--- a/doc/list.n
+++ b/doc/list.n
@@ -46,9 +46,9 @@ while \fBconcat\fR with the same arguments will return
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
-lappend(n), lindex(n), linsert(n), llength(n), lrange(n),
-lrepeat(n),
-lreplace(n), lsearch(n), lset(n), lsort(n)
+lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, quoting
'\"Local Variables:
diff --git a/doc/llength.n b/doc/llength.n
index 79f93c0..574834f 100644
--- a/doc/llength.n
+++ b/doc/llength.n
@@ -49,7 +49,12 @@ An empty list is not necessarily an empty string:
1,0
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), lsearch(n),
-lset(n), lsort(n), lrange(n), lreplace(n)
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, length
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/lmap.n b/doc/lmap.n
index 1a7858d..36a0c7c 100644
--- a/doc/lmap.n
+++ b/doc/lmap.n
@@ -77,7 +77,10 @@ set prefix [\fBlmap\fR x $values {expr {
# The value of prefix is "8 7 6 5 4"
.CE
.SH "SEE ALSO"
-break(n), continue(n), for(n), foreach(n), while(n)
+break(n), continue(n), for(n), foreach(n), while(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
foreach, iteration, list, loop, map
'\" Local Variables:
diff --git a/doc/load.n b/doc/load.n
index 54d90a3..f970024 100644
--- a/doc/load.n
+++ b/doc/load.n
@@ -56,7 +56,7 @@ on Safe\-Tcl, see the \fBsafe\fR manual entry.
The initialization procedure must match the following prototype:
.PP
.CS
-typedef int \fBTcl_PackageInitProc\fR(
+typedef int \fBTcl_LibraryInitProc\fR(
Tcl_Interp *\fIinterp\fR);
.CE
.PP
@@ -79,7 +79,7 @@ Tcl's unloading mechanism.
.PP
The \fBload\fR command also supports libraries that are statically
linked with the application, if those libraries have been registered
-by calling the \fBTcl_StaticPackage\fR procedure.
+by calling the \fBTcl_StaticLibrary\fR procedure.
If \fIfileName\fR is an empty string, then \fIprefix\fR must
be specified.
.PP
@@ -88,7 +88,8 @@ Tcl tries to guess the prefix. This may be done differently on
different platforms. The default guess, which is used on most
UNIX platforms, is to take the last element of
\fIfileName\fR, strip off the first three characters if they
-are \fBlib\fR, and use any following alphabetic and
+are \fBlib\fR, then strip off the next three characters if they
+are \fBtcl\fR, and use any following alphabetic and
underline characters, converted to titlecase as the prefix.
For example, the command \fBload libxyz4.2.so\fR uses the prefix
\fBXyz\fR and the command \fBload bin/last.so {}\fR uses the
@@ -97,7 +98,7 @@ prefix \fBLast\fR.
If \fIfileName\fR is an empty string, then \fIprefix\fR must
be specified.
The \fBload\fR command first searches for a statically loaded library
-(one that has been registered by calling the \fBTcl_StaticPackage\fR
+(one that has been registered by calling the \fBTcl_StaticLibrary\fR
procedure) by that name; if one is found, it is used.
Otherwise, the \fBload\fR command searches for a dynamically loaded
library by that name, and uses it if it is found. If several
@@ -187,7 +188,7 @@ switch $tcl_platform(platform) {
foo
.CE
.SH "SEE ALSO"
-info sharedlibextension, package(n), Tcl_StaticPackage(3), safe(n)
+info sharedlibextension, package(n), Tcl_StaticLibrary(3), safe(n)
.SH KEYWORDS
binary code, dynamic library, load, safe interpreter, shared library
'\"Local Variables:
diff --git a/doc/lpop.n b/doc/lpop.n
new file mode 100644
index 0000000..2a464eb
--- /dev/null
+++ b/doc/lpop.n
@@ -0,0 +1,97 @@
+'\"
+'\" Copyright (c) 2018 Peter Spjuth. 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 lpop n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lpop \- Get and remove an element in a list
+.SH SYNOPSIS
+\fBlpop \fIvarName ?index ...?\fR
+.BE
+.SH DESCRIPTION
+.PP
+The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which
+it interprets as the name of a variable containing a Tcl list.
+It also accepts one or more \fIindices\fR into
+the list. If no indices are presented, it defaults to "end".
+.PP
+When presented with a single index, the \fBlpop\fR command
+addresses the \fIindex\fR'th element in it, removes if from the list
+and returns the element.
+.PP
+If \fIindex\fR is negative or greater or equal than the number
+of elements in \fI$varName\fR, then an error occurs.
+.PP
+The interpretation of each simple \fIindex\fR value is the same as
+for the command \fBstring index\fR, supporting simple index
+arithmetic and indices relative to the end of the list.
+.PP
+If additional \fIindex\fR arguments are supplied, then each argument is
+used in turn to address an element within a sublist designated
+by the previous indexing operation,
+allowing the script to remove elements in sublists.
+The command,
+.PP
+.CS
+\fBlpop\fR a 1 2
+.CE
+.PP
+gets and removes element 2 of sublist 1.
+.PP
+.SH EXAMPLES
+.PP
+In each of these examples, the initial value of \fIx\fR is:
+.PP
+.CS
+set x [list [list a b c] [list d e f] [list g h i]]
+ \fI\(-> {a b c} {d e f} {g h i}\fR
+.CE
+.PP
+The indicated value becomes the new value of \fIx\fR
+(except in the last case, which is an error which leaves the value of
+\fIx\fR unchanged.)
+.PP
+.CS
+\fBlpop\fR x 0
+ \fI\(-> {d e f} {g h i}\fR
+\fBlpop\fR x 2
+ \fI\(-> {a b c} {d e f}\fR
+\fBlpop\fR x end
+ \fI\(-> {a b c} {d e f}\fR
+\fBlpop\fR x end-1
+ \fI\(-> {a b c} {g h i}\fR
+\fBlpop\fR x 2 1
+ \fI\(-> {a b c} {d e f} {g i}\fR
+\fBlpop\fR x 2 3 j
+ \fI\(-> list index out of range\fR
+.CE
+.PP
+In the following examples, the initial value of \fIx\fR is:
+.PP
+.CS
+set x [list [list [list a b] [list c d]] \e
+ [list [list e f] [list g h]]]
+ \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR
+.CE
+.PP
+The indicated value becomes the new value of \fIx\fR.
+.PP
+.CS
+\fBlpop\fR x 1 1 0
+ \fI\(-> {{a b} {c d}} {{e f} h}\fR
+.CE
+.SH "SEE ALSO"
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
+string(n)
+.SH KEYWORDS
+element, index, list, remove, pop, stack, queue
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/doc/lrange.n b/doc/lrange.n
index ffa6dba..38c4abf 100644
--- a/doc/lrange.n
+++ b/doc/lrange.n
@@ -71,8 +71,13 @@ elements to
{elements to}
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lset(n), lreplace(n), lsort(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, range, sublist
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/lremove.n b/doc/lremove.n
new file mode 100644
index 0000000..bd4a5eb
--- /dev/null
+++ b/doc/lremove.n
@@ -0,0 +1,57 @@
+'\"
+'\" Copyright (c) 2019 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH lremove n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lremove \- Remove elements from a list by index
+.SH SYNOPSIS
+\fBlremove \fIlist\fR ?\fIindex ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+\fBlremove\fR returns a new list formed by simultaneously removing zero or
+more elements of \fIlist\fR at each of the indices given by an arbitrary number
+of \fIindex\fR arguments. The indices may be in any order and may be repeated;
+the element at index will only be removed once. The index values are
+interpreted the same as index values for the command \fBstring index\fR,
+supporting simple index arithmetic and indices relative to the end of the
+list. 0 refers to the first element of the list, and \fBend\fR refers to the
+last element of the list.
+.SH EXAMPLES
+.PP
+Removing the third element of a list:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} 2
+a b d e
+.CE
+.PP
+Removing two elements from a list:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} end-1 1
+a c e
+.CE
+.PP
+Removing the same element indicated in two different ways:
+.PP
+.CS
+% \fBlremove\fR {a b c d e} 2 end-2
+a b d e
+.CE
+.SH "SEE ALSO"
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
+.SH KEYWORDS
+element, list, remove
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/lrepeat.n b/doc/lrepeat.n
index 52a17f0..cd672db 100644
--- a/doc/lrepeat.n
+++ b/doc/lrepeat.n
@@ -32,7 +32,12 @@ is identical to \fBlist element ...\fR.
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), linsert(n), llength(n), lset(n)
-
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, index, list
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/lreplace.n b/doc/lreplace.n
index 32b7356..47d33f9 100644
--- a/doc/lreplace.n
+++ b/doc/lreplace.n
@@ -95,8 +95,9 @@ a b c d e f g h i
.CE
.VE TIP505
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lset(n), lrange(n), lsort(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n),
+lreverse(n), lsearch(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
diff --git a/doc/lreverse.n b/doc/lreverse.n
index a2a02a5..bb0703d 100644
--- a/doc/lreverse.n
+++ b/doc/lreverse.n
@@ -25,8 +25,9 @@ input list, \fIlist\fR, except with the elements in the reverse order.
\fI\(-> f e {c d} b a\fR
.CE
.SH "SEE ALSO"
-list(n), lsearch(n), lsort(n)
-
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lsearch(n), lseq(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, reverse
'\" Local Variables:
diff --git a/doc/lsearch.n b/doc/lsearch.n
index efe1792..dc6d1f7 100644
--- a/doc/lsearch.n
+++ b/doc/lsearch.n
@@ -135,7 +135,6 @@ The list elements are sorted in increasing order. This option is only
meaningful when used with \fB\-sorted\fR.
.TP
\fB\-bisect\fR
-.VS 8.6
Inexact search when the list elements are in sorted order. For an increasing
list the last index where the element is less than or equal to the pattern
is returned. For a decreasing list the last index where the element is greater
@@ -143,12 +142,24 @@ than or equal to the pattern is returned. If the pattern is before the first
element or the list is empty, -1 is returned.
This option implies \fB\-sorted\fR and cannot be used with either \fB\-all\fR
or \fB\-not\fR.
-.VE 8.6
.SS "NESTED LIST OPTIONS"
.PP
These options are used to search lists of lists. They may be used
with any other options.
.TP
+\fB\-stride\0\fIstrideLength\fR
+.
+If this option is specified, the list is treated as consisting of
+groups of \fIstrideLength\fR elements and the groups are searched by
+either their first element or, if the \fB\-index\fR option is used,
+by the element within each group given by the first index passed to
+\fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting
+index always points to the first element in a group.
+.PP
+The list length must be an integer multiple of \fIstrideLength\fR, which
+in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and
+indicates no grouping.
+.TP
\fB\-index\fR\0\fIindexList\fR
.
This option is designed for use when searching within nested lists.
@@ -209,9 +220,18 @@ It is also possible to search inside elements:
\fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc*
\fI\(-> {a abc} {b bcd}\fR
.CE
+.PP
+The same thing for a flattened list:
+.PP
+.CS
+\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc*
+ \fI\(-> {a abc b bcd}\fR
+.CE
.SH "SEE ALSO"
-foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
-lset(n), lsort(n), lrange(n), lreplace(n),
+foreach(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lseq(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
binary search, linear search,
diff --git a/doc/lseq.n b/doc/lseq.n
new file mode 100644
index 0000000..08be86f
--- /dev/null
+++ b/doc/lseq.n
@@ -0,0 +1,99 @@
+'\"
+'\" Copyright (c) 2022 Eric Taylor. 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 lseq n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+lseq \- Build a numeric sequence returned as a list
+.SH SYNOPSIS
+\fBlseq \fIstart \fR?(\fB..\fR|\fBto\fR)? \fIend\fR ??\fBby\fR? \fIstep\fR?
+
+\fBlseq \fIstart \fBcount\fR \fIcount\fR ??\fBby\fR? \fIstep\fR?
+
+\fBlseq \fIcount\fR ?\fBby \fIstep\fR?
+.BE
+.SH DESCRIPTION
+.PP
+The \fBlseq\fR command creates a sequence of numeric values using the given
+parameters \fIstart\fR, \fIend\fR, and \fIstep\fR.
+The \fIoperation\fR argument
+.QW \fB..\fR
+or
+.QW \fBto\fR
+defines an inclusive range; if it is omitted, the range is exclusive.
+The \fBcount\fR option is used to define a count of the number of elements in
+the list.
+The \fIstep\fR (which may be preceded by \fBby\fR) is 1 if not provided.
+The short form with a
+single \fIcount\fR value will create a range from 0 to \fIcount\fR-1 (i.e.,
+\fIcount\fR values).
+.PP
+The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR,
+can also be a valid expression. the \fBlseq\fR command will evaluate the
+expression (as if with \fBexpr\fR)
+and use the numeric result, or return an error as with any invalid argument
+value; a non-numeric expression result will result in an error.
+
+.SH EXAMPLES
+.CS
+.\"
+\fBlseq\fR 3
+ \fI\(-> 0 1 2\fR
+
+\fBlseq\fR 3 0
+ \fI\(-> 3 2 1 0\fR
+
+\fBlseq\fR 10 .. 1 by -2
+ \fI\(-> 10 8 6 4 2\fR
+
+set l [\fBlseq\fR 0 -5]
+ \fI\(-> 0 -1 -2 -3 -4 -5\fR
+
+foreach i [\fBlseq\fR [llength $l]] {
+ puts l($i)=[lindex $l $i]
+}
+ \fI\(-> l(0)=0\fR
+ \fI\(-> l(1)=-1\fR
+ \fI\(-> l(2)=-2\fR
+ \fI\(-> l(3)=-3\fR
+ \fI\(-> l(4)=-4\fR
+ \fI\(-> l(5)=-5\fR
+
+foreach i [\fBlseq\fR {[llength $l]-1} 0] {
+ puts l($i)=[lindex $l $i]
+}
+ \fI\(-> l(5)=-5\fR
+ \fI\(-> l(4)=-4\fR
+ \fI\(-> l(3)=-3\fR
+ \fI\(-> l(2)=-2\fR
+ \fI\(-> l(1)=-1\fR
+ \fI\(-> l(0)=0\fR
+
+set i 17
+ \fI\(-> 17\fR
+if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i < 50)
+ puts "Ok"
+} else {
+ puts "outside :("
+}
+ \fI\(-> Ok\fR
+
+set sqrs [lmap i [\fBlseq\fR 1 10] { expr {$i*$i} }]
+ \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR
+.\"
+.CE
+.SH "SEE ALSO"
+foreach(n), list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n),
+llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
+lreverse(n), lsearch(n), lset(n), lsort(n)
+.SH KEYWORDS
+element, index, list
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/lset.n b/doc/lset.n
index e509641..e2e1590 100644
--- a/doc/lset.n
+++ b/doc/lset.n
@@ -136,8 +136,9 @@ The indicated return value also becomes the new value of \fIx\fR.
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lsort(n), lrange(n), lreplace(n),
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lsort(n)
string(n)
.SH KEYWORDS
element, index, list, replace, set
diff --git a/doc/lsort.n b/doc/lsort.n
index c3245b2..1695ea8 100644
--- a/doc/lsort.n
+++ b/doc/lsort.n
@@ -221,7 +221,6 @@ Sorting using indices:
{e 1} {d 2} { c 3} {b 4} {a 5}
.CE
.PP
-.VS 8.6
Sorting a dictionary:
.PP
.CS
@@ -239,7 +238,6 @@ Sorting using striding and multiple indices:
{{Bob Smith} 25 Audi {Jane Doe} 40 Ford}
{{Jane Doe} 40 Ford {Bob Smith} 25 Audi}
.CE
-.VE 8.6
.PP
Stripping duplicate values using sorting:
.PP
@@ -266,8 +264,9 @@ More complex sorting using a comparison function:
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
-list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
-lset(n), lrange(n), lreplace(n)
+list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n),
+lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
+lreverse(n), lsearch(n), lseq(n), lset(n)
.SH KEYWORDS
element, list, order, sort
'\" Local Variables:
diff --git a/doc/mathfunc.n b/doc/mathfunc.n
index 7a16961..004b7e3 100644
--- a/doc/mathfunc.n
+++ b/doc/mathfunc.n
@@ -13,7 +13,7 @@
.SH NAME
mathfunc \- Mathematical functions for Tcl expressions
.SH SYNOPSIS
-package require \fBTcl 8.5\fR
+package require \fBTcl 8.5-\fR
.sp
\fB::tcl::mathfunc::abs\fR \fIarg\fR
.br
@@ -47,8 +47,24 @@ package require \fBTcl 8.5\fR
.br
\fB::tcl::mathfunc::int\fR \fIarg\fR
.br
+.VS "8.7, TIP 521"
+\fB::tcl::mathfunc::isfinite\fR \fIarg\fR
+.br
+\fB::tcl::mathfunc::isinf\fR \fIarg\fR
+.br
+\fB::tcl::mathfunc::isnan\fR \fIarg\fR
+.br
+\fB::tcl::mathfunc::isnormal\fR \fIarg\fR
+.VE "8.7, TIP 521"
+.br
\fB::tcl::mathfunc::isqrt\fR \fIarg\fR
.br
+.VS "8.7, TIP 521"
+\fB::tcl::mathfunc::issubnormal\fR \fIarg\fR
+.br
+\fB::tcl::mathfunc::isunordered\fR \fIx y\fR
+.VE "8.7, TIP 521"
+.br
\fB::tcl::mathfunc::log\fR \fIarg\fR
.br
\fB::tcl::mathfunc::log10\fR \fIarg\fR
@@ -92,15 +108,17 @@ directly.
Tcl supports the following mathematical functions in expressions, all
of which work solely with floating-point numbers unless otherwise noted:
.DS
-.ta 3c 6c 9c
+.ta 3.2c 6.4c 9.6c
\fBabs\fR \fBacos\fR \fBasin\fR \fBatan\fR
\fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR
\fBcosh\fR \fBdouble\fR \fBentier\fR \fBexp\fR
\fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR
-\fBisqrt\fR \fBlog\fR \fBlog10\fR \fBmax\fR
-\fBmin\fR \fBpow\fR \fBrand\fR \fBround\fR
-\fBsin\fR \fBsinh\fR \fBsqrt\fR \fBsrand\fR
-\fBtan\fR \fBtanh\fR \fBwide\fR
+\fBisfinite\fR \fBisinf\fR \fBisnan\fR \fBisnormal\fR
+\fBisqrt\fR \fBissubnormal\fR \fBisunordered\fR \fBlog\fR
+\fBlog10\fR \fBmax\fR \fBmin\fR \fBpow\fR
+\fBrand\fR \fBround\fR \fBsin\fR \fBsinh\fR
+\fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR
+\fBwide\fR
.DE
.PP
In addition to these predefined functions, applications may
@@ -209,6 +227,34 @@ to the machine word size are returned as an integer value. For reference,
the number of bytes in the machine word are stored in the \fBwordSize\fR
element of the \fBtcl_platform\fR array.
.TP
+\fBisfinite \fIarg\fR
+.VS "8.7, TIP 521"
+Returns 1 if the floating-point number \fIarg\fR is finite. That is, if it is
+zero, subnormal, or normal. Returns 0 if the number is infinite or NaN. Throws
+an error if \fIarg\fR cannot be promoted to a floating-point value.
+.VE "8.7, TIP 521"
+.TP
+\fBisinf \fIarg\fR
+.VS "8.7, TIP 521"
+Returns 1 if the floating-point number \fIarg\fR is infinite. Returns 0 if the
+number is finite or NaN. Throws an error if \fIarg\fR cannot be promoted to a
+floating-point value.
+.VE "8.7, TIP 521"
+.TP
+\fBisnan \fIarg\fR
+.VS "8.7, TIP 521"
+Returns 1 if the floating-point number \fIarg\fR is Not-a-Number. Returns 0 if
+the number is finite or infinite. Throws an error if \fIarg\fR cannot be
+promoted to a floating-point value.
+.VE "8.7, TIP 521"
+.TP
+\fBisnormal \fIarg\fR
+.VS "8.7, TIP 521"
+Returns 1 if the floating-point number \fIarg\fR is normal. Returns 0 if the
+number is zero, subnormal, infinite or NaN. Throws an error if \fIarg\fR
+cannot be promoted to a floating-point value.
+.VE "8.7, TIP 521"
+.TP
\fBisqrt \fIarg\fR
.
Computes the integer part of the square root of \fIarg\fR. \fIArg\fR must be
@@ -216,6 +262,23 @@ a positive value, either an integer or a floating point number.
Unlike \fBsqrt\fR, which is limited to the precision of a floating point
number, \fIisqrt\fR will return a result of arbitrary precision.
.TP
+\fBissubnormal \fIarg\fR
+.VS "8.7, TIP 521"
+Returns 1 if the floating-point number \fIarg\fR is subnormal, i.e., the
+result of gradual underflow. Returns 0 if the number is zero, normal, infinite
+or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point
+value.
+.VE "8.7, TIP 521"
+.TP
+\fBisunordered \fIx y\fR
+.VS "8.7, TIP 521"
+Returns 1 if \fIx\fR and \fIy\fR cannot be compared for ordering, that is, if
+either one is NaN. Returns 0 if both values can be ordered, that is, if they
+are both chosen from among the set of zero, subnormal, normal and infinite
+values. Throws an error if either \fIx\fR or \fIy\fR cannot be promoted to a
+floating-point value.
+.VE "8.7, TIP 521"
+.TP
\fBlog \fIarg\fR
.
Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a
@@ -292,12 +355,12 @@ The argument may be any numeric value. The integer part of \fIarg\fR
is determined, and then the low order 64 bits of that integer value
are returned as an integer value.
.SH "SEE ALSO"
-expr(n), mathop(n), namespace(n)
+expr(n), fpclassify(n), mathop(n), namespace(n)
.SH "COPYRIGHT"
.nf
Copyright \(co 1993 The Regents of the University of California.
Copyright \(co 1994-2000 Sun Microsystems Incorporated.
-Copyright \(co 2005, 2006 Kevin B. Kenny <kennykb@acm.org>.
+Copyright \(co 2005-2006 Kevin B. Kenny <kennykb@acm.org>.
.fi
'\" Local Variables:
'\" mode: nroff
diff --git a/doc/mathop.n b/doc/mathop.n
index 84cf308..3a13456 100644
--- a/doc/mathop.n
+++ b/doc/mathop.n
@@ -11,7 +11,7 @@
.SH NAME
mathop \- Mathematical operators as Tcl commands
.SH SYNOPSIS
-package require \fBTcl 8.5\fR
+package require \fBTcl 8.5-\fR
.sp
\fB::tcl::mathop::!\fR \fInumber\fR
.br
@@ -55,6 +55,16 @@ package require \fBTcl 8.5\fR
.br
\fB::tcl::mathop::ne\fR \fIarg arg\fR
.br
+.VS "8.7, TIP461"
+\fB::tcl::mathop::lt\fR ?\fIarg\fR ...?
+.br
+\fB::tcl::mathop::le\fR ?\fIarg\fR ...?
+.br
+\fB::tcl::mathop::gt\fR ?\fIarg\fR ...?
+.br
+\fB::tcl::mathop::ge\fR ?\fIarg\fR ...?
+.VE "8.7, TIP461"
+.br
\fB::tcl::mathop::in\fR \fIarg list\fR
.br
\fB::tcl::mathop::ni\fR \fIarg list\fR
@@ -76,7 +86,8 @@ The following operator commands are supported:
\fB/\fR \fB%\fR \fB**\fR \fB&\fR \fB|\fR
\fB^\fR \fB>>\fR \fB<<\fR \fB==\fR \fBeq\fR
\fB!=\fR \fBne\fR \fB<\fR \fB<=\fR \fB>\fR
-\fB>=\fR \fBin\fR \fBni\fR
+\fB>=\fR \fBin\fR \fBni\fR \fBlt\fR \fBle\fR
+\fBgt\fR \fBge\fR
.DE
.SS "MATHEMATICAL OPERATORS"
.PP
@@ -192,8 +203,8 @@ after the first having to be strictly more than the one preceding it.
Comparisons are performed preferentially on the numeric values, and are
otherwise performed using UNICODE string comparison. If fewer than two
arguments are present, this operation always returns a true value. When the
-arguments are numeric but should be compared as strings, the \fBstring
-compare\fR command should be used instead.
+arguments are numeric but should be compared as strings, the \fBlt\fR
+operator or the \fBstring compare\fR command should be used instead.
.TP
\fB<=\fR ?\fIarg\fR ...?
.
@@ -202,8 +213,8 @@ after the first having to be equal to or more than the one preceding it.
Comparisons are performed preferentially on the numeric values, and are
otherwise performed using UNICODE string comparison. If fewer than two
arguments are present, this operation always returns a true value. When the
-arguments are numeric but should be compared as strings, the \fBstring
-compare\fR command should be used instead.
+arguments are numeric but should be compared as strings, the \fBle\fR
+operator or the \fBstring compare\fR command should be used instead.
.TP
\fB>\fR ?\fIarg\fR ...?
.
@@ -212,8 +223,8 @@ after the first having to be strictly less than the one preceding it.
Comparisons are performed preferentially on the numeric values, and are
otherwise performed using UNICODE string comparison. If fewer than two
arguments are present, this operation always returns a true value. When the
-arguments are numeric but should be compared as strings, the \fBstring
-compare\fR command should be used instead.
+arguments are numeric but should be compared as strings, the \fBgt\fR
+operator or the \fBstring compare\fR command should be used instead.
.TP
\fB>=\fR ?\fIarg\fR ...?
.
@@ -222,8 +233,40 @@ after the first having to be equal to or less than the one preceding it.
Comparisons are performed preferentially on the numeric values, and are
otherwise performed using UNICODE string comparison. If fewer than two
arguments are present, this operation always returns a true value. When the
-arguments are numeric but should be compared as strings, the \fBstring
-compare\fR command should be used instead.
+arguments are numeric but should be compared as strings, the \fBge\fR
+operator or the \fBstring compare\fR command should be used instead.
+.TP
+\fBlt\fR ?\fIarg\fR ...?
+.VS "8.7, TIP461"
+Returns whether the arbitrarily-many arguments are ordered, with each argument
+after the first having to be strictly more than the one preceding it.
+Comparisons are performed using UNICODE string comparison. If fewer than two
+arguments are present, this operation always returns a true value.
+.VE "8.7, TIP461"
+.TP
+\fBle\fR ?\fIarg\fR ...?
+.VS "8.7, TIP461"
+Returns whether the arbitrarily-many arguments are ordered, with each argument
+after the first having to be equal to or strictly more than the one preceding it.
+Comparisons are performed using UNICODE string comparison. If fewer than two
+arguments are present, this operation always returns a true value.
+.VE "8.7, TIP461"
+.TP
+\fBgt\fR ?\fIarg\fR ...?
+.VS "8.7, TIP461"
+Returns whether the arbitrarily-many arguments are ordered, with each argument
+after the first having to be strictly less than the one preceding it.
+Comparisons are performed using UNICODE string comparison. If fewer than two
+arguments are present, this operation always returns a true value.
+.VE "8.7, TIP461"
+.TP
+\fBge\fR ?\fIarg\fR ...?
+.VS "8.7, TIP461"
+Returns whether the arbitrarily-many arguments are ordered, with each argument
+after the first having to be equal to or strictly less than the one preceding it.
+Comparisons are performed using UNICODE string comparison. If fewer than two
+arguments are present, this operation always returns a true value.
+.VE "8.7, TIP461"
.SS "BIT-WISE OPERATORS"
.PP
The behaviors of the bit-wise operator commands (all of which only operate on
@@ -299,8 +342,12 @@ set gotIt [\fBin\fR 3 $list]
\fI# Test to see if a value is within some defined range\fR
set inRange [\fB<=\fR 1 $x 5]
-\fI# Test to see if a list is sorted\fR
+\fI# Test to see if a list is numerically sorted\fR
set sorted [\fB<=\fR {*}$list]
+
+\fI# Test to see if a list is lexically sorted\fR
+set alphaList {a b c d e f}
+set sorted [\fBle\fR {*}$alphaList]
.CE
.SH "SEE ALSO"
expr(n), mathfunc(n), namespace(n)
diff --git a/doc/msgcat.n b/doc/msgcat.n
index 9d7291a..c39dc87 100644
--- a/doc/msgcat.n
+++ b/doc/msgcat.n
@@ -11,9 +11,9 @@
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
-\fBpackage require Tcl 8.5\fR
+\fBpackage require tcl 8.7\fR
.sp
-\fBpackage require msgcat 1.6\fR
+\fBpackage require msgcat 1.7\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
@@ -23,9 +23,15 @@ msgcat \- Tcl message catalog
\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
.VE "TIP 412"
.sp
+.VS "TIP 490"
+\fB::msgcat::mcpackagenamespaceget\fR
+.VE "TIP 490"
+.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
-\fB::msgcat::mcpreferences\fR
+.VS "TIP 499"
+\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
+.VE "TIP 499"
.sp
.VS "TIP 412"
\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR?
@@ -50,6 +56,10 @@ msgcat \- Tcl message catalog
.sp
\fB::msgcat::mcforgetpackage\fR
.VE "TIP 412"
+.sp
+.VS "TIP 499"
+\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR?
+.VS "TIP 499"
.BE
.SH DESCRIPTION
.PP
@@ -63,7 +73,7 @@ the application source code. New languages
or locales may be provided by adding a new file to
the message catalog.
.PP
-\fBmsgcat\fR distinguises packages by its namespace.
+\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.
@@ -71,6 +81,11 @@ In \fBmsgcat\fR, there is a global locale initialized by the system locale of th
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.
+.PP
+.VS tip490
+Object oriented programming is supported by the use of a package namespace.
+.VE tip490
+.PP
.SH COMMANDS
.TP
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
@@ -95,6 +110,17 @@ use the result. If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.RE
+.VS "TIP 490"
+.TP
+\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR?
+.
+Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument.
+.PP
+.RS
+\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller.
+An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below.
+.RE
+.PP
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.
@@ -102,29 +128,69 @@ Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string. This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
+.VS "TIP 412"
.TP
-\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
+\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR
.
-.VS "TIP 412"
Return true, if there is a translation for the given \fIsrc-string\fR.
.PP
.RS
The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces.
.PP
It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used).
-.RE
+.PP
.VE "TIP 412"
+.VS "TIP 490"
+An explicit package namespace may be specified by the option \fB-namespace\fR.
+The namespace of the caller is used if not explicitly specified.
+.RE
+.PP
+.VE "TIP 490"
+.VS "TIP 490"
+.TP
+\fB::msgcat::mcpackagenamespaceget\fR
+.
+Return the package namespace of the caller.
+This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR.
+.PP
+.RS
+Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown:
+.CS
+proc ::tooltip::tooltip {widget message} {
+ ...
+ set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}]
+ ...
+ bind $widget [list ::tooltip::show $widget $messagenamespace $message]
+}
+
+proc ::tooltip::show {widget messagenamespace message} {
+ ...
+ set message [::msgcat::mcn $messagenamespace $message]
+ ...
+}
+.CE
+.RE
+.PP
+.VE "TIP 490"
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.
-This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR
-is omitted, the current locale is returned, otherwise the current locale
-is set to \fInewLocale\fR. msgcat stores and compares the locale in a
+If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale
+is set to \fInewLocale\fR.
+.PP
+.RS
+If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set.
+For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR.
+.PP
+The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR].
+.PP
+The current locale is always the first element of the list returned by \fBmcpreferences\fR.
+.PP
+msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment. See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
-.RS
.PP
.VS "TIP 412"
If the locale is set, the preference list of locales is evaluated.
@@ -132,25 +198,33 @@ Locales in this list are loaded now, if not jet loaded.
.VE "TIP 412"
.RE
.TP
-\fB::msgcat::mcpreferences\fR
+\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
.
-Returns an ordered list of the locales preferred by
-the user, based on the user's language specification.
-The list is ordered from most specific to least
-preference. The list is derived from the current
-locale set in msgcat by \fB::msgcat::mclocale\fR, and
-cannot be set independently. For example, if the
-current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
-returns \fB{en_us_funky en_us en {}}\fR.
+Without arguments, returns an ordered list of the locales preferred by
+the user.
+The list is ordered from most specific to least preference.
+.PP
+.VS "TIP 499"
+.RS
+A set of locale preferences may be given to set the list of locale preferences.
+The current locale is also set, which is the first element of the locale preferences list.
+.PP
+Locale preferences are loaded now, if not jet loaded.
+.PP
+As an example, the user may prefer French or English text. This may be configured by:
+.CS
+::msgcat::mcpreferences fr en {}
+.CE
+.RE
+.PP
+.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 \fBget\fR returns the list of currently loaded locales.
-.PP
-The subcommand \fBpresent\fR requires the argument \fIlocale\fR and returns true, if this locale is loaded.
+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
@@ -159,7 +233,7 @@ The subcommand \fBclear\fR removes all locales and their data, which are not in
.
.VS "TIP 412"
Searches the specified directory for files that match
-the language specifications returned by \fB::msgcat::mcloadedlocales get\fR
+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
@@ -232,6 +306,22 @@ Note that this routine is only called if the concerned package did not set a pac
The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations.
.VE "TIP 412"
.PP
+.VS "TIP 499"
+.TP
+\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR
+.
+Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR.
+An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french:
+.CS
+% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH]
+fr_ch fr de_ch de {}
+.CE
+.TP
+\fB::msgcat::mcutil getsystemlocale\fR
+.
+The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR.
+.VE "TIP 499"
+.PP
.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
@@ -437,7 +527,7 @@ formatting substitution is done directly.
# human-oriented versions by \fBmsgcat::mcset\fR
.CE
.VS "TIP 412"
-.SH Package private locale
+.SH "PACKAGE PRIVATE LOCALE"
.PP
A package using \fBmsgcat\fR may choose to use its own package private
locale and its own set of loaded locales, independent to the global
@@ -461,10 +551,22 @@ This command may cause the load of locales.
.
Return the package private locale or the global locale, if no package private locale is set.
.TP
-\fB::msgcat::mcpackagelocale preferences\fR
+\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ...
.
-Return the package private preferences or the global preferences,
+With no parameters, return the package private preferences or the global preferences,
if no package private locale is set.
+The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR).
+.PP
+.RS
+.VS "TIP 499"
+If a set of locale preferences is given, it is set as package locale preference list.
+The package locale is set to the first element of the preference list.
+A package locale is activated, if it was not set so far.
+.PP
+Locale preferences are loaded now for the package, if not jet loaded.
+.VE "TIP 499"
+.RE
+.PP
.TP
\fB::msgcat::mcpackagelocale loaded\fR
.
@@ -488,7 +590,7 @@ Returns true, if the given locale is loaded for the package.
.
Clear any loaded locales of the package not present in the package preferences.
.PP
-.SH Changing package options
+.SH "CHANGING PACKAGE OPTIONS"
.PP
Each package using msgcat has a set of options within \fBmsgcat\fR.
The package options are described in the next sectionPackage options.
@@ -563,7 +665,7 @@ A generic unknown handler is used if set to the empty string. This consists in r
See section \fBcallback invocation\fR below.
The appended arguments are identical to \fB::msgcat::mcunknown\fR.
.RE
-.SS Callback invocation
+.SH "Callback invocation"
A package may decide to register one or multiple callbacks, as described above.
.PP
Callbacks are invoked, if:
@@ -577,7 +679,54 @@ Callbacks are invoked, if:
If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion.
Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error.
.PP
-.SS Examples
+.VS tip490
+.SH "OBJECT ORIENTED PROGRAMMING"
+\fBmsgcat\fR supports packages implemented by object oriented programming.
+Objects and classes should be defined within a package namespace.
+.PP
+There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called:
+.PP
+.TP
+\fB1) In class definition script\fR
+.
+\fBmsgcat\fR command is called within a class definition script.
+.CS
+namespace eval ::N2 {
+ mcload $dir/msgs
+ oo::class create C1 {puts [mc Hi!]}
+}
+.CE
+.PP
+.TP
+\fB2) method defined in a class\fR
+.
+\fBmsgcat\fR command is called from a method in an object and the method is defined in a class.
+.CS
+namespace eval ::N3Class {
+ mcload $dir/msgs
+ oo::class create C1
+ oo::define C1 method m1 {
+ puts [mc Hi!]
+ }
+}
+.CE
+.PP
+.TP
+\fB3) method defined in a classless object\fR
+.
+\fBmsgcat\fR command is called from a method of a classless object.
+.CS
+namespace eval ::N4 {
+ mcload $dir/msgs
+ oo::object create O1
+ oo::objdefine O1 method m1 {} {
+ puts [mc Hi!]
+ }
+}
+.CE
+.PP
+.VE tip490
+.SH EXAMPLES
Packages which display a GUI may update their widgets when the global locale changes.
To register to a callback, use:
.CS
@@ -643,9 +792,9 @@ proc ::tcl::clock::LocalizeFormat { locale format } {
.PP
The message catalog code was developed by Mark Harrison.
.SH "SEE ALSO"
-format(n), scan(n), namespace(n), package(n)
+format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object
.SH KEYWORDS
-internationalization, i18n, localization, l10n, message, text, translation
+internationalization, i18n, localization, l10n, message, text, translation, class, object
.\" Local Variables:
.\" mode: nroff
.\" End:
diff --git a/doc/my.n b/doc/my.n
index 2a9769b..3464a87 100644
--- a/doc/my.n
+++ b/doc/my.n
@@ -9,25 +9,45 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-my \- invoke any method of current object
+my, myclass \- invoke any method of current object or its class
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBmy\fI methodName\fR ?\fIarg ...\fR?
+\fBmyclass\fI methodName\fR ?\fIarg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
-The \fBmy\fR command is used to allow methods of objects to invoke any method
-of the object (or its class). In particular, the set of valid values for
+The \fBmy\fR command is used to allow methods of objects to invoke methods
+of the object (or its class),
+.VS TIP478
+and the \fBmyclass\fR command is used to allow methods of objects to invoke
+methods of the current class of the object \fIas an object\fR.
+.VE TIP478
+In particular, the set of valid values for
\fImethodName\fR is the set of all methods supported by an object and its
-superclasses, including those that are not exported. The object upon which the
-method is invoked is always the one that is the current context of the method
-(i.e. the object that is returned by \fBself object\fR) from which the
-\fBmy\fR command is invoked.
+superclasses, including those that are not exported
+.VS TIP500
+and private methods of the object or class when used within another method
+defined by that object or class.
+.VE TIP500
.PP
-Each object has its own \fBmy\fR command, contained in its instance namespace.
+The object upon which the method is invoked via \fBmy\fR is the one that owns
+the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
+remains if the command is renamed), which is the currently invoked object by
+default.
+.VS TIP478
+Similarly, the object on which the method is invoked via \fBmyclass\fR is the
+object that is the current class of the object that owns the namespace that
+the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the
+link remains even if the command is renamed into another namespace, and
+defaults to being the manufacturing class of the current object.
+.VE TIP478
+.PP
+Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its
+instance namespace.
.SH EXAMPLES
.PP
This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
@@ -40,16 +60,71 @@ oo::class create c {
puts [incr counter]
}
}
+
c create o
o count \fI\(-> prints "1"\fR
o count \fI\(-> prints "2"\fR
o count \fI\(-> prints "3"\fR
.CE
+.PP
+This example shows how you can use \fBmy\fR to make callbacks to private
+methods from outside the object (from a \fBtrace\fR), using
+\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR
+command for the recommended way of doing this.)
+.PP
+.CS
+oo::class create HasCallback {
+ method makeCallback {} {
+ return [namespace code {
+ \fBmy\fR Callback
+ }]
+ }
+
+ method Callback {args} {
+ puts "callback: $args"
+ }
+}
+
+set o [HasCallback new]
+trace add variable xyz write [$o makeCallback]
+set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR
+.CE
+.PP
+.VS TIP478
+This example shows how to access a private method of a class from an instance
+of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for
+a higher level interface for doing this.)
+.PP
+.CS
+oo::class create CountedSteps {
+ self {
+ variable count
+ method Count {} {
+ return [incr count]
+ }
+ }
+ method advanceTwice {} {
+ puts "in [self] step A: [\fBmyclass\fR Count]"
+ puts "in [self] step B: [\fBmyclass\fR Count]"
+ }
+}
+
+CountedSteps create x
+CountedSteps create y
+x advanceTwice \fI\(-> prints "in ::x step A: 1"\fR
+ \fI\(-> prints "in ::x step B: 2"\fR
+y advanceTwice \fI\(-> prints "in ::y step A: 3"\fR
+ \fI\(-> prints "in ::y step B: 4"\fR
+x advanceTwice \fI\(-> prints "in ::x step A: 5"\fR
+ \fI\(-> prints "in ::x step B: 6"\fR
+y advanceTwice \fI\(-> prints "in ::y step A: 7"\fR
+ \fI\(-> prints "in ::y step B: 8"\fR
+.CE
+.VE TIP478
.SH "SEE ALSO"
next(n), oo::object(n), self(n)
.SH KEYWORDS
method, method visibility, object, private method, public method
-
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
diff --git a/doc/namespace.n b/doc/namespace.n
index f7775b4..1773555 100644
--- a/doc/namespace.n
+++ b/doc/namespace.n
@@ -788,12 +788,10 @@ name. Note that when this option is non-empty and the
will be exactly those words that have mappings in the dictionary.
.TP
\fB\-parameters\fR
-.VS 8.6
This option gives a list of named arguments (the names being used during
generation of error messages) that are passed by the caller of the ensemble
between the name of the ensemble and the subcommand argument. By default, it
is the empty list.
-.VE 8.6
.TP
\fB\-prefixes\fR
.
@@ -943,7 +941,6 @@ Remove all imported commands from the current namespace:
namespace forget {*}[namespace import]
.CE
.PP
-.VS 8.6
Create an ensemble for simple working with numbers, using the
\fB\-parameters\fR option to allow the operator to be put between the first
and second arguments.
@@ -959,7 +956,6 @@ and second arguments.
# In use, the ensemble works like this:
puts [do 1 plus [do 9 minus 7]]
.CE
-.VE 8.6
.SH "SEE ALSO"
interp(n), upvar(n), variable(n)
.SH KEYWORDS
diff --git a/doc/next.n b/doc/next.n
index 294d4b5..624e058 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -12,7 +12,7 @@
next, nextto \- invoke superclass method implementations
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBnext\fR ?\fIarg ...\fR?
\fBnextto\fI class\fR ?\fIarg ...\fR?
@@ -112,6 +112,7 @@ oo::class create theSuperclass {
puts "in the superclass, args = $args"
}
}
+
oo::class create theSubclass {
superclass theSuperclass
method example {args} {
@@ -121,6 +122,7 @@ oo::class create theSubclass {
puts "after chaining from subclass"
}
}
+
theSubclass create obj
oo::objdefine obj method example args {
puts "per-object method, args = $args"
@@ -167,6 +169,7 @@ oo::class create cache {
\fI# Compute value, insert into cache, and return it\fR
return [set ValueCache($key) [\fBnext\fR {*}$args]]
}
+
method flushCache {} {
my variable ValueCache
unset ValueCache
@@ -178,10 +181,12 @@ oo::class create cache {
oo::object create demo
oo::objdefine demo {
mixin cache
+
method compute {a b c} {
after 3000 \fI;# Simulate deep thought\fR
return [expr {$a + $b * $c}]
}
+
method compute2 {a b c} {
after 3000 \fI;# Simulate deep thought\fR
return [expr {$a * $b + $c}]
diff --git a/doc/object.n b/doc/object.n
index df657a9..98679d1 100644
--- a/doc/object.n
+++ b/doc/object.n
@@ -12,7 +12,7 @@
oo::object \- root class of the class hierarchy
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBoo::object\fI method \fR?\fIarg ...\fR?
.fi
diff --git a/doc/open.n b/doc/open.n
index 782183c..68e8494 100644
--- a/doc/open.n
+++ b/doc/open.n
@@ -128,6 +128,28 @@ If a new file is created as part of opening it, \fIpermissions\fR
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
+.PP
+.VS "8.7, TIP 603"
+When the file opened is an ordinary disk file, the \fBchan configure\fR and
+\fBfconfigure\fR commands can be used to query this additional configuration
+option:
+.TP
+\fB\-stat\fR
+.
+This option, when read, returns a dictionary of values much as is obtained
+from the \fBfile stat\fR command, where that stat information relates to the
+real opened file. Keys in the dictionary may include \fBatime\fR, \fBctime\fR,
+\fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR,
+\fBsize\fR, \fBtype\fR, and \fBuid\fR among others; the \fBmtime\fR,
+\fBsize\fR and \fBtype\fR fields are guaranteed to be present and meaningful
+on all platforms; other keys may be present too.
+.RS
+.PP
+\fIImplementation note:\fR This option maps to a call to \fBfstat()\fR on
+POSIX platforms, and to a call to \fBGetFileInformationByHandle()\fR on
+Windows; the information reported is what those system calls produce.
+.RE
+.VE "8.7, TIP 603"
.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is
@@ -166,8 +188,9 @@ is opened and initialized in a platform-dependent manner. Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
.PP
-The \fBfconfigure\fR command can be used to query and set additional
-configuration options specific to serial ports (where supported):
+The \fBchan configure\fR and \fBfconfigure\fR commands can be used to query
+and set additional configuration options specific to serial ports (where
+supported):
.TP
\fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR
.
@@ -249,6 +272,75 @@ handshake characters. Normally the operating system default should be
DC1 (0x11) and DC3 (0x13) representing the ASCII standard
XON and XOFF characters.
.TP
+\fB\-closemode\fR \fIcloseMode\fR
+.VS "8.7, TIP 160"
+(Windows and Unix). This option is used to query or change the close mode of
+the serial channel, which defines how pending output in operating system
+buffers is handled when the channel is closed. The following values for
+\fIcloseMode\fR are supported:
+.RS
+.TP
+\fBdefault\fR
+.
+indicates that a system default operation should be used; all serial channels
+default to this.
+.TP
+\fBdiscard\fR
+.
+indicates that the contents of the OS buffers should be discarded. Note that
+this is \fInot recommended\fR when writing to a POSIX terminal, as it can
+interact unexpectedly with handling of \fBstderr\fR.
+.TP
+\fBdrain\fR
+.
+indicates that Tcl should wait when closing the channel until all output has
+been consumed. This may slow down \fBclose\fR noticeably.
+.RE
+.VE "8.7, TIP 160"
+.TP
+\fB\-inputmode\fR \fIinputMode\fR
+.VS "8.7, TIP 160"
+(Unix only; Windows has the equivalent option on console channels). This
+option is used to query or change the input mode of the serial channel under
+the assumption that it is talking to a terminal, which controls how interactive
+input from users is handled. The following values for \fIinputMode\fR are
+supported:
+.RS
+.TP
+\fBnormal\fR
+.
+indicates that normal line-oriented input should be used, with standard
+terminal editing capabilities enabled.
+.TP
+\fBpassword\fR
+.
+indicates that non-echoing input should be used, with standard terminal
+editing capabilities enabled but no writing of typed characters to the
+terminal (except for newlines). Some terminals may indicate this specially.
+.TP
+\fBraw\fR
+.
+indicates that all keyboard input should be given directly to Tcl with the
+terminal doing no processing at all. It does not echo the keys, leaving it up
+to the Tcl script to interpret what to do.
+.TP
+\fBreset\fR (set only)
+.
+indicates that the terminal should be reset to what state it was in when the
+terminal was opened.
+.PP
+Note that setting this option (technically, anything that changes the terminal
+state from its initial value \fIvia this option\fR) will cause the channel to
+turn on an automatic reset of the terminal when the channel is closed.
+.RE
+.TP
+\fB\-winsize\fR
+.
+(Unix only; Windows has the equivalent option on console channels). This
+option is query only. It retrieves a two-element list with the the current
+width and height of the terminal.
+.VE "8.7, TIP 160"
+.TP
\fB\-pollinterval\fR \fImsec\fR
.
(Windows only). This option is used to set the maximum time between
@@ -275,7 +367,7 @@ In case of a serial communication error, \fBread\fR or \fBputs\fR
returns a general Tcl file I/O error.
\fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details.
See below for an explanation of the various error codes.
-.SH "SERIAL PORT SIGNALS"
+.SS "SERIAL PORT SIGNALS"
.PP
RS-232 is the most commonly used standard electrical interface for serial
communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and
@@ -316,7 +408,7 @@ milliseconds. Normally a receive or transmit data signal stays at the mark
(on=1) voltage until the next character is transferred. A BREAK is sometimes
used to reset the communications line or change the operating mode of
communications hardware.
-.SH "ERROR CODES (Windows only)"
+.SS "ERROR CODES (Windows only)"
.PP
A lot of different errors may occur during serial read operations or during
event polling in background. The external device may have been switched
@@ -359,7 +451,7 @@ may cause this error.
\fBBREAK\fR
.
A BREAK condition has been detected by your UART (see above).
-.SH "PORTABILITY ISSUES"
+.SS "PORTABILITY ISSUES"
.TP
\fBWindows \fR
.
@@ -414,6 +506,54 @@ input, but is redirected from a file, then the above problem does not occur.
See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for
additional information not specific to command pipelines about executing
applications on the various platforms
+.SH "CONSOLE CHANNELS"
+.VS "8.7, TIP 160"
+On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR)
+support the following options:
+.TP
+\fB\-inputmode\fR \fIinputMode\fR
+.
+This option is used to query or change the input mode of the console channel,
+which controls how interactive input from users is handled. The following
+values for \fIinputMode\fR are supported:
+.RS
+.TP
+\fBnormal\fR
+.
+indicates that normal line-oriented input should be used, with standard
+console editing capabilities enabled.
+.TP
+\fBpassword\fR
+.
+indicates that non-echoing input should be used, with standard console
+editing capabilitied enabled but no writing of typed characters to the
+terminal (except for newlines).
+.TP
+\fBraw\fR
+.
+indicates that all keyboard input should be given directly to Tcl with the
+console doing no processing at all. It does not echo the keys, leaving it up
+to the Tcl script to interpret what to do.
+.TP
+\fBreset\fR (set only)
+.
+indicates that the console should be reset to what state it was in when the
+console channel was opened.
+.PP
+Note that setting this option (technically, anything that changes the console
+state from its default \fIvia this option\fR) will cause the channel to turn
+on an automatic reset of the console when the channel is closed.
+.RE
+.TP
+\fB\-winsize\fR
+.
+This option is query only.
+It retrieves a two-element list with the the current width and height of the
+console that this channel is talking to.
+.PP
+Note that the equivalent options exist on Unix, but are on the serial channel
+type.
+.VE "8.7, TIP 160"
.SH "EXAMPLES"
Open a file for writing, forcing it to be created and raising an error if it
already exists.
@@ -429,7 +569,6 @@ set myLogFile [\fBopen\fR filename.log "a"]
fconfigure $myLogFile -buffering line
.CE
.PP
-.PP
Open a command pipeline and catch any errors:
.PP
.CS
@@ -451,6 +590,22 @@ set fl [\fBopen\fR |[list create_image_data $input] "rb"]
set binData [read $fl]
close $fl
.CE
+.PP
+.VS "8.7, TIP 160"
+Read a password securely from the user (assuming that the script is being run
+interactively):
+.PP
+.CS
+chan configure stdin \fB-inputmode password\fR
+try {
+ chan puts -nonewline "Password: "
+ chan flush stdout
+ set thePassword [chan gets stdin]
+} finally {
+ chan configure stdin \fB-inputmode reset\fR
+}
+.CE
+.VE "8.7, TIP 160"
.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(3)
diff --git a/doc/package.n b/doc/package.n
index a6a972f..5687480 100644
--- a/doc/package.n
+++ b/doc/package.n
@@ -12,6 +12,7 @@
package \- Facilities for package loading and version control
.SH SYNOPSIS
.nf
+\fBpackage files\fR \fIpackage\fR
\fBpackage forget\fR ?\fIpackage package ...\fR?
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
\fBpackage names\fR
@@ -43,6 +44,13 @@ primarily by system scripts that maintain the package database.
The behavior of the \fBpackage\fR command is determined by its first argument.
The following forms are permitted:
.TP
+\fBpackage files\fR \fIpackage\fR
+.
+Lists all files forming part of \fIpackage\fR. Auto-loaded files are not
+included in this list, only files which were directly sourced during package
+initialization. The list order corresponds with the order in which the
+files were sourced.
+.TP
\fBpackage forget\fR ?\fIpackage package ...\fR?
.
Removes all information about each specified package from this interpreter,
@@ -283,8 +291,8 @@ error.
.PP
When an interpreter is created, its initial selection mode value is set to
.QW stable
-unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR
-is set. If that environment variable is defined (with any value) then
+unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR is set
+(to any value) or the Tcl package itself is unstable. Otherwise
the initial (and permanent) selection mode value is set to
.QW latest .
.RE
diff --git a/doc/packagens.n b/doc/packagens.n
index bce22fe..d55151f 100644
--- a/doc/packagens.n
+++ b/doc/packagens.n
@@ -29,7 +29,7 @@ This parameter specifies the name of the package. It is required.
This parameter specifies the version of the package. It is required.
.TP
\fB\-load \fIfilespec\fR
-This parameter specifies a binary library that must be loaded with the
+This parameter specifies a library that must be loaded with the
\fBload\fR command. \fIfilespec\fR is a list with two elements. The
first element is the name of the file to load. The second, optional
element is a list of commands supplied by loading that file. If the
@@ -48,3 +48,7 @@ At least one \fB\-load\fR or \fB\-source\fR parameter must be given.
package(n)
.SH KEYWORDS
auto-load, index, package, version
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/pid.n b/doc/pid.n
index 6f8c399..fa0af56 100644
--- a/doc/pid.n
+++ b/doc/pid.n
@@ -43,6 +43,9 @@ close $pipeline
.SH "SEE ALSO"
exec(n), open(n)
-
.SH KEYWORDS
file, pipeline, process identifier
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/platform.n b/doc/platform.n
index 5380ff4..7cb685d 100644
--- a/doc/platform.n
+++ b/doc/platform.n
@@ -12,7 +12,7 @@
platform \- System identification support code and utilities
.SH SYNOPSIS
.nf
-\fBpackage require platform ?1.0.10?\fR
+\fBpackage require platform\fR ?\fB1.0.10\fR?
.sp
\fBplatform::generic\fR
\fBplatform::identify\fR
diff --git a/doc/platform_shell.n b/doc/platform_shell.n
index 330afa9..a9e14d0 100644
--- a/doc/platform_shell.n
+++ b/doc/platform_shell.n
@@ -12,7 +12,7 @@
platform::shell \- System identification support code and utilities
.SH SYNOPSIS
.nf
-\fBpackage require platform::shell ?1.1.4?\fR
+\fBpackage require platform::shell\fR ?\fB1.1.4\fR?
.sp
\fBplatform::shell::generic \fIshell\fR
\fBplatform::shell::identify \fIshell\fR
@@ -55,3 +55,7 @@ This command returns the contents of \fBtcl_platform(platform)\fR for
the specified Tcl shell.
.SH KEYWORDS
operating system, cpu architecture, platform, architecture
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/prefix.n b/doc/prefix.n
index 50aa2fb..d327a78 100644
--- a/doc/prefix.n
+++ b/doc/prefix.n
@@ -12,9 +12,9 @@
tcl::prefix \- facilities for prefix matching
.SH SYNOPSIS
.nf
-\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR
-\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR
-\fB::tcl::prefix match\fR \fI?option ...?\fR \fItable\fR \fIstring\fR
+\fB::tcl::prefix all\fR \fItable string\fR
+\fB::tcl::prefix longest\fR \fItable string\fR
+\fB::tcl::prefix match\fR ?\fIoption ...\fR? \fItable string\fR
.fi
.BE
.SH DESCRIPTION
@@ -22,17 +22,17 @@ tcl::prefix \- facilities for prefix matching
This document describes commands looking up a prefix in a list of strings.
The following commands are supported:
.TP
-\fB::tcl::prefix all\fR \fItable\fR \fIstring\fR
+\fB::tcl::prefix all\fR \fItable string\fR
.
Returns a list of all elements in \fItable\fR that begin with the prefix
\fIstring\fR.
.TP
-\fB::tcl::prefix longest\fR \fItable\fR \fIstring\fR
+\fB::tcl::prefix longest\fR \fItable string\fR
.
Returns the longest common prefix of all elements in \fItable\fR that
begin with the prefix \fIstring\fR.
.TP
-\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable\fR \fIstring\fR
+\fB::tcl::prefix match\fR ?\fIoptions\fR? \fItable string\fR
.
If \fIstring\fR equals one element in \fItable\fR or is a prefix to exactly
one element, the matched element is returned. If not, the result depends
diff --git a/doc/process.n b/doc/process.n
new file mode 100644
index 0000000..165e413
--- /dev/null
+++ b/doc/process.n
@@ -0,0 +1,150 @@
+'\"
+'\" Copyright (c) 2017 Frederic Bonnet.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH process n 8.7 Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::process \- Subprocess management
+.SH SYNOPSIS
+\fB::tcl::process \fIoption \fR?\fIarg arg ...\fR?
+.BE
+.SH DESCRIPTION
+.PP
+This command provides a way to manage subprocesses created by the \fBopen\fR
+and \fBexec\fR commands, as identified by the process identifiers (PIDs) of
+those subprocesses. The legal \fIoptions\fR (which may be abbreviated) are:
+.TP
+\fB::tcl::process autopurge\fR ?\fIflag\fR?
+.
+Automatic purge facility. If \fIflag\fR is specified as a boolean value then
+it activates or deactivate autopurge. In all cases it returns the current
+status as a boolean value. When autopurge is active,
+\fBTcl_ReapDetachedProcs\fR is called each time the \fBexec\fR command is
+executed or a pipe channel created by \fBopen\fR is closed. When autopurge is
+inactive, \fB::tcl::process\fR purge must be called explicitly. By default
+autopurge is active.
+.TP
+\fB::tcl::process list\fR
+.
+Returns the list of subprocess PIDs. This includes all currently executing
+subprocesses and all terminated subprocesses that have not yet had their
+corresponding process table entries purged.
+.TP
+\fB::tcl::process purge\fR ?\fIpids\fR?
+.
+Cleans up all data associated with terminated subprocesses. If \fIpids\fR is
+specified as a list of PIDs then the command only cleanup data for the matching
+subprocesses if they exist, and raises an error otherwise. If a process listed is
+still active, this command does nothing to that process.
+.TP
+\fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR?
+.
+Returns a dictionary mapping subprocess PIDs to their respective status. If
+\fIpids\fR is specified as a list of PIDs then the command only returns the
+status of the matching subprocesses if they exist, and raises an error
+otherwise. For active processes, the status is an empty value. For terminated
+processes, the status is a list with the following format:
+.QW "\fB{\fIcode\fR ?\fImsg errorCode\fR?\fB}\fR" ,
+where:
+.RS
+.TP
+\fIcode\fR\0
+.
+is a standard Tcl return code, i.e., \fB0\fR for TCL_OK and \fB1\fR
+for TCL_ERROR,
+.TP
+\fImsg\fR\0
+.
+is the human-readable error message,
+.TP
+\fIerrorCode\fR\0
+.
+uses the same format as the \fBerrorCode\fR global variable
+.PP
+Note that \fBmsg\fR and \fBerrorCode\fR are only present for abnormally
+terminated processes (i.e. those where the \fIcode\fR is nonzero). Under the
+hood this command calls \fBTcl_WaitPid\fR with the \fBWNOHANG\fR flag set for
+non-blocking behavior, unless the \fB\-wait\fR switch is set (see below).
+.PP
+Additionally, \fB::tcl::process status\fR accepts the following switches:
+.TP
+\fB\-wait\fR\0
+.
+By default the command returns immediately (the underlying \fBTcl_WaitPid\fR is
+called with the \fBWNOHANG\fR flag set) unless this switch is set. If \fIpids\fR
+is specified as a list of PIDs then the command waits until the status of the
+matching subprocesses are available. If \fIpids\fR was not specified, this
+command will wait for all known subprocesses.
+.TP
+\fB\-\|\-\fR
+.
+Marks the end of switches. The argument following this one will
+be treated as the first \fIarg\fR even if it starts with a \fB\-\fR.
+.RE
+.SH "EXAMPLES"
+.PP
+These show the use of \fB::tcl::process\fR. Some of the results from
+\fB::tcl::process status\fR are split over multiple lines for readability.
+.PP
+.CS
+\fB::tcl::process autopurge\fR
+ \fI\(-> true\fR
+\fB::tcl::process autopurge\fR false
+ \fI\(-> false\fR
+
+set pid1 [exec command1 a b c | command2 d e f &]
+ \fI\(-> 123 456\fR
+set chan [open "|command1 a b c | command2 d e f"]
+ \fI\(-> file123\fR
+set pid2 [pid $chan]
+ \fI\(-> 789 1011\fR
+
+\fB::tcl::process list\fR
+ \fI\(-> 123 456 789 1011\fR
+
+\fB::tcl::process status\fR
+ \fI\(-> 123 0
+ 456 {1 "child killed: write on pipe with no readers" {
+ CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}}
+ 789 {1 "child suspended: background tty read" {
+ CHILDSUSP 789 SIGTTIN "background tty read"}}
+ 1011 {}\fR
+
+\fB::tcl::process status\fR 123
+ \fI\(-> 123 0\fR
+
+\fB::tcl::process status\fR 1011
+ \fI\(-> 1011 {}\fR
+
+\fB::tcl::process status\fR -wait
+ \fI\(-> 123 0
+ 456 {1 "child killed: write on pipe with no readers" {
+ CHILDKILLED 456 SIGPIPE "write on pipe with no readers"}}
+ 789 {1 "child suspended: background tty read" {
+ CHILDSUSP 789 SIGTTIN "background tty read"}}
+ 1011 {1 "child process exited abnormally" {
+ CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process status\fR 1011
+ \fI\(-> 1011 {1 "child process exited abnormally" {
+ CHILDSTATUS 1011 -1}}\fR
+
+\fB::tcl::process purge\fR
+exec command1 1 2 3 &
+ \fI\(-> 1213\fR
+\fB::tcl::process list\fR
+ \fI\(-> 1213\fR
+.CE
+.SH "SEE ALSO"
+exec(n), open(n), pid(n),
+Tcl_DetachPids(3), Tcl_WaitPid(3), Tcl_ReapDetachedProcs(3)
+.SH "KEYWORDS"
+background, child, detach, process, wait
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/puts.n b/doc/puts.n
index f4e1040..0943f87 100644
--- a/doc/puts.n
+++ b/doc/puts.n
@@ -62,6 +62,12 @@ To avoid wasting memory, nonblocking I/O should normally
be used in an event-driven fashion with the \fBfileevent\fR command
(do not invoke \fBputs\fR unless you have recently been notified
via a file event that the channel is ready for more output data).
+.SH "ENCODING ERRORS"
+.PP
+Encoding errors may exist, if the encoding profile \fBstrict\fR is used.
+\fBputs\fR writes out data until an encoding error occurs and fails with
+POSIX error code \fBEILSEQ\fR.
+
.SH EXAMPLES
.PP
Write a short message to the console (or wherever \fBstdout\fR is
@@ -96,3 +102,7 @@ close $chan
file(n), fileevent(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, newline, output, write
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/pwd.n b/doc/pwd.n
index 85dd390..e96cae5 100644
--- a/doc/pwd.n
+++ b/doc/pwd.n
@@ -37,3 +37,7 @@ cd $savedDir
file(n), cd(n), glob(n), filename(n)
.SH KEYWORDS
working directory
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/read.n b/doc/read.n
index 9a9a7e8..7c0c155 100644
--- a/doc/read.n
+++ b/doc/read.n
@@ -50,6 +50,79 @@ newline characters according to the \fB\-translation\fR option
for the channel.
See the \fBfconfigure\fR manual entry for a discussion on ways in
which \fBfconfigure\fR will alter input.
+.SH "ENCODING ERRORS"
+.PP
+Encoding errors may exist, if the encoding profile \fBstrict\fR is used.
+Encoding errors are special, as an eventual introspection or recovery is
+possible by changing to an encoding (or encoding profile), which accepts
+the data.
+An encoding error is reported by the POSIX error code \fBEILSEQ\fR.
+.PP
+In blocking mode, the error is directly thrown, even, if there is a
+leading decodable data portion.
+The file pointer is advanced just before the encoding error.
+An eventual well decoded data chunk before the encoding error is returned
+in the error option dictionary key \fB-data\fR.
+The value of the key contains the empty string, if the error arises at the
+first data position.
+.PP
+In non blocking mode, first, any data without encoding error is returned
+(without error state).
+In the next call, no data is returned and the \fBEILSEQ\fR error state is set.
+The key \fB-data\fR is not present.
+.PP
+Here is an example with an encoding error in UTF-8 encoding, which is then
+introspected by a switch to the binary encoding. The test file contains a not
+continued multi-byte sequence at position 1 (\fBA \\xC3 B\fR):
+.PP
+File creation for examples
+.
+.CS
+% set f [open test_A_195_B.txt wb]; puts -nonewline $f A\\xC3B; close $f
+.CE
+Blocking example
+.
+.CS
+% set f [open test_A_195_B.txt r]
+file35a65a0
+% fconfigure $f -encoding utf-8 -profile strict -blocking 1
+% catch {read $f} e d
+1
+% set d
+-data A -code 1 -level 0
+-errorstack {INNER {invokeStk1 read file35a65a0}}
+-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
+-errorinfo {...} -errorline 1
+% tell $f
+1
+% fconfigure $f -encoding binary -profile strict
+% read $f
+ÃB
+% close $f
+.CE
+The already decoded data "A" is returned in the error options dictionary key
+\fB-data\fR.
+The file position is advanced on the encoding error position 1.
+The data at the error position is thus recovered by the next \fBread\fR command.
+.PP
+Non blocking example
+.
+.CS
+% set f [open test_A_195_B.txt r]
+file35a65a0
+% fconfigure $f -encoding utf-8 -profile strict -blocking 0
+% read $f
+A
+% tell $f
+1
+% catch {read $f} e d
+1
+% set d
+-code 1 -level 0
+-errorstack {INNER {invokeStk1 read file384b228}}
+-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
+-errorinfo {...} -errorline 1
+.CE
.SH "USE WITH SERIAL PORTS"
'\" Note: this advice actually applies to many versions of Tcl
.PP
diff --git a/doc/refchan.n b/doc/refchan.n
index edc9974..94823c5 100644
--- a/doc/refchan.n
+++ b/doc/refchan.n
@@ -11,7 +11,20 @@
.SH NAME
refchan \- command handler API of reflected channels
.SH SYNOPSIS
-\fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR?
+.nf
+\fBchan create \fImode cmdPrefix\fR
+
+\fIcmdPrefix \fBblocking\fR \fIchannelId mode\fR
+\fIcmdPrefix \fBcget\fR \fIchannelId option\fR
+\fIcmdPrefix \fBcgetall\fR \fIchannelId\fR
+\fIcmdPrefix \fBconfigure\fR \fIchannelId option value\fR
+\fIcmdPrefix \fBfinalize\fR \fIchannelId\fR
+\fIcmdPrefix \fBinitialize\fR \fIchannelId mode\fR
+\fIcmdPrefix \fBread\fR \fIchannelId count\fR
+\fIcmdPrefix \fBseek\fR \fIchannelId offset base\fR
+\fIcmdPrefix \fBwatch\fR \fIchannelId eventspec\fR
+\fIcmdPrefix \fBwrite\fR \fIchannelId data\fR
+.fi
.BE
.SH DESCRIPTION
.PP
@@ -322,6 +335,19 @@ invocation (usually \fBfconfigure\fR or \fBchan configure\fR) will appear to
have thrown this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
etc.) is treated as and converted to an error.
.RE
+.TP
+\fIcmdPrefix \fBtruncate\fR \fIchannelId length\fR
+.
+This \fIoptional\fR subcommand handles changing the length of the
+underlying data stream for the channel \fIchannelId\fR. Its length
+gets set to \fIlength\fR.
+.RS
+.PP
+If the subcommand throws an error the command which caused its
+invocation (usually \fBchan truncate\fR) will appear to have thrown
+this error. Any exception beyond \fBerror\fR (e.g.,\ \fBbreak\fR,
+etc.) is treated as and converted to an error.
+.RE
.SH NOTES
Some of the functions supported in channels defined in Tcl's C
interface are not available to channels reflected to the Tcl level.
diff --git a/doc/registry.n b/doc/registry.n
index ec5910c..66b2dd9 100644
--- a/doc/registry.n
+++ b/doc/registry.n
@@ -44,13 +44,11 @@ one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR,
\fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more
registry key names separated by backslash (\fB\e\fR) characters.
.PP
-.VS 8.6
The optional \fI\-mode\fR argument indicates which registry to work
with; when it is \fB\-32bit\fR the 32-bit registry will be used, and
when it is \fB\-64bit\fR the 64-bit registry will be used. If this
argument is omitted, the system's default registry will be the subject
of the requested operation.
-.VE 8.6
.PP
\fIOption\fR indicates what to do with the registry key name. Any
unique abbreviation for \fIoption\fR is acceptable. The valid options
diff --git a/doc/regsub.n b/doc/regsub.n
index a5b79de..29c118a 100644
--- a/doc/regsub.n
+++ b/doc/regsub.n
@@ -68,6 +68,33 @@ and
sequences are handled for each substitution using the information
from the corresponding match.
.TP
+\fB\-command\fR
+.VS 8.7
+Changes the handling of \fIsubSpec\fR so that it is not treated
+as a template for a substitution string and the substrings
+.QW &
+and
+.QW \e\fIn\fR
+no longer have special meaning. Instead \fIsubSpec\fR must be a
+command prefix, that is, a non-empty list. The substring of \fIstring\fR
+that matches \fIexp\fR, and then each substring that matches each
+capturing sub-RE within \fIexp\fR are appended as additional elements
+to that list. (The items appended to the list are much like what
+\fBregexp\fR \fB-inline\fR would return). The completed list is then
+evaluated as a Tcl command, and the result of that command is the
+substitution string. Any error or exception from command evaluation
+becomes an error or exception from the \fBregsub\fR command.
+.RS
+.PP
+If \fB\-all\fR is not also given, the command callback will be invoked at most
+once (exactly when the regular expression matches). If \fB\-all\fR is given,
+the command callback will be invoked for each matched location, in sequence.
+The exact location indices that matched are not made available to the script.
+.PP
+See \fBEXAMPLES\fR below for illustrative cases.
+.RE
+.VE 8.7
+.TP
\fB\-expanded\fR
.
Enables use of the expanded regular expression syntax where
@@ -183,6 +210,53 @@ set substitution {[format \e\e\e\eu%04x [scan "\e\e&" %c]]}
set quoted [subst [string map {\en {\e\eu000a}} \e
[\fBregsub\fR -all $RE $string $substitution]]]
.CE
+.PP
+.VS 8.7
+The above operation can be done using \fBregsub \-command\fR instead, which is
+often faster. (A full pre-computed \fBstring map\fR would be faster still, but
+the cost of computing the map for a transformation as complex as this can be
+quite large.)
+.PP
+.CS
+# This RE is just a character class for everything "bad"
+set RE {[][{};#\e\e\e$\es\eu0080-\euffff]}
+
+# This encodes what the RE described above matches
+proc encodeChar {ch} {
+ # newline is handled specially since backslash-newline is a
+ # special sequence.
+ if {$ch eq "\en"} {
+ return "\e\eu000a"
+ }
+ # No point in writing this as a one-liner
+ scan $ch %c charNumber
+ format "\e\eu%04x" $charNumber
+}
+
+set quoted [\fBregsub\fR -all -command $RE $string encodeChar]
+.CE
+.PP
+Decoding a URL-encoded string using \fBregsub \-command\fR, a lambda term and
+the \fBapply\fR command.
+.PP
+.CS
+# Match one of the sequences in a URL-encoded string that needs
+# fixing, converting + to space and %XX to the right character
+# (e.g., %7e becomes ~)
+set RE {(\e+)|%([0-9A-Fa-f]{2})}
+
+# Note that -command uses a command prefix, not a command name
+set decoded [\fBregsub\fR -all -command $RE $string {apply {{- p h} {
+ # + is a special case; handle directly
+ if {$p eq "+"} {
+ return " "
+ }
+ # convert hex to a char
+ scan $h %x charNumber
+ format %c $charNumber
+}}}]
+.CE
+.VE 8.7
.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n), string(n)
.SH KEYWORDS
diff --git a/doc/rename.n b/doc/rename.n
index f74db5f..b064f66 100644
--- a/doc/rename.n
+++ b/doc/rename.n
@@ -43,3 +43,7 @@ proc ::source args {
namespace(n), proc(n)
.SH KEYWORDS
command, delete, namespace, rename
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/return.n b/doc/return.n
index ea590ea..e3d7c06 100644
--- a/doc/return.n
+++ b/doc/return.n
@@ -137,7 +137,6 @@ by the \fBcatch\fR command (or from the copy of that information
stored in the global variable \fBerrorInfo\fR).
.TP
\fB\-errorstack \fIlist\fR
-.VS 8.6
The \fB\-errorstack\fR option receives special treatment only when the value
of the \fB\-code\fR option is \fBTCL_ERROR\fR. Then \fIlist\fR is the initial
error stack, recording actual argument values passed to each proc level. The error stack will
@@ -152,7 +151,6 @@ the procedure. Typically the \fIlist\fR value is supplied from
the value of \fB\-errorstack\fR in a return options dictionary captured
by the \fBcatch\fR command (or from the copy of that information from
\fBinfo errorstack\fR).
-.VE 8.6
.TP
\fB\-level \fIlevel\fR
.
diff --git a/doc/safe.n b/doc/safe.n
index 819287d..6e0d948 100644
--- a/doc/safe.n
+++ b/doc/safe.n
@@ -23,10 +23,13 @@ safe \- Creating and manipulating safe interpreters
.sp
\fB::safe::interpFindInAccessPath\fR \fIchild\fR \fIdirectory\fR
.sp
+\fB::safe::setSyncMode\fR ?\fInewValue\fR?
+.sp
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
.SS OPTIONS
.PP
?\fB\-accessPath\fR \fIpathList\fR?
+?\fB\-autoPath\fR \fIpathList\fR?
?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR?
?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR?
?\fB\-deleteHook\fR \fIscript\fR?
@@ -148,6 +151,15 @@ $child eval [list set tk_library \e
.CE
.RE
.TP
+\fB::safe::setSyncMode\fR ?\fInewValue\fR?
+This command is used to get or set the "Sync Mode" of the Safe Base.
+When an argument is supplied, the command returns an error if the argument
+is not a boolean value, or if any Safe Base interpreters exist. Typically
+the value will be set as part of initialization - boolean true for
+"Sync Mode" on (the default), false for "Sync Mode" off. With "Sync Mode"
+on, the Safe Base keeps each child interpreter's ::auto_path synchronized
+with its access path. See the section \fBSYNC MODE\fR below for details.
+.TP
\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
This command installs a script that will be called when interesting
life cycle events occur for a safe interpreter.
@@ -199,6 +211,13 @@ parent for auto-loading.
See the section \fBSECURITY\fR below for more detail about virtual paths,
tokens and access control.
.TP
+\fB\-autoPath\fR \fIdirectoryList\fR
+This option sets the list of directories in the safe interpreter's
+::auto_path. The option is undefined if the Safe Base has "Sync Mode" on
+- in that case the safe interpreter's ::auto_path is managed by the Safe
+Base and is a tokenized form of its access path.
+See the section \fBSYNC MODE\fR below for details.
+.TP
\fB\-statics\fR \fIboolean\fR
This option specifies if the safe interpreter will be allowed
to load statically linked packages (like \fBload {} Tk\fR).
@@ -331,7 +350,8 @@ list will be assigned a token that will be set in
the child \fBauto_path\fR and the first element of that list will be set as
the \fBtcl_library\fR for that child.
.PP
-If the access path argument is not given or is the empty list,
+If the access path argument is not given to \fB::safe::interpCreate\fR or
+\fB::safe::interpInit\fR or is the empty list,
the default behavior is to let the child access the same packages
as the parent has access to (Or to be more precise:
only packages written in Tcl (which by definition cannot be dangerous
@@ -357,8 +377,152 @@ When the \fIaccessPath\fR is changed after the first creation or
initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR),
an \fBauto_reset\fR is automatically evaluated in the safe interpreter
to synchronize its \fBauto_index\fR with the new token list.
+.SH TYPICAL USE
+In many cases, the properties of a Safe Base interpreter can be specified
+when the interpreter is created, and then left unchanged for the lifetime
+of the interpreter.
+.PP
+If you wish to use Safe Base interpreters with "Sync Mode" off, evaluate
+the command
+.RS
+.PP
+.CS
+ safe::setSyncMode 0
+.CE
+.RE
+.PP
+Use \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR to create an
+interpreter with the properties that you require. The simplest way is not
+to specify \fB\-accessPath\fR or \fB\-autoPath\fR, which means the safe
+interpreter will use the same paths as the parent interpreter. However,
+if \fB\-accessPath\fR is specified, then \fB\-autoPath\fR must also be
+specified, or else it will be set to {}.
+.PP
+The value of \fB\-autoPath\fR will be that required to access tclIndex
+and pkgIndex.tcl files according to the same rules as an unsafe
+interpreter (see pkg_mkIndex(n) and library(n)).
+.PP
+With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and
+the Safe Base sets the child's ::auto_path to a tokenized form of the
+access path. In addition to the directories present if "Safe Mode" is off,
+the ::auto_path includes the numerous subdirectories and module paths
+that belong to the access path.
+.SH SYNC MODE
+Before Tcl version 8.7, the Safe Base kept each safe interpreter's
+::auto_path synchronized with a tokenized form of its access path.
+Limitations of Tcl 8.4 and earlier made this feature necessary. This
+definition of ::auto_path did not conform its specification in library(n)
+and pkg_mkIndex(n), but nevertheless worked perfectly well for the discovery
+and loading of packages. The introduction of Tcl modules in Tcl 8.5 added a
+large number of directories to the access path, and it is inconvenient to
+have these additional directories unnecessarily appended to the ::auto_path.
+.PP
+In order to preserve compatibility with existing code, this synchronization
+of the ::auto_path and access path ("Sync Mode" on) is still the default.
+However, the Safe Base offers the option of limiting the safe interpreter's
+::auto_path to the much shorter list of directories that is necessary for
+it to perform its function ("Sync Mode" off). Use the command
+\fB::safe::setSyncMode\fR to choose the mode before creating any Safe
+Base interpreters.
+.PP
+In either mode, the most convenient way to initialize a safe interpreter is
+to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the
+\fB\-accessPath\fR or \fB\-autoPath\fR options (or with the \fB\-accessPath\fR
+option set to the
+empty list), which will give the safe interpreter the same access as the
+parent interpreter to packages, modules, and autoloader files. With
+"Sync Mode" off, the Safe Base will set the value of \fB\-autoPath\fR to the
+parent's ::auto_path, and will set the child's ::auto_path to a tokenized form
+of the parent's ::auto_path.
+.PP
+With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty
+list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or
+\fB::safe::interpConfigure\fR, it will be tokenized and used as the safe
+interpreter's ::auto_path. Any directories that do not also belong to the
+access path cannot be tokenized and will be silently ignored. However, the
+value of \fB\-autoPath\fR will remain as specified, and will be used to
+re-tokenize the child's ::auto_path if \fB::safe::interpConfigure\fR is called
+to change the value of \fB\-accessPath\fR.
+.PP
+With "Sync Mode" off, if the access path is reset to the values in the
+parent interpreter by calling \fB::safe::interpConfigure\fR with arguments
+\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the argument
+\fB\-autoPath\fR is supplied to specify a different value.
+.PP
+With "Sync Mode" off, if a non-empty value of \fB\-accessPath\fR is supplied, the
+safe interpreter's ::auto_path will be set to {} (by
+\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR) or left unchanged
+(by \fB::safe::interpConfigure\fR). If the same command specifies a new
+value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR argument has
+been processed.
+
+Examples of use with "Sync Mode" off: any of these commands will set the
+::auto_path to a tokenized form of its value in the parent interpreter:
+.RS
+.PP
+.CS
+ safe::interpCreate foo
+ safe::interpCreate foo -accessPath {}
+ safe::interpInit bar
+ safe::interpInit bar -accessPath {}
+ safe::interpConfigure foo -accessPath {}
+.CE
+.RE
+.PP
+Example of use with "Sync Mode" off: when initializing a safe interpreter
+with a non-empty access path, the ::auto_path will be set to {} unless its
+own value is also specified:
+.RS
+.PP
+.CS
+ safe::interpCreate foo -accessPath {
+ /usr/local/TclHome/lib/tcl8.6
+ /usr/local/TclHome/lib/tcl8.6/http1.0
+ /usr/local/TclHome/lib/tcl8.6/opt0.4
+ /usr/local/TclHome/lib/tcl8.6/msgs
+ /usr/local/TclHome/lib/tcl8.6/encoding
+ /usr/local/TclHome/lib
+ }
+
+ # The child's ::auto_path must be given a suitable value:
+
+ safe::interpConfigure foo -autoPath {
+ /usr/local/TclHome/lib/tcl8.6
+ /usr/local/TclHome/lib
+ }
+
+ # The two commands can be combined:
+
+ safe::interpCreate foo -accessPath {
+ /usr/local/TclHome/lib/tcl8.6
+ /usr/local/TclHome/lib/tcl8.6/http1.0
+ /usr/local/TclHome/lib/tcl8.6/opt0.4
+ /usr/local/TclHome/lib/tcl8.6/msgs
+ /usr/local/TclHome/lib/tcl8.6/encoding
+ /usr/local/TclHome/lib
+ } -autoPath {
+ /usr/local/TclHome/lib/tcl8.6
+ /usr/local/TclHome/lib
+ }
+.CE
+.RE
+.PP
+Example of use with "Sync Mode" off: the command
+\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's
+::auto_path, and so any necessary change must be made by the script:
+.RS
+.PP
+.CS
+ safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11
+
+ lassign [safe::interpConfigure foo -autoPath] DUM childAutoPath
+ lappend childAutoPath /usr/local/TclHome/lib/extras/Img1.4.11
+ safe::interpConfigure foo -autoPath $childAutoPath
+.CE
+.RE
.SH "SEE ALSO"
-interp(n), library(n), load(n), package(n), source(n), unknown(n)
+interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n),
+tm(n), unknown(n)
.SH KEYWORDS
alias, auto\-loading, auto_mkindex, load, parent interpreter, safe
interpreter, child interpreter, source
diff --git a/doc/self.n b/doc/self.n
index 0ad5428..14f68c7 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -12,7 +12,7 @@
self \- method call internal introspection
.SH SYNOPSIS
.nf
-package require TclOO
+package require tcl::oo
\fBself\fR ?\fIsubcommand\fR?
.fi
@@ -32,7 +32,12 @@ implement the current call chain. The first element is the same as would be
reported by \fBinfo object\fR \fBcall\fR for the current method (except that this
also reports useful values from within constructors and destructors, whose
names are reported as \fB<constructor>\fR and \fB<destructor>\fR
-respectively), and the second element is an index into the first element's
+respectively,
+.VS TIP500
+and for private methods, which are described as being \fBprivate\fR instead of
+being a \fBmethod\fR),
+.VE TIP500
+and the second element is an index into the first element's
list that indicates which actual implementation is currently executing (the
first implementation to execute is always at index 0).
.TP
diff --git a/doc/set.n b/doc/set.n
index f065087..890ef1d 100644
--- a/doc/set.n
+++ b/doc/set.n
@@ -73,3 +73,7 @@ practice instead of doing double-dereferencing):
expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n)
.SH KEYWORDS
read, write, variable
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/singleton.n b/doc/singleton.n
new file mode 100644
index 0000000..3ccbdd3
--- /dev/null
+++ b/doc/singleton.n
@@ -0,0 +1,99 @@
+'\"
+'\" Copyright (c) 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.
+'\"
+.TH singleton n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::singleton \- a class that does only allows one instance of itself
+.SH SYNOPSIS
+.nf
+package require tcl::oo
+
+\fBoo::singleton\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::singleton\fR
+.fi
+.BE
+.SH DESCRIPTION
+Singleton classes are classes that only permit at most one instance of
+themselves to exist. They unexport the \fBcreate\fR and
+\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method
+so that it only makes a new instance if there is no existing instance. It is
+not recommended to inherit from a singleton class; singleton-ness is \fInot\fR
+inherited. It is not recommended that a singleton class's constructor take any
+arguments.
+.PP
+Instances have their\fB destroy\fR method overridden with a method that always
+returns an error in order to discourage destruction of the object, but
+destruction remains possible if strictly necessary (e.g., by destroying the
+class or using \fBrename\fR to delete it). They also have a (non-exported)
+\fB<cloned>\fR method defined on them that similarly always returns errors to
+make attempts to use the singleton instance with \fBoo::copy\fR fail.
+.SS CONSTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy the singleton object).
+.SS "EXPORTED METHODS"
+.TP
+\fIcls \fBnew \fR?\fIarg ...\fR?
+.
+This returns the current instance of the singleton class, if one exists, and
+creates a new instance only if there is no existing instance. The additional
+arguments, \fIarg ...\fR, are only used if a new instance is actually
+manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR
+method.
+.RS
+.PP
+This is an override of the behaviour of a superclass's method with an
+identical call signature to the superclass's implementation.
+.RE
+.SS "NON-EXPORTED METHODS"
+The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and
+\fBcreateWithNamespace\fR are unexported; callers should not assume that they
+have control over either the name or the namespace name of the singleton instance.
+.SH EXAMPLE
+.PP
+This example demonstrates that there is only one instance even though the
+\fBnew\fR method is called three times.
+.PP
+.CS
+\fBoo::singleton\fR create Highlander {
+ method say {} {
+ puts "there can be only one"
+ }
+}
+
+set h1 [Highlander new]
+set h2 [Highlander new]
+if {$h1 eq $h2} {
+ puts "equal objects" \fI\(-> prints "equal objects"\fR
+}
+set h3 [Highlander new]
+if {$h1 eq $h3} {
+ puts "equal objects" \fI\(-> prints "equal objects"\fR
+}
+.CE
+.PP
+Note that the name of the instance of the singleton is not guaranteed to be
+anything in particular.
+.SH "SEE ALSO"
+oo::class(n)
+.SH KEYWORDS
+class, metaclass, object, single instance
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/socket.n b/doc/socket.n
index aa25bd4..b7b3228 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -131,6 +131,16 @@ wildcard address so that it can accept connections from any
interface. If \fIaddr\fR is a domain name that resolves to multiple IP
addresses that are available on the local machine, the socket will
listen on all of them.
+.TP
+\fB\-reuseaddr\fI boolean\fR
+.
+Tells the kernel whether to reuse the local address if there is no socket
+actively listening on it. This is the default on Windows.
+.TP
+\fB\-reuseport\fI boolean\fR
+.
+Tells the kernel whether to allow the binding of multiple sockets to the same
+address and port.
.PP
Server channels cannot be used for input or output; their sole use is to
accept new client connections. The channels created for each incoming
@@ -152,7 +162,8 @@ described below.
.SH "CONFIGURATION OPTIONS"
.PP
The \fBchan configure\fR command can be used to query several readonly
-configuration options for socket channels:
+configuration options for socket channels or in some cases to set
+alternative properties on socket channels:
.TP
\fB\-error\fR
.
@@ -194,6 +205,16 @@ list is identical to the address, its first element.
\fB\-connecting\fR
.
This option is not supported by server sockets. For client sockets, this option returns 1 if an asyncroneous connect is still in progress, 0 otherwise.
+.TP
+\fB\-keepalive\fR
+.
+This option sets or queries the TCP keepalive option on the socket as 1 if
+keepalive is turned on, 0 otherwise.
+.TP
+\fB\-nodelay\fR
+.
+This option sets or queries the TCP nodelay option on the socket as 1 if
+nodelay is turned on, 0 otherwise.
.PP
.SH "EXAMPLES"
.PP
diff --git a/doc/source.n b/doc/source.n
index 82fefa6..cee1312 100644
--- a/doc/source.n
+++ b/doc/source.n
@@ -37,17 +37,15 @@ allowing for files containing code and data segments (scripted documents).
If you require a
.QW ^Z
in code for string comparison, you can use
-.QW \e032
-or
-.QW \eu001a ,
+.QW \ex1A ,
which will be safely substituted by the Tcl interpreter into
.QW ^Z .
.PP
-A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, unicode).
+A leading BOM (Byte order mark) contained in the file is ignored for unicode encodings (utf-8, utf-16, ucs-2).
.PP
The \fB\-encoding\fR option is used to specify the encoding of
the data stored in \fIfileName\fR. When the \fB\-encoding\fR option
-is omitted, the system encoding is assumed.
+is omitted, the utf-8 encoding is assumed.
.SH EXAMPLE
.PP
Run the script in the file \fBfoo.tcl\fR and then the script in the
@@ -69,3 +67,7 @@ foreach scriptFile {foo.tcl bar.tcl} {
file(n), cd(n), encoding(n), info(n)
.SH KEYWORDS
file, script
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/string.n b/doc/string.n
index 2d53a98..aefe485 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -12,7 +12,7 @@
.SH NAME
string \- Manipulate strings
.SH SYNOPSIS
-\fBstring \fIoption arg \fR?\fIarg ...?\fR
+\fBstring \fIoption arg \fR?\fIarg ...\fR?
.BE
.SH DESCRIPTION
.PP
@@ -20,7 +20,7 @@ Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
\fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR?
-.VS 8.6.2
+.
Concatenate the given \fIstring\fRs just like placing them directly
next to each other and return the resulting compound string. If no
\fIstring\fRs are present, the result is an empty string.
@@ -32,7 +32,6 @@ of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR,
and is more efficient than building a list of arguments and using
\fBjoin\fR with an empty join string.
.RE
-.VE
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR
.
@@ -89,6 +88,24 @@ If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then this command returns an empty string.
.RE
.TP
+\fBstring insert \fIstring index insertString\fR
+.VS "TIP 504"
+Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the
+\fIindex\fR'th character. The \fIindex\fR may be specified as described in the
+\fBSTRING INDICES\fR section.
+.RS
+.PP
+If \fIindex\fR is start-relative, the first character inserted in the returned
+string will be at the specified index. If \fIindex\fR is end-relative, the last
+character inserted in the returned string will be at the specified index.
+.PP
+If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is
+\fB0\fR), \fIinsertString\fR is prepended to \fIstring\fR. If \fIindex\fR is at
+or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR),
+\fIinsertString\fR is appended to \fIstring\fR.
+.RE
+.VE "TIP 504"
+.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
.
Returns 1 if \fIstring\fR is a valid member of the specified character
@@ -111,17 +128,24 @@ Any character with a value less than \eu0080 (those that are in the
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 12
Any Unicode control character.
+.IP \fBdict\fR 12
+.VS TIP501
+Any proper dict structure, with optional surrounding whitespace. In
+case of improper dict structure, 0 is returned and the \fIvarname\fR
+will contain the index of the
+.QW element
+where the dict parsing fails, or \-1 if this cannot be determined.
+.VE TIP501
.IP \fBdigit\fR 12
Any Unicode digit character. Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 12
Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR.
.IP \fBentier\fR 12
-.VS 8.6
+.
Any of the valid string formats for an integer value of arbitrary size
in Tcl, with optional surrounding whitespace. The formats accepted are
exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR.
-.VE
.IP \fBfalse\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
@@ -268,7 +292,9 @@ the special interpretation of the characters \fB*?[]\e\fR in
.
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
-character whose index is \fIlast\fR. An index of 0 refers to the first
+character whose index is \fIlast\fR (using the forms described in
+\fBSTRING INDICES\fR). An index of \fB0\fR refers to the first
+character of the string; an index of \fBend\fR refers to last
character of the string. \fIfirst\fR and \fIlast\fR may be specified
as for the \fBindex\fR method. If \fIfirst\fR is less than zero then
it is treated as if it were zero, and if \fIlast\fR is greater than or
@@ -278,13 +304,16 @@ string is returned.
.TP
\fBstring repeat \fIstring count\fR
.
-Returns \fIstring\fR repeated \fIcount\fR number of times.
+Returns a string consisting of \fIstring\fR concatenated with itself
+\fIcount\fR times. If \fIcount\fR is 0, the empty string will be
+returned.
.TP
\fBstring replace \fIstring first last\fR ?\fInewstring\fR?
.
Removes a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
-character whose index is \fIlast\fR. An index of 0 refers to the
+character whose index is \fIlast\fR (using the forms described in
+\fBSTRING INDICES\fR). An index of 0 refers to the
first character of the string. \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method. If \fInewstring\fR is
specified, then it is placed in the removed character range. If
@@ -376,7 +405,7 @@ Formally, the \fBstring bytelength\fR operation returns the content of
the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling
\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated.
This is highly unlikely to be useful to Tcl scripts, as Tcl's internal
-encoding is not strict UTF\-8, but rather a modified CESU\-8 with a
+encoding is not strict UTF\-8, but rather a modified WTF\-8 with a
denormalized NUL (identical to that used in a number of places by
Java's serialization mechanism) to enable basic processing with
non-Unicode-aware C functions. As this representation should only
@@ -385,10 +414,10 @@ store the representation is of very low value (except to C extension
code, which has direct access for the purpose of memory management,
etc.)
.PP
-\fICompatibility note:\fR it is likely that this subcommand will be
-withdrawn in a future version of Tcl. It is better to use the
-\fBencoding convertto\fR command to convert a string to a known
-encoding and then apply \fBstring length\fR to that.
+\fICompatibility note:\fR This subcommand is deprecated and will
+be removed in Tcl 9.0. It is better to use the \fBencoding convertto\fR
+command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8")
+and then apply \fBstring length\fR to that.
.PP
.CS
\fBstring length\fR [encoding convertto utf-8 $theString]
@@ -477,7 +506,7 @@ if {$length == 0} {
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
-case conversion, compare, index, match, pattern, string, word, equal,
+case conversion, compare, index, integer value, match, pattern, string, word, equal,
ctype, character, reverse
.\" Local Variables:
.\" mode: nroff
diff --git a/doc/tclsh.1 b/doc/tclsh.1
index fa0ecc2..3a78737 100644
--- a/doc/tclsh.1
+++ b/doc/tclsh.1
@@ -38,15 +38,11 @@ read Tcl commands from the named file; \fBtclsh\fR will exit
when it reaches the end of the file.
The end of the file may be marked either by the physical end of
the medium, or by the character,
-.QW \e032
-.PQ \eu001a ", control-Z" .
+.PQ \ex1A ", control-Z" .
If this character is present in the file, the \fBtclsh\fR application
will read text up to but not including the character. An application
that requires this character in the file may safely encode it as
-.QW \e032 ,
-.QW \ex1A ,
-or
-.QW \eu001a ;
+.QW \ex1A ;
or may generate it by use of commands such as \fBformat\fR or \fBbinary\fR.
There is no automatic evaluation of \fB.tclshrc\fR when the name
of a script file is presented on the \fBtclsh\fR command
@@ -143,6 +139,15 @@ incomplete commands.
.SH "STANDARD CHANNELS"
.PP
See \fBTcl_StandardChannels\fR for more explanations.
+.SH ZIPVFS
+.PP
+When a zipfile is concatenated to the end of a \fBtclsh\fR, on
+startup the contents of the zip archive will be mounted as the
+virtual file system /zvfs. If a top level directory tcl8.6 is
+present in the zip archive, it will become the directory loaded
+as env(TCL_LIBRARY). If a file named \fBmain.tcl\fR is present
+in the top level directory of the zip archive, it will be sourced
+instead of the shell's normal command line handing.
.SH "SEE ALSO"
auto_path(n), encoding(n), env(n), fconfigure(n)
.SH KEYWORDS
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 1a5151a..965ed64 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -1179,7 +1179,6 @@ Here is a sketch of a sample test suite main script:
.RS
.PP
.CS
-package require Tcl 8.6
package require tcltest 2.5
package require example
\fB::tcltest::configure\fR -testdir \e
diff --git a/doc/tclvars.n b/doc/tclvars.n
index adefe40..4d1413c 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -322,11 +322,9 @@ The version number for the operating system running on this machine.
On UNIX machines, this is the value returned by \fBuname -r\fR.
.TP
\fBpathSeparator\fR
-.VS 8.6
'\" Defined by TIP #315
The character that should be used to \fBsplit\fR PATH-like environment
variables into their corresponding list of directory names.
-.VE 8.6
.TP
\fBplatform\fR
.
diff --git a/doc/tell.n b/doc/tell.n
index 1da240d..54fbae1 100644
--- a/doc/tell.n
+++ b/doc/tell.n
@@ -16,7 +16,7 @@ tell \- Return current access position for an open channel
.BE
.SH DESCRIPTION
.PP
-Returns an integer string giving the current access position in
+Returns an integer giving the current access position in
\fIchannelId\fR. This value returned is a byte offset that can be passed to
\fBseek\fR in order to set the channel to a particular position. Note
that this value is in terms of bytes, not characters like \fBread\fR.
@@ -46,3 +46,7 @@ if {[read $chan 6] eq "foobar"} {
file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3)
.SH KEYWORDS
access position, channel, seeking
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/timerate.n b/doc/timerate.n
index c5fdf30..5d49c86 100644
--- a/doc/timerate.n
+++ b/doc/timerate.n
@@ -35,10 +35,10 @@ if \fItime\fR is not specified.
.sp
The parameter \fImax-count\fR could additionally impose a further restriction
by the maximal number of iterations to evaluate the script.
-If \fImax-count\fR is specified, the evalution will stop either this count of
+If \fImax-count\fR is specified, the evaluation will stop either this count of
iterations is reached or the time is exceeded.
.sp
-It will then return a canonical tcl-list of the form:
+It will then return a canonical Tcl-list of the form:
.PP
.CS
\fB0.095977 \(mcs/# 52095836 # 10419167 #/sec 5000.000 net-ms\fR
@@ -85,7 +85,7 @@ used to measure the cost of \fBTcl_EvalObjEx\fR, of the invocation of canonical
lists, and of the uncompiled versions of bytecoded commands.
.PP
As opposed to the \fBtime\fR commmand, which runs the tested script for a fixed
-number of iterations, the timerate command runs it for a fixed time.
+number of iterations, the \fBtimerate\fR command runs it for a fixed time.
Additionally, the compiled variant of the script will be used during the entire
measurement, as if the script were part of a compiled procedure, if the \fB\-direct\fR
option is not specified. The fixed time period and possibility of compilation allow
diff --git a/doc/trace.n b/doc/trace.n
index 5482e59..9b8fd57 100644
--- a/doc/trace.n
+++ b/doc/trace.n
@@ -20,7 +20,8 @@ trace \- Monitor variable accesses, command usages and command executions
This command causes Tcl commands to be executed whenever certain operations are
invoked. The legal \fIoption\fRs (which may be abbreviated) are:
.TP
-\fBtrace add \fItype name ops ?args?\fR
+\fBtrace add \fItype name ops\fR ?\fIargs\fR?
+.
Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR.
.RS
.TP
@@ -237,7 +238,7 @@ if an entire array is being deleted and the trace was registered
on the overall array, rather than a single element, then \fIname1\fR
gives the array name and \fIname2\fR is an empty string.
\fIName1\fR and \fIname2\fR are not necessarily the same as the
-name used in the \fBtrace variable\fR command: the \fBupvar\fR
+name used in the \fBtrace add variable\fR command: the \fBupvar\fR
command allows a procedure to reference a variable under a
different name.
\fIOp\fR indicates what operation is being performed on the
diff --git a/doc/transchan.n b/doc/transchan.n
index 4da74f2..b9a0f21 100644
--- a/doc/transchan.n
+++ b/doc/transchan.n
@@ -11,7 +11,18 @@
.SH NAME
transchan \- command handler API of channel transforms
.SH SYNOPSIS
-\fBcmdPrefix \fIoption\fR ?\fIarg arg ...\fR?
+.nf
+\fBchan push \fIchannelName cmdPrefix\fR
+
+\fIcmdPrefix \fBclear \fIhandle\fR
+\fIcmdPrefix \fBdrain \fIhandle\fR
+\fIcmdPrefix \fBfinalize \fIhandle\fR
+\fIcmdPrefix \fBflush \fIhandle\fR
+\fIcmdPrefix \fBinitialize \fIhandle mode\fR
+\fIcmdPrefix \fBlimit? \fIhandle\fR
+\fIcmdPrefix \fBread \fIhandle buffer\fR
+\fIcmdPrefix \fBwrite \fIhandle buffer\fR
+.fi
.BE
.SH DESCRIPTION
.PP
diff --git a/doc/unknown.n b/doc/unknown.n
index 82dcefc..ee8a5be 100644
--- a/doc/unknown.n
+++ b/doc/unknown.n
@@ -89,3 +89,7 @@ proc \fBunknown\fR args {
info(n), proc(n), interp(n), library(n), namespace(n)
.SH KEYWORDS
error, non-existent command, unknown
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/unload.n b/doc/unload.n
index 61caca1..00b709b 100644
--- a/doc/unload.n
+++ b/doc/unload.n
@@ -90,7 +90,7 @@ detached from the process.
The unload procedure must match the following prototype:
.PP
.CS
-typedef int \fBTcl_PackageUnloadProc\fR(
+typedef int \fBTcl_LibraryUnloadProc\fR(
Tcl_Interp *\fIinterp\fR,
int \fIflags\fR);
.CE
@@ -122,7 +122,8 @@ Tcl tries to guess the prefix. This may be done differently on
different platforms. The default guess, which is used on most
UNIX platforms, is to take the last element of
\fIfileName\fR, strip off the first three characters if they
-are \fBlib\fR, and use any following alphabetic and
+are \fBlib\fR, then strip off the next three characters if they
+are \fBtcl\fR, and use any following alphabetic and
underline characters, converted to titlecase as the prefix.
For example, the command \fBunload libxyz4.2.so\fR uses the prefix
\fBXyz\fR and the command \fBunload bin/last.so {}\fR uses the
diff --git a/doc/update.n b/doc/update.n
index ce0fb25..a85faac 100644
--- a/doc/update.n
+++ b/doc/update.n
@@ -63,3 +63,7 @@ while {!$done} {
after(n), interp(n)
.SH KEYWORDS
asynchronous I/O, event, flush, handler, idle, update
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/uplevel.n b/doc/uplevel.n
index 4decc6d..cda1652 100644
--- a/doc/uplevel.n
+++ b/doc/uplevel.n
@@ -24,9 +24,9 @@ the result of that evaluation.
If \fIlevel\fR is an integer then
it gives a distance (up the procedure calling stack) to move before
executing the command. If \fIlevel\fR consists of \fB#\fR followed by
-a number then the number gives an absolute level number. If \fIlevel\fR
+a integer then the level gives an absolute level. If \fIlevel\fR
is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be
-defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR.
+defaulted if the first \fIcommand\fR argument is an integer or starts with \fB#\fR.
.PP
For example, suppose that procedure \fBa\fR was invoked
from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR.
diff --git a/doc/upvar.n b/doc/upvar.n
index 91defe6..5d697dd 100644
--- a/doc/upvar.n
+++ b/doc/upvar.n
@@ -94,7 +94,7 @@ proc \fIsetByUpvar\fR { name value } {
set localVar $value
}
set originalVar 1
-trace variable originalVar w \fItraceproc\fR
+trace add variable originalVar write \fItraceproc\fR
\fIsetByUpvar\fR originalVar 2
.CE
.PP
diff --git a/doc/vwait.n b/doc/vwait.n
index f64d39c..e595a74 100644
--- a/doc/vwait.n
+++ b/doc/vwait.n
@@ -12,6 +12,8 @@
vwait \- Process events until a variable is written
.SH SYNOPSIS
\fBvwait\fR \fIvarName\fR
+.sp
+\fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR?
.BE
.SH DESCRIPTION
.PP
@@ -24,8 +26,75 @@ command will return as soon as the event handler that modified
a variable name with respect to the global namespace, but can refer to any
namespace's variables if the fully-qualified name is given.
.PP
+In the second more complex command form \fIoptions\fR allow for finer
+control of the wait operation and to deal with multiple event sources.
+\fIOptions\fR can be made up of
+.TP
+\fB\-\-\fR
+.
+Marks the end of options. All following arguments are handled as
+variable names.
+.TP
+\fB\-all\fR
+.
+All conditions for the wait operation must be met to complete the
+wait operation. Otherwise (the default) the first event completes
+the wait.
+.TP
+\fB\-extended\fR
+.
+An extended result in list form is returned, see below for explanation.
+.TP
+\fB\-nofileevents\fR
+.
+File events are not handled in the wait operation.
+.TP
+\fB\-noidleevents\fR
+.
+Idle handlers are not invoked during the wait operation.
+.TP
+\fB\-notimerevents\fR
+.
+Timer handlers are not serviced during the wait operation.
+.TP
+\fB\-nowindowevents\fR
+.
+Events of the windowing system are not handled during the wait operation.
+.TP
+\fB\-readable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR
+is or becomes readable the wait operation completes.
+.TP
+\fB\-timeout\fR \fImilliseconds\fR
+.
+The wait operation is constrained to \fImilliseconds\fR.
+.TP
+\fB\-variable\fR \fIvarName\fR
+.
+\fIVarName\fR must be the name of a global variable. Writing or
+unsetting this variable completes the wait operation.
+.TP
+\fB\-writable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for writing. If \fIchannel\fR
+is or becomes writable the wait operation completes.
+.PP
+The result returned by \fBvwait\fR is for the simple form an empty
+string. If the \fI\-timeout\fR option is specified, the result is the
+number of milliseconds remaining when the wait condition has been
+met, or -1 if the wait operation timed out.
+.PP
+If the \fI\-extended\fR option is specified, the result is made up
+of a Tcl list with an even number of elements. Odd elements
+take the values \fBreadable\fR, \fBtimeleft\fR, \fBvariable\fR,
+and \fBwritable\fR. Even elements are the corresponding variable
+and channel names or the remaining number of milliseconds.
+The list is ordered by the occurrences of the event(s) with the
+exception of \fBtimeleft\fR which always comes last.
+.PP
In some cases the \fBvwait\fR command may not return immediately
-after \fIvarName\fR is set. This happens if the event handler
+after \fIvarName\fR et.al. is set. This happens if the event handler
that sets \fIvarName\fR does not complete immediately. For example,
if an event handler sets \fIvarName\fR and then itself calls
\fBvwait\fR to wait for a different variable, then it may not return
diff --git a/doc/while.n b/doc/while.n
index 961260c..6acc909 100644
--- a/doc/while.n
+++ b/doc/while.n
@@ -63,3 +63,7 @@ set lineCount 0
break(n), continue(n), for(n), foreach(n)
.SH KEYWORDS
boolean, loop, test, while
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/zipfs.3 b/doc/zipfs.3
new file mode 100644
index 0000000..571647f
--- /dev/null
+++ b/doc/zipfs.3
@@ -0,0 +1,130 @@
+'\"
+'\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com>
+'\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de>
+'\" Copyright (c) 2017 Sean Woods <yoda@etoyoc.com>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH Tclzipfs 3 8.7 Tcl "Tcl Library Procedures"
+.so man.macros
+.BS
+.SH NAME
+TclZipfs_AppHook, TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount \- handle ZIP files as Tcl virtual filesystems
+.SH SYNOPSIS
+.nf
+const char *
+\fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR)
+.sp
+int
+\fBTclZipfs_Mount\fR(\fIinterp, zipname, mountpoint, password\fR)
+.sp
+int
+\fBTclZipfs_MountBuffer\fR(\fIinterp, data, dataLen, mountpoint, copy\fR)
+.sp
+int
+\fBTclZipfs_Unmount\fR(\fIinterp, mountpoint\fR)
+.fi
+.SH ARGUMENTS
+.AS Tcl_Interp *mountpoint in
+.AP "int" *argcPtr in
+Pointer to a variable holding the number of command line arguments from
+\fBmain\fR().
+.AP "char" ***argvPtr in
+Pointer to an array of strings containing the command line arguments to
+\fBmain\fR().
+.AP Tcl_Interp *interp in
+Interpreter in which the ZIP file system is mounted. The interpreter's result is
+modified to hold the result or error message from the script.
+.AP "const char" *zipname in
+Name of a ZIP file. Must not be NULL when either mounting or unmounting a ZIP.
+.AP "const char" *mountpoint in
+Name of a mount point, which must be a legal Tcl file or directory name. May
+be NULL to query current mount points.
+.AP "const char" *password in
+An (optional) password. Use NULL if no password is wanted to read the file.
+.AP "const void" *data in
+A data buffer to mount. The data buffer must hold the contents of a ZIP
+archive, and must not be NULL.
+.AP size_t dataLen in
+The number of bytes in the supplied data buffer argument, \fIdata\fR.
+.AP int copy in
+If non-zero, the ZIP archive in the data buffer will be internally copied
+before mounting, allowing the data buffer to be disposed once
+\fBTclZipfs_MountBuffer\fR returns. If zero, the caller guarantees that the
+buffer will be valid to read from for the duration of the mount.
+.BE
+.SH DESCRIPTION
+\fBTclZipfs_AppHook\fR is a utility function to perform standard application
+initialization procedures, taking into account available ZIP archives as
+follows:
+.IP [1]
+If the current application has a mountable ZIP archive, that archive is
+mounted under \fIZIPFS_VOLUME\fBapp\fR as a read-only Tcl virtual file
+system. \fIZIPFS_VOLUME\fR is \fB//zipfs:/\fR on all platforms.
+.IP [2]
+If a file named \fBmain.tcl\fR is located in the root directory of that file
+system (i.e., at \fIZIPROOT\fB/app/main.tcl\fR after the ZIP archive is
+mounted as described above) it is treated as the startup script for the
+process.
+.IP [3]
+If the file \fIZIPROOT\fB/app/tcl_library/init.tcl\fR is present, the
+\fBtcl_library\fR global variable in the initial Tcl interpreter is set to
+\fIZIPROOT\fB/app/tcl_library\fR.
+.IP [4]
+If the directory \fBtcl_library\fR was not found in the main application
+mount, the system will then search for it as either a VFS attached to the
+application dynamic library, or as a zip archive named
+\fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the
+present working directory or in the standard Tcl install location. (For
+example, the Tcl 8.7.2 release would be searched for in a file
+\fBlibtcl_8_7_2.zip\fR.) That archive, if located, is also mounted read-only.
+.PP
+On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since
+it uses WCHAR instead of char. As a result, it requires your application to
+be compiled with the UNICODE preprocessor symbol defined (e.g., via the
+\fB-DUNICODE\fR compiler flag).
+.PP
+The result of \fBTclZipfs_AppHook\fR is the full Tcl version with build
+information (e.g., \fB8.7.0+abcdef...abcdef.gcc-1002\fR).
+The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and
+\fIargvPtr\fR to remove arguments; the current implementation does not do so,
+but callers \fIshould not\fR assume that this will be true in the future.
+.PP
+\fBTclZipfs_Mount\fR is used to mount ZIP archives and to retrieve information
+about currently mounted archives. If \fImountpoint\fR and \fIzipname\fR are both
+specified (i.e. non-NULL), the function mounts the ZIP archive \fIzipname\fR on
+the mount point given in \fImountpoint\fR. If \fIpassword\fR is not NULL, it
+should point to the NUL terminated password protecting the archive. If not under
+the zipfs file system root, \fImountpoint\fR is normalized with respect to it.
+For example, a mount point passed as either \fBmt\fR \fB/mt\fR would be
+normalized to \fB//zipfs:/mt\fR. An error is raised if the mount point includes
+a drive or UNC volume. On success, \fIinterp\fR's result is set to the
+normalized mount point path.
+.PP
+If \fImountpoint\fR is a NULL pointer, information on all currently mounted ZIP
+file systems is stored in \fIinterp\fR's result as a sequence of mount
+points and ZIP file names.
+.PP
+If \fImountpoint\fR is not NULL but \fIzipfile\fR
+is NULL, the path to the archive mounted at that mount point is stored
+as \fIinterp\fR's result. The function returns a standard Tcl result
+code.
+.PP
+\fBTclZipfs_MountBuffer\fR mounts the ZIP archive content \fIdata\fR on the
+mount point given in \fImountpoint\fR. Both \fImountpoint\fR and \fIdata\fR must
+be specified as non-NULL. The \fIcopy\fR argument determines whether the buffer
+is internally copied before mounting or not. The ZIP archive is assumed to be
+not password protected. On success, \fIinterp\fR's result is set to the
+normalized mount point path.
+.PP
+\fBTclZipfs_Unmount\fR undoes the effect of \fBTclZipfs_Mount\fR, i.e., it
+unmounts the mounted ZIP file system that was mounted from \fIzipname\fR (at
+\fImountpoint\fR). Errors are reported in the interpreter \fIinterp\fR. The
+result of this call is a standard Tcl result code.
+.PP
+\fBTclZipfs_AppHook\fR can not be used in stub-enabled extensions.
+.SH "SEE ALSO"
+zipfs(n)
+.SH KEYWORDS
+compress, filesystem, zip
diff --git a/doc/zipfs.n b/doc/zipfs.n
new file mode 100644
index 0000000..0a05078
--- /dev/null
+++ b/doc/zipfs.n
@@ -0,0 +1,293 @@
+'\"
+'\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com>
+'\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de>
+'\" Copyright (c) 2015 Sean Woods <yoda@etoyoc.com>
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH zipfs n 1.0 Zipfs "zipfs Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+zipfs \- Mount and work with ZIP files within Tcl
+.SH SYNOPSIS
+.nf
+\fBpackage require tcl::zipfs \fR?\fB1.0\fR?
+.sp
+\fBzipfs canonical\fR ?\fImntpnt\fR? \fIfilename\fR ?\fIZIPFS\fR?
+\fBzipfs exists\fR \fIfilename\fR
+\fBzipfs find\fR \fIdirectoryName\fR
+\fBzipfs info\fR \fIfilename\fR
+\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR?
+\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR?
+\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR?
+\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR?
+\fBzipfs mkkey\fR \fIpassword\fR
+\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR?
+\fBzipfs mount\fR ?\fIzipfile\fR? ?\fImountpoint\fR? ?\fIpassword\fR?
+\fBzipfs root\fR
+\fBzipfs unmount\fR \fImountpoint\fR
+.fi
+'\" The following subcommand is *UNDOCUMENTED*
+'\" \fBzipfs mount_data\fR ?\fIdata\fR ?\fImountpoint\fR??
+.BE
+.SH DESCRIPTION
+.PP
+The \fBzipfs\fR command provides Tcl with the ability to mount the
+contents of a ZIP archive file as a virtual file system. Tcl's ZIP
+archive support is limited to basic features and options.
+Supported storage methods include only STORE and DEFLATE with optional
+simple encryption, sufficient to prevent casual inspection of their contents
+but not able to prevent access by even a moderately determined attacker.
+Strong encryption, multi-part archives, platform metadata,
+zip64 formats and other compression methods like bzip2 are not supported.
+.PP
+Files within mounted archives can be written to but new files or directories
+cannot be created. Further, modifications to files are limited to the
+mounted archive in memory and are not persisted to disk.
+.PP
+Paths in mounted archives are case-sensitive on all platforms.
+.TP
+\fBzipfs canonical\fR ?\fImountpoint\fR? \fIfilename\fR ?\fIinZipfs\fR?
+.
+This takes the name of a file, \fIfilename\fR, and produces where it would be
+mapped into a zipfs mount as its result. If specified, \fImountpoint\fR says
+within which mount the mapping will be done; if omitted, the main root of the
+zipfs system is used. The \fIinZipfs\fR argument is a an optional boolean
+which controls whether to fully canonicalise the name; it defaults to true.
+.TP
+\fBzipfs exists\fR \fIfilename\fR
+.
+Return 1 if the given filename exists in the mounted zipfs and 0 if it does not.
+.TP
+\fBzipfs find\fR \fIdirectoryName\fR
+.
+Returns the list of paths under directory \fIdirectoryName\fR which need not be
+within a zipfs mounted archive. The paths are prefixed with \fIdirectoryName\fR.
+This command is also used by the \fBzipfs mkzip\fR and \fBzipfs mkimg\fR
+commands.
+.TP
+\fBzipfs info\fR \fIfile\fR
+.
+Return information about the given \fIfile\fR in the mounted zipfs. The
+information consists of:
+.RS
+.IP (1)
+the name of the ZIP archive file that contains the file,
+.IP (2)
+the size of the file after decompressions,
+.IP (3)
+the compressed size of the file, and
+.IP (4)
+the offset of the compressed data in the ZIP archive file.
+.PP
+As a special case, querying the mount point gives the start of the zip data as the offset
+in (4), which can be used to truncate the zip information from an executable.
+Querying an ancestor of a mount point will raise an error.
+.RE
+.TP
+\fBzipfs list\fR ?(\fB\-glob\fR|\fB\-regexp\fR)? ?\fIpattern\fR?
+.
+If \fIpattern\fR is not specified, the command returns a list of files across
+all zipfs mounted archives. If \fIpattern\fR is specified, only those paths
+matching the pattern are returned. By default, or with the \fB-glob\fR option,
+the pattern is treated as a glob pattern and matching is done as described for
+the \fBstring match\fR command. Alternatively, the \fB-regexp\fR option may be
+used to specify matching \fBpattern\fR as a regular expression. The file names
+are returned in arbitrary order. Note that path separators are treated as
+ordinary characters in the matching. Thus forward slashes should be used
+as path separators in the pattern. The returned paths only include those
+actually in the archive and does not include intermediate directories in
+mount paths.
+.TP
+\fBzipfs mount\fR
+.TP
+\fBzipfs mount\fR \fImountpoint\fR
+.TP
+\fBzipfs mount\fR \fIzipfile\fR \fImountpoint\fR ?\fIpassword\fR?
+.RS
+.PP
+The \fBzipfs mount\fR command mounts ZIP archives as Tcl virtual file systems
+and returns information about current mounts.
+.PP
+With no arguments, the command returns a dictionary mapping
+mount points to the path of the corresponding ZIP archive.
+.PP
+In the single argument form, the command returns the file path
+of the ZIP archive mounted at the specified mount point.
+.PP
+In the third form, the command mounts the ZIP archive \fIzipfile\fR as a Tcl virtual
+filesystem at \fImountpoint\fR. After this command executes, files contained
+in \fIzipfile\fR will appear to Tcl to be regular files at the mount point.
+If \fImountpoint\fR is
+specified as an empty string, it is defaulted to the \fB[zipfs root]\fR.
+The command returns the normalized mount point path.
+.PP
+If not under the zipfs file system root, \fImountpoint\fR is normalized with
+respect to it. For example, a mount point passed as either \fBmt\fR \fB/mt\fR
+would be normalized to \fB//zipfs:/mt\fR. An error is raised if the mount point
+includes a drive or UNC volume.
+.PP
+\fBNB:\fR because the current working directory is a concept maintained by the
+operating system, using \fBcd\fR into a mounted archive will only work in the
+current process, and then not entirely consistently (e.g., if a shared library
+uses direct access to the OS rather than through Tcl's filesystem API, it will
+not see the current directory as being inside the mount and will not be able
+to access the files inside the mount).
+.RE
+.TP
+\fBzipfs root\fR
+.
+Returns a constant string which indicates the mount point for zipfs volumes
+for the current platform.
+This value is
+.QW \fB//zipfs:/\fR
+on most platforms.
+.TP
+\fBzipfs unmount \fImountpoint\fR
+.
+Unmounts a previously mounted ZIP archive mounted to \fImountpoint\fR.
+The command will fail with an error exception if
+there are any files within the mounted archive are open.
+.SS "ZIP CREATION COMMANDS"
+This package also provides several commands to aid the creation of ZIP
+archives as Tcl applications.
+.TP
+\fBzipfs mkzip\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR?
+.
+Creates a ZIP archive file named \fIoutfile\fR from the contents of the input
+directory \fIindir\fR (contained regular files only) with optional ZIP
+password \fIpassword\fR. While processing the files below \fIindir\fR the
+optional file name prefix given in \fIstrip\fR is stripped off the beginning
+of the respective file name. When stripping, it is common to remove either
+the whole source directory name or the name of its parent directory.
+.RS
+.PP
+\fBCaution:\fR the choice of the \fIindir\fR parameter (less the optional
+stripped prefix) determines the later root name of the archive's content.
+.RE
+.TP
+\fBzipfs mkimg\fR \fIoutfile indir\fR ?\fIstrip\fR? ?\fIpassword\fR? ?\fIinfile\fR?
+.
+Creates an image (potentially a new executable file) similar to \fBzipfs
+mkzip\fR; see that command for a description of most parameters to this
+command, as they behave identically here.
+.RS
+.PP
+If the \fIinfile\fR parameter is specified, this file is prepended in front of
+the ZIP archive, otherwise the file returned by \fBinfo nameofexecutable\fR
+(i.e., the executable file of the running process) is used. If the
+\fIpassword\fR parameter is not empty, an obfuscated version of that password
+(see \fBzipfs mkkey\fR) is placed between the image and ZIP chunks of the
+output file and the contents of the ZIP chunk are protected with that
+password.
+If the starting image has a ZIP archive already attached to it, it is removed
+from the copy in \fIoutfile\fR before the new ZIP archive is added.
+.PP
+If there is a file, \fBmain.tcl\fR, in the root directory of the resulting
+archive and the image file that the archive is attached to is a \fBtclsh\fR
+(or \fBwish\fR) instance (true by default, but depends on your configuration),
+then the resulting image is an executable that will \fBsource\fR the script in
+that \fBmain.tcl\fR after mounting the ZIP archive, and will \fBexit\fR once
+that script has been executed.
+.PP
+\fBCaution:\fR highly experimental, not usable on Android, only partially
+tested on Linux and Windows.
+.RE
+.TP
+\fBzipfs mkkey\fR \fIpassword\fR
+.
+Given the clear text \fIpassword\fR argument, an obfuscated string version is
+returned with the same format used in the \fBzipfs mkimg\fR command.
+.TP
+\fBzipfs lmkimg\fR \fIoutfile inlist\fR ?\fIpassword infile\fR?
+.
+This command is like \fBzipfs mkimg\fR, but instead of an input directory,
+\fIinlist\fR must be a Tcl list where the odd elements are the names of files
+to be copied into the archive in the image, and the even elements are their
+respective names within that archive.
+.TP
+\fBzipfs lmkzip\fR \fIoutfile inlist\fR ?\fIpassword\fR?
+.
+This command is like \fBzipfs mkzip\fR, but instead of an input directory,
+\fIinlist\fR must be a Tcl list where the odd elements are the names of files
+to be copied into the archive, and the even elements are their respective
+names within that archive.
+.SH "EXAMPLES"
+.PP
+Mounting an ZIP archive as an application directory and running code out of it
+before unmounting it again:
+.PP
+.CS
+set zip myApp.zip
+set base [file join [\fBzipfs root\fR] myApp]
+
+\fBzipfs mount\fR $zip $base
+# $base now has the contents of myApp.zip
+
+source [file join $base app.tcl]
+# use the contents, load libraries from it, etc...
+
+\fBzipfs unmount\fR $base
+.CE
+.PP
+Creating a ZIP archive, given that a directory exists containing the content
+to put in the archive. Note that the source directory is given twice, in order
+to strip the exterior directory name from each filename in the archive.
+.PP
+.CS
+set sourceDirectory [file normalize myApp]
+set targetZip myApp.zip
+
+\fBzipfs mkzip\fR $targetZip $sourceDirectory $sourceDirectory
+.CE
+.PP
+Encryption can be applied to ZIP archives by providing a password when
+building the ZIP and when mounting it.
+.PP
+.CS
+set zip myApp.zip
+set sourceDir [file normalize myApp]
+set password "hunter2"
+set base [file join [\fBzipfs root\fR] myApp]
+
+# Create with password
+\fBzipfs mkzip\fR $targetZip $sourceDir $sourceDir $password
+
+# Mount with password
+\fBzipfs mount\fR $zip $base $password
+.CE
+.PP
+When creating an executable image with a password, the password is placed
+within the executable in a shrouded form so that the application can read
+files inside the embedded ZIP archive yet casual inspection cannot read it.
+.PP
+.CS
+set appDir [file normalize myApp]
+set img "myApp.bin"
+set password "hunter2"
+
+# Create some simple content to define a basic application
+file mkdir $appDir
+set f [open $appDir/main.tcl]
+puts $f {
+ puts "Hi. This is [info script]"
+}
+close $f
+
+# Create the executable
+\fBzipfs mkimg\fR $img $appDir $appDir $password
+
+# Launch the executable, printing its output to stdout
+exec $img >@stdout
+# prints: \fIHi. This is //zipfs:/app/main.tcl\fR
+.CE
+.SH "SEE ALSO"
+tclsh(1), file(n), zipfs(3), zlib(n)
+.SH "KEYWORDS"
+compress, filesystem, zip
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/generic/regc_color.c b/generic/regc_color.c
index dc9f5b4..f1e25d2 100644
--- a/generic/regc_color.c
+++ b/generic/regc_color.c
@@ -2,7 +2,7 @@
* colorings of characters
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -761,7 +761,7 @@ dumpcolors(
chr c;
const char *has;
- fprintf(f, "max %ld\n", (long) cm->max);
+ fprintf(f, "max %" TCL_Z_MODIFIER "u\n", cm->max);
if (NBYTS > 1) {
fillcheck(cm, cm->tree, 0, f);
}
diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c
index d450d3e..3b4f1e4 100644
--- a/generic/regc_cvec.c
+++ b/generic/regc_cvec.c
@@ -2,7 +2,7 @@
* Utility functions for handling cvecs
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index d96d22f..eb068b4 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -2,7 +2,7 @@
* lexical analyzer
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -457,7 +457,7 @@ next(
if (ATEOS()) {
FAILW(REG_EESCAPE);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
switch (v->nexttype) { /* not all escapes okay here */
case PLAIN:
return 1;
@@ -716,7 +716,7 @@ next(
}
RETV(PLAIN, *v->now++);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
@@ -775,7 +775,7 @@ lexescape(
NOTE(REG_UNONPOSIX);
switch (c) {
case CHR('a'):
- RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007')));
+ RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\x07')));
break;
case CHR('A'):
RETV(SBEGIN, 0);
@@ -803,7 +803,7 @@ lexescape(
break;
case CHR('e'):
NOTE(REG_UUNPORT);
- RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033')));
+ RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\x1B')));
break;
case CHR('f'):
RETV(PLAIN, CHR('\f'));
@@ -1141,7 +1141,7 @@ skip(
/*
- newline - return the chr for a newline
* This helps confine use of CHR to this source file.
- ^ static chr newline(NOPARMS);
+ ^ static chr newline(void);
*/
static chr
newline(void)
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index 449cff6..adeb0bd 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -4,7 +4,7 @@
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,49 +16,49 @@ static const struct cname {
const char *name;
const char code;
} cnames[] = {
- {"NUL", '\0'},
- {"SOH", '\001'},
- {"STX", '\002'},
- {"ETX", '\003'},
- {"EOT", '\004'},
- {"ENQ", '\005'},
- {"ACK", '\006'},
- {"BEL", '\007'},
- {"alert", '\007'},
- {"BS", '\010'},
- {"backspace", '\b'},
- {"HT", '\011'},
- {"tab", '\t'},
- {"LF", '\012'},
- {"newline", '\n'},
- {"VT", '\013'},
- {"vertical-tab", '\v'},
- {"FF", '\014'},
- {"form-feed", '\f'},
- {"CR", '\015'},
- {"carriage-return", '\r'},
- {"SO", '\016'},
- {"SI", '\017'},
- {"DLE", '\020'},
- {"DC1", '\021'},
- {"DC2", '\022'},
- {"DC3", '\023'},
- {"DC4", '\024'},
- {"NAK", '\025'},
- {"SYN", '\026'},
- {"ETB", '\027'},
- {"CAN", '\030'},
- {"EM", '\031'},
- {"SUB", '\032'},
- {"ESC", '\033'},
- {"IS4", '\034'},
- {"FS", '\034'},
- {"IS3", '\035'},
- {"GS", '\035'},
- {"IS2", '\036'},
- {"RS", '\036'},
- {"IS1", '\037'},
- {"US", '\037'},
+ {"NUL", '\x00'},
+ {"SOH", '\x01'},
+ {"STX", '\x02'},
+ {"ETX", '\x03'},
+ {"EOT", '\x04'},
+ {"ENQ", '\x05'},
+ {"ACK", '\x06'},
+ {"BEL", '\x07'},
+ {"alert", '\x07'},
+ {"BS", '\x08'},
+ {"backspace", '\x08'},
+ {"HT", '\x09'},
+ {"tab", '\x09'},
+ {"LF", '\x0A'},
+ {"newline", '\x0A'},
+ {"VT", '\x0B'},
+ {"vertical-tab", '\x0B'},
+ {"FF", '\x0C'},
+ {"form-feed", '\x0C'},
+ {"CR", '\x0D'},
+ {"carriage-return", '\x0D'},
+ {"SO", '\x0E'},
+ {"SI", '\x0F'},
+ {"DLE", '\x10'},
+ {"DC1", '\x11'},
+ {"DC2", '\x12'},
+ {"DC3", '\x13'},
+ {"DC4", '\x14'},
+ {"NAK", '\x15'},
+ {"SYN", '\x16'},
+ {"ETB", '\x17'},
+ {"CAN", '\x18'},
+ {"EM", '\x19'},
+ {"SUB", '\x1A'},
+ {"ESC", '\x1B'},
+ {"IS4", '\x1C'},
+ {"FS", '\x1C'},
+ {"IS3", '\x1D'},
+ {"GS", '\x1D'},
+ {"IS2", '\x1E'},
+ {"RS", '\x1E'},
+ {"IS1", '\x1F'},
+ {"US", '\x1F'},
{"space", ' '},
{"exclamation-mark",'!'},
{"quotation-mark", '"'},
@@ -861,7 +861,7 @@ element(
*/
Tcl_DStringInit(&ds);
- np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
+ np = Tcl_UniCharToUtfDString(startp, len, &ds);
for (cn=cnames; cn->name!=NULL; cn++) {
if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
break; /* NOTE BREAK OUT */
@@ -1273,7 +1273,7 @@ cmp(
const chr *x, const chr *y, /* strings to compare */
size_t len) /* exact length of comparison */
{
- return memcmp(VS(x), VS(y), len*sizeof(chr));
+ return memcmp((void*)(x), (void*)(y), len*sizeof(chr));
}
/*
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index bd98508..71bcb09 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -2,7 +2,7 @@
* NFA utilities.
* This file is #included by regcomp.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -843,7 +843,7 @@ moveins(
/*
- copyins - copy in arcs of a state to another state
- ^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyins(struct nfa *, struct state *, struct state *, int);
*/
static void
copyins(
@@ -1100,7 +1100,7 @@ moveouts(
/*
- copyouts - copy out arcs of a state to another state
- ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyouts(struct nfa *, struct state *, struct state *, int);
*/
static void
copyouts(
diff --git a/generic/regcomp.c b/generic/regcomp.c
index 1d13876..983cd7a 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -2,7 +2,7 @@
* re_*comp and friends - compile REs
* This file #includes several others (see the bottom).
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -56,7 +56,7 @@ static const chr *scanplain(struct vars *);
static void onechr(struct vars *, pchr, struct state *, struct state *);
static void dovec(struct vars *, struct cvec *, struct state *, struct state *);
static void wordchrs(struct vars *);
-static struct subre *subre(struct vars *, int, int, struct state *, struct state *);
+static struct subre *sub_re(struct vars *, int, int, struct state *, struct state *);
static void freesubre(struct vars *, struct subre *);
static void freesrnode(struct vars *, struct subre *);
static int numst(struct subre *, int);
@@ -81,7 +81,7 @@ static int lexescape(struct vars *);
static int lexdigits(struct vars *, int, int, int);
static int brenext(struct vars *, pchr);
static void skip(struct vars *);
-static chr newline(NOPARMS);
+static chr newline(void);
static chr chrnamed(struct vars *, const chr *, const chr *, pchr);
/* === regc_color.c === */
static void initcm(struct vars *, struct colormap *);
@@ -205,11 +205,11 @@ struct vars {
int cflags; /* copy of compile flags */
int lasttype; /* type of previous token */
int nexttype; /* type of next token */
- chr nextvalue; /* value (if any) of next token */
+ int nextvalue; /* value (if any) of next token */
int lexcon; /* lexical context type (see lex.c) */
int nsubexp; /* subexpression count */
struct subre **subs; /* subRE pointer vector */
- size_t nsubs; /* length of vector */
+ int nsubs; /* length of vector */
struct subre *sub10[10]; /* initial vector, enough for most */
struct nfa *nfa; /* the NFA */
struct colormap *cm; /* character color map */
@@ -287,8 +287,7 @@ compile(
{
AllocVars(v);
struct guts *g;
- int i;
- size_t j;
+ int i, j;
FILE *debug = (flags&REG_PROGRESS) ? stdout : NULL;
#define CNOERR() { if (ISERR()) return freev(v, v->err); }
@@ -341,13 +340,13 @@ compile(
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
- re->re_fns = (char *)&functions;
+ re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
- re->re_guts = (char *)(MALLOC(sizeof(struct guts)));
+ re->re_guts = (void*)(MALLOC(sizeof(struct guts)));
if (re->re_guts == NULL) {
return freev(v, REG_ESPACE);
}
@@ -433,7 +432,7 @@ compile(
* Can sacrifice main NFA now, so use it as work area.
*/
- (DISCARD) optimize(v->nfa, debug);
+ (void) optimize(v->nfa, debug);
CNOERR();
makesearch(v, v->nfa);
CNOERR();
@@ -476,10 +475,10 @@ moresubs(
int wanted) /* want enough room for this one */
{
struct subre **p;
- size_t n;
+ int n;
- assert(wanted > 0 && (size_t)wanted >= v->nsubs);
- n = (size_t)wanted * 3 / 2 + 1;
+ assert(wanted > 0 && wanted >= v->nsubs);
+ n = wanted * 3 / 2 + 1;
if (v->subs == v->sub10) {
p = (struct subre **) MALLOC(n * sizeof(struct subre *));
if (p != NULL) {
@@ -498,7 +497,7 @@ moresubs(
*p = NULL;
}
assert(v->nsubs == n);
- assert((size_t)wanted < v->nsubs);
+ assert(wanted < v->nsubs);
}
/*
@@ -664,7 +663,7 @@ parse(
assert(stopper == ')' || stopper == EOS);
- branches = subre(v, '|', LONGER, init, final);
+ branches = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branches;
firstbranch = 1;
@@ -674,7 +673,7 @@ parse(
* Need a place to hang the branch.
*/
- branch->right = subre(v, '|', LONGER, init, final);
+ branch->right = sub_re(v, '|', LONGER, init, final);
NOERRN();
branch = branch->right;
}
@@ -745,7 +744,7 @@ parsebranch(
lp = left;
seencontent = 0;
- t = subre(v, '=', 0, left, right); /* op '=' is tentative */
+ t = sub_re(v, '=', 0, left, right); /* op '=' is tentative */
NOERRN();
while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) {
if (seencontent) { /* implicit concat operator */
@@ -809,7 +808,7 @@ parseqatom(
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
- subno = 0; /* just to shut lint up */
+ subno = 0;
/*
* An atom or constraint...
@@ -953,10 +952,10 @@ parseqatom(
if (cap) {
v->nsubexp++;
subno = v->nsubexp;
- if ((size_t)subno >= v->nsubs) {
+ if (subno >= v->nsubs) {
moresubs(v, subno);
}
- assert((size_t)subno < v->nsubs);
+ assert(subno < v->nsubs);
} else {
atomtype = PLAIN; /* something that's not '(' */
}
@@ -978,7 +977,7 @@ parseqatom(
NOERR();
if (cap) {
v->subs[subno] = atom;
- t = subre(v, '(', atom->flags|CAP, lp, rp);
+ t = sub_re(v, '(', atom->flags|CAP, lp, rp);
NOERR();
t->subno = subno;
t->left = atom;
@@ -996,7 +995,7 @@ parseqatom(
INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG);
NOERR();
assert(v->nextvalue > 0);
- atom = subre(v, 'b', BACKR, lp, rp);
+ atom = sub_re(v, 'b', BACKR, lp, rp);
NOERR();
subno = v->nextvalue;
atom->subno = subno;
@@ -1111,7 +1110,7 @@ parseqatom(
*/
if (atom == NULL) {
- atom = subre(v, '=', 0, lp, rp);
+ atom = sub_re(v, '=', 0, lp, rp);
NOERR();
}
@@ -1148,7 +1147,7 @@ parseqatom(
* Break remaining subRE into x{...} and what follows.
*/
- t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
+ t = sub_re(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
NOERR();
t->left = atom;
atomp = &t->left;
@@ -1162,7 +1161,7 @@ parseqatom(
*/
assert(top->op == '=' && top->left == NULL && top->right == NULL);
- top->left = subre(v, '=', top->flags, top->begin, lp);
+ top->left = sub_re(v, '=', top->flags, top->begin, lp);
NOERR();
top->op = '.';
top->right = t;
@@ -1231,9 +1230,9 @@ parseqatom(
assert(m >= 1 && m != DUPINF && n >= 1);
repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1);
f = COMBINE(qprefer, atom->flags);
- t = subre(v, '.', f, s, atom->end); /* prefix and atom */
+ t = sub_re(v, '.', f, s, atom->end); /* prefix and atom */
NOERR();
- t->left = subre(v, '=', PREF(f), s, atom->begin);
+ t->left = sub_re(v, '=', PREF(f), s, atom->begin);
NOERR();
t->right = atom;
*atomp = t;
@@ -1248,7 +1247,7 @@ parseqatom(
dupnfa(v->nfa, atom->begin, atom->end, s, s2);
repeat(v, s, s2, m, n);
f = COMBINE(qprefer, atom->flags);
- t = subre(v, '*', f, s, s2);
+ t = sub_re(v, '*', f, s, s2);
NOERR();
t->min = (short) m;
t->max = (short) n;
@@ -1266,7 +1265,7 @@ parseqatom(
t->right = parsebranch(v, stopper, type, s2, rp, 1);
} else {
EMPTYARC(s2, rp);
- t->right = subre(v, '=', 0, s2, rp);
+ t->right = sub_re(v, '=', 0, s2, rp);
}
NOERR();
assert(SEE('|') || SEE(stopper) || SEE(EOS));
@@ -1718,12 +1717,12 @@ wordchrs(
}
/*
- - subre - allocate a subre
- ^ static struct subre *subre(struct vars *, int, int, struct state *,
+ - sub_re - allocate a subre
+ ^ static struct subre *sub_re(struct vars *, int, int, struct state *,
^ struct state *);
*/
static struct subre *
-subre(
+sub_re(
struct vars *v,
int op,
int flags,
@@ -1900,10 +1899,10 @@ nfatree(
assert(t != NULL && t->begin != NULL);
if (t->left != NULL) {
- (DISCARD) nfatree(v, t->left, f);
+ (void) nfatree(v, t->left, f);
}
if (t->right != NULL) {
- (DISCARD) nfatree(v, t->right, f);
+ (void) nfatree(v, t->right, f);
}
return nfanode(v, t, f);
@@ -2147,7 +2146,7 @@ stdump(
fprintf(f, "}");
}
if (nfapresent) {
- fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no);
+ fprintf(f, " %d-%d", t->begin->no, t->end->no);
}
if (t->left != NULL) {
fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf)));
diff --git a/generic/regcustom.h b/generic/regcustom.h
index f6bf60c..56bf571 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -36,10 +36,9 @@
* Overrides for regguts.h definitions, if any.
*/
-#define FUNCPTR(name, args) (*name)args
-#define MALLOC(n) VS(attemptckalloc(n))
-#define FREE(p) ckfree(VS(p))
-#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n))
+#define MALLOC(n) (void*)(attemptckalloc(n))
+#define FREE(p) ckfree((void*)(p))
+#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n))
/*
* Do not insert extras between the "begin" and "end" lines - this chunk is
@@ -89,15 +88,9 @@ typedef int celt; /* Type to hold chr, or NOCELT */
#define NOCELT (-1) /* Celt value which is not valid chr */
#define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */
#define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */
-#if TCL_UTF_MAX > 4
#define CHRBITS 32 /* Bits in a chr; must not use sizeof */
#define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */
-#define CHR_MAX 0xFFFFFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
-#else
-#define CHRBITS 16 /* Bits in a chr; must not use sizeof */
-#define CHR_MIN 0x0000 /* Smallest and largest chr; the value */
-#define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
-#endif
+#define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */
/*
* Functions operating on chr.
diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c
index e5f22c4..eddfea2 100644
--- a/generic/rege_dfa.c
+++ b/generic/rege_dfa.c
@@ -2,7 +2,7 @@
* DFA routines
* This file is #included by regexec.c.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -419,7 +419,7 @@ freeDFA(
static unsigned
hash(
unsigned *const uv,
- const int n)
+ int n)
{
int i;
unsigned h;
diff --git a/generic/regerror.c b/generic/regerror.c
index bc73d6a..775c640 100644
--- a/generic/regerror.c
+++ b/generic/regerror.c
@@ -1,7 +1,7 @@
/*
* regerror - error-code expansion
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regex.h b/generic/regex.h
index adbd098..dba3ab4 100644
--- a/generic/regex.h
+++ b/generic/regex.h
@@ -151,8 +151,8 @@ typedef struct {
int re_csize; /* sizeof(character) */
char *re_endp; /* backward compatibility kludge */
/* the rest is opaque pointers to hidden innards */
- char *re_guts; /* `char *' is more portable than `void *' */
- char *re_fns;
+ void *re_guts;
+ void *re_fns;
} regex_t;
/* result reporting (may acquire more fields later) */
diff --git a/generic/regexec.c b/generic/regexec.c
index 0ab3c88..7ef048e 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -1,7 +1,7 @@
/*
* re_*exec and friends - match REs
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -44,7 +44,7 @@ struct sset { /* state set */
unsigned hash; /* hash of bitvector */
#define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
#define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
- memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
+ memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0))
int flags;
#define STARTER 01 /* the initial state set */
#define POSTSTATE 02 /* includes the goal state */
@@ -91,7 +91,6 @@ struct smalldfa {
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
};
-#define DOMALLOC ((struct smalldfa *)NULL) /* force malloc */
/*
* Internal variables, bundled for easy passing around.
@@ -117,7 +116,7 @@ struct vars {
#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) ((long)OFF(p))
+#define LOFF(p) ((size_t)OFF(p))
/*
* forward declarations
@@ -146,7 +145,7 @@ static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *con
static chr *lastCold(struct vars *const, struct dfa *const);
static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *);
static void freeDFA(struct dfa *const);
-static unsigned hash(unsigned *const, const int);
+static unsigned hash(unsigned *const, int);
static struct sset *initialize(struct vars *const, struct dfa *const, chr *const);
static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const);
static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor);
@@ -172,8 +171,8 @@ exec(
{
AllocVars(v);
int st, backref;
- size_t n;
- size_t i;
+ int n;
+ int i;
#define LOCALMAT 20
regmatch_t mat[LOCALMAT];
#define LOCALDFAS 40
@@ -236,15 +235,16 @@ exec(
v->stop = (chr *)string + len;
v->err = 0;
assert(v->g->ntree >= 0);
- n = (size_t) v->g->ntree;
+ 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)
+ if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
+ }
FreeVars(v);
return REG_ESPACE;
}
@@ -269,7 +269,7 @@ exec(
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
zapallsubs(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
- memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
+ memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t));
}
/*
@@ -279,13 +279,15 @@ exec(
if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
}
- n = (size_t) v->g->ntree;
+ n = v->g->ntree;
for (i = 0; i < n; i++) {
- if (v->subdfas[i] != NULL)
+ if (v->subdfas[i] != NULL) {
freeDFA(v->subdfas[i]);
+ }
}
- if (v->subdfas != subdfas)
+ if (v->subdfas != subdfas) {
FREE(v->subdfas);
+ }
FreeVars(v);
return st;
}
@@ -300,9 +302,10 @@ getsubdfa(struct vars * v,
struct subre * t)
{
if (v->subdfas[t->id] == NULL) {
- v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, DOMALLOC);
- if (ISERR())
+ v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
+ if (ISERR()) {
return NULL;
+ }
}
return v->subdfas[t->id];
}
@@ -332,7 +335,7 @@ simpleFind(
s = newDFA(v, &v->g->search, cm, &v->dfa1);
assert(!(ISERR() && s != NULL));
NOERR();
- MDEBUG(("\nsearch at %ld\n", LOFF(v->start)));
+ 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);
@@ -360,12 +363,12 @@ simpleFind(
assert(cold != NULL);
open = cold;
cold = NULL;
- MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
+ 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 %ld\n", LOFF(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 {
@@ -476,7 +479,7 @@ complicatedFindLoop(
cold = NULL;
close = v->start;
do {
- MDEBUG(("\ncsearch at %ld\n", LOFF(close)));
+ 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 */
@@ -484,9 +487,9 @@ complicatedFindLoop(
assert(cold != NULL);
open = cold;
cold = NULL;
- MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close)));
+ 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 %ld\n", LOFF(begin)));
+ MDEBUG(("\ncomplicatedFind trying at %" TCL_Z_MODIFIER "u\n", LOFF(begin)));
estart = begin;
estop = v->stop;
for (;;) {
@@ -502,7 +505,7 @@ complicatedFindLoop(
break; /* NOTE BREAK OUT */
}
- MDEBUG(("tentative end %ld\n", LOFF(end)));
+ 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) {
@@ -629,7 +632,7 @@ cdissect(
int er;
assert(t != NULL);
- MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op));
+ MDEBUG(("cdissect %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u %c\n", LOFF(begin), LOFF(end), t->op));
switch (t->op) {
case '=': /* terminal node */
@@ -716,7 +719,7 @@ ccondissect(
if (mid == NULL) {
return REG_NOMATCH;
}
- MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
@@ -767,7 +770,7 @@ ccondissect(
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
- MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid)));
+ MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
@@ -807,7 +810,7 @@ crevcondissect(
if (mid == NULL) {
return REG_NOMATCH;
}
- MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ MDEBUG(("tentative midpoint %" TCL_Z_MODIFIER "u\n", LOFF(mid)));
/*
* Iterate until satisfaction or failure.
@@ -858,7 +861,7 @@ crevcondissect(
MDEBUG(("%d failed midpoint\n", t->id));
return REG_NOMATCH;
}
- MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid)));
+ MDEBUG(("%d: new midpoint %" TCL_Z_MODIFIER "u\n", t->id, LOFF(mid)));
zaptreesubs(v, t->left);
zaptreesubs(v, t->right);
}
@@ -890,7 +893,7 @@ cbrdissect(
MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max));
/* get the backreferenced string */
- if (v->pmatch[n].rm_so == -1) {
+ if (v->pmatch[n].rm_so == TCL_INDEX_NONE) {
return REG_NOMATCH;
}
brstring = v->start + v->pmatch[n].rm_so;
@@ -924,17 +927,20 @@ cbrdissect(
assert(end > begin);
tlen = end - begin;
- if (tlen % brlen != 0)
+ if (tlen % brlen != 0) {
return REG_NOMATCH;
+ }
numreps = tlen / brlen;
- if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF))
+ 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)
+ if ((*v->g->compare) (brstring, p, brlen) != 0) {
return REG_NOMATCH;
+ }
p += brlen;
}
@@ -1011,8 +1017,9 @@ citerdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1026,8 +1033,9 @@ citerdissect(struct vars * v,
* sub-match endpoints in endpts[1..max_matches].
*/
max_matches = end - begin;
- if (max_matches > (size_t)t->max && t->max != DUPINF)
+ 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 *));
@@ -1066,12 +1074,13 @@ citerdissect(struct vars * v,
k--;
goto backtrack;
}
- MDEBUG(("%d: working endpoint %d: %ld\n",
+ 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)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1097,8 +1106,9 @@ citerdissect(struct vars * v,
* 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)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1109,8 +1119,9 @@ citerdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
@@ -1184,8 +1195,9 @@ creviterdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1239,8 +1251,9 @@ creviterdissect(struct vars * v,
limit++;
/* if this is the last allowed sub-match, it must reach to the end */
- if ((size_t)k >= max_matches)
+ 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,
@@ -1250,12 +1263,13 @@ creviterdissect(struct vars * v,
k--;
goto backtrack;
}
- MDEBUG(("%d: working endpoint %d: %ld\n",
+ 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)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1276,8 +1290,9 @@ creviterdissect(struct vars * v,
* 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)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1288,8 +1303,9 @@ creviterdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
diff --git a/generic/regfree.c b/generic/regfree.c
index b0aaa70..71263ab 100644
--- a/generic/regfree.c
+++ b/generic/regfree.c
@@ -1,7 +1,7 @@
/*
* regfree - free an RE
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regfronts.c b/generic/regfronts.c
index 088a640..3042558 100644
--- a/generic/regfronts.c
+++ b/generic/regfronts.c
@@ -4,7 +4,7 @@
* Mostly for implementation of backward-compatibility kludges. Note that
* these routines exist ONLY in char versions.
*
- * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+ * Copyright © 1998, 1999 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
diff --git a/generic/regguts.h b/generic/regguts.h
index a91765e..62ab889 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -49,41 +49,15 @@
#include <assert.h>
#endif
-/* voids */
-#ifndef VOID
-#define VOID void /* for function return values */
-#endif
-#ifndef DISCARD
-#define DISCARD void /* for throwing values away */
-#endif
-#ifndef PVOID
-#define PVOID void * /* generic pointer */
-#endif
-#ifndef VS
-#define VS(x) ((void*)(x)) /* cast something to generic ptr */
-#endif
-#ifndef NOPARMS
-#define NOPARMS void /* for empty parm lists */
-#endif
-
-/* function-pointer declarator */
-#ifndef FUNCPTR
-#if __STDC__ >= 1
-#define FUNCPTR(name, args) (*name)args
-#else
-#define FUNCPTR(name, args) (*name)()
-#endif
-#endif
-
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
#endif
#ifndef REALLOC
-#define REALLOC(p, n) realloc(VS(p), n)
+#define REALLOC(p, n) realloc(p, n)
#endif
#ifndef FREE
-#define FREE(p) free(VS(p))
+#define FREE(p) free(p)
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
@@ -96,7 +70,6 @@
*/
#define NOTREACHED 0
-#define xxx 1
#define DUPMAX _POSIX2_RE_DUP_MAX
#define DUPINF (DUPMAX+1)
@@ -408,7 +381,7 @@ struct subre {
*/
struct fns {
- void FUNCPTR(free, (regex_t *));
+ void (*free) (regex_t *);
};
/*
@@ -425,7 +398,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
- int FUNCPTR(compare, (const chr *, const chr *, size_t));
+ int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 2f21fa5..0097eea 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -32,7 +32,7 @@ declare 0 {
const char *version, const void *clientData)
}
declare 1 {
- CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
+ const char *Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -40,22 +40,22 @@ declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
- char *Tcl_Alloc(unsigned int size)
+ char *Tcl_Alloc(TCL_HASH_TYPE size)
}
declare 4 {
void Tcl_Free(char *ptr)
}
declare 5 {
- char *Tcl_Realloc(char *ptr, unsigned int size)
+ char *Tcl_Realloc(char *ptr, TCL_HASH_TYPE size)
}
declare 6 {
- char *Tcl_DbCkalloc(unsigned int size, const char *file, int line)
+ char *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
- char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
+ char *Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
@@ -65,7 +65,7 @@ declare 8 {
declare 9 unix {
void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
@@ -86,10 +86,10 @@ declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
- void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length)
+ void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
declare 17 {
- Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[])
+ Tcl_Obj *Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -104,29 +104,29 @@ declare 20 {
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
-declare 22 {
+declare 22 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line)
}
declare 23 {
- Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length,
- const char *file, int line)
+ Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
+ Tcl_Size 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(int objc, Tcl_Obj *const *objv,
+ Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line)
}
-declare 26 {
+declare 26 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
- Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length,
+ Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length,
const char *file, int line)
}
declare 29 {
@@ -142,8 +142,9 @@ 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 *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr)
+ unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, Tcl_Size *numBytesPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
@@ -152,9 +153,9 @@ declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
-declare 36 {
+declare 36 {deprecated {No longer in use, changed to macro}} {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr)
+ const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
@@ -187,7 +188,7 @@ declare 45 {
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 46 {
- int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index,
+ int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr)
}
declare 47 {
@@ -195,67 +196,67 @@ declare 47 {
int *lengthPtr)
}
declare 48 {
- int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
- int count, int objc, Tcl_Obj *const objv[])
+ int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first,
+ Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 49 {
+declare 49 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewBooleanObj(int intValue)
}
declare 50 {
- Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int numBytes)
+ Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
-declare 52 {
+declare 52 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
declare 53 {
- Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
+ Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 54 {
+declare 54 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
- Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
+ Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length)
}
-declare 57 {
+declare 57 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue)
}
declare 58 {
- unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes)
+ unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
- int numBytes)
+ Tcl_Size numBytes)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
-declare 61 {
+declare 61 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 {
- void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
+ void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[])
}
-declare 63 {
+declare 63 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
- void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
+ void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
declare 65 {
- void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
+ void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
-declare 66 {
+declare 66 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
-declare 67 {
+declare 67 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
- int length)
+ Tcl_Size length)
}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
@@ -268,7 +269,7 @@ declare 70 {
}
declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
@@ -282,10 +283,10 @@ declare 74 {
declare 75 {
int Tcl_AsyncReady(void)
}
-declare 76 {
+declare 76 {deprecated {No longer in use, changed to macro}} {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
-declare 77 {
+declare 77 {deprecated {Use Tcl_UtfBackslash}} {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
@@ -294,11 +295,12 @@ declare 78 {
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 80 {
- void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
+ 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)
}
@@ -306,85 +308,85 @@ declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
- char *Tcl_Concat(int argc, CONST84 char *const *argv)
+ char *Tcl_Concat(Tcl_Size argc, const char *const *argv)
}
declare 84 {
- int Tcl_ConvertElement(const char *src, char *dst, int flags)
+ Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags)
}
declare 85 {
- int Tcl_ConvertCountedElement(const char *src, int length, char *dst,
+ Tcl_Size Tcl_ConvertCountedElement(const char *src, Tcl_Size length, char *dst,
int flags)
}
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd,
- Tcl_Interp *target, const char *targetCmd, int argc,
- CONST84 char *const *argv)
+ Tcl_Interp *target, const char *targetCmd, Tcl_Size argc,
+ const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd,
- Tcl_Interp *target, const char *targetCmd, int objc,
+ Tcl_Interp *target, const char *targetCmd, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 88 {
Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
- const char *chanName, ClientData instanceData, int mask)
+ const char *chanName, void *instanceData, int mask)
}
declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
- Tcl_ChannelProc *proc, ClientData clientData)
+ Tcl_ChannelProc *proc, void *clientData)
}
declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 91 {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
- Tcl_CmdProc *proc, ClientData clientData,
+ Tcl_CmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
- Tcl_EventCheckProc *checkProc, ClientData clientData)
+ Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 93 {
- void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
-declare 95 {
+declare 95 {deprecated {}} {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
- Tcl_MathProc *proc, ClientData clientData)
+ Tcl_MathProc *proc, void *clientData)
}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
- Tcl_ObjCmdProc *proc, ClientData clientData,
+ Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
- Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
+ Tcl_Interp *Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
- Tcl_TimerProc *proc, ClientData clientData)
+ Tcl_TimerProc *proc, void *clientData)
}
declare 99 {
- Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
- Tcl_CmdTraceProc *proc, ClientData clientData)
+ Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level,
+ Tcl_CmdTraceProc *proc, void *clientData)
}
declare 100 {
void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name)
}
declare 101 {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 103 {
int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName)
@@ -393,14 +395,14 @@ declare 104 {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
}
declare 105 {
- void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
+ void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, void *clientData)
}
declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
- Tcl_EventCheckProc *checkProc, ClientData clientData)
+ Tcl_EventCheckProc *checkProc, void *clientData)
}
declare 107 {
- void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
@@ -412,7 +414,7 @@ declare 110 {
void Tcl_DeleteInterp(Tcl_Interp *interp)
}
declare 111 {
- void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr)
+ void Tcl_DetachPids(Tcl_Size numPids, Tcl_Pid *pidPtr)
}
declare 112 {
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
@@ -422,16 +424,16 @@ declare 113 {
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
- Tcl_InterpDeleteProc *proc, ClientData clientData)
+ Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 115 {
int Tcl_DoOneEvent(int flags)
}
declare 116 {
- void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
+ void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData)
}
declare 117 {
- char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length)
+ char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, Tcl_Size length)
}
declare 118 {
char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
@@ -452,7 +454,7 @@ declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 124 {
- void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length)
+ void Tcl_DStringSetLength(Tcl_DString *dsPtr, Tcl_Size length)
}
declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
@@ -461,10 +463,10 @@ declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
- CONST84_RETURN char *Tcl_ErrnoId(void)
+ const char *Tcl_ErrnoId(void)
}
declare 128 {
- CONST84_RETURN char *Tcl_ErrnoMsg(int err)
+ const char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
@@ -472,11 +474,11 @@ declare 129 {
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
-declare 131 {
+declare 131 {deprecated {No longer in use, changed to macro}} {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 {
- void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
+ void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
@@ -513,8 +515,8 @@ declare 142 {
declare 143 {
void Tcl_Finalize(void)
}
-declare 144 {
- void Tcl_FindExecutable(const char *argv0)
+declare 144 {nostub {Don't use this function in a stub-enabled extension}} {
+ const char *Tcl_FindExecutable(const char *argv0)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
@@ -523,21 +525,21 @@ declare 145 {
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
-declare 147 {
+declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
- int *argcPtr, CONST84 char ***argvPtr)
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
+ int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
- ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
+ void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 {
@@ -545,20 +547,20 @@ declare 151 {
int *modePtr)
}
declare 152 {
- int Tcl_GetChannelBufferSize(Tcl_Channel chan)
+ Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
- ClientData *handlePtr)
+ void **handlePtr)
}
declare 154 {
- ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
+ void *Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
- CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
+ const char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -572,20 +574,20 @@ declare 159 {
Tcl_CmdInfo *infoPtr)
}
declare 160 {
- CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
+ const char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
- CONST84_RETURN char *Tcl_GetHostName(void)
+ const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp)
}
declare 164 {
- Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp)
+ Tcl_Interp *Tcl_GetParent(Tcl_Interp *interp)
}
declare 165 {
const char *Tcl_GetNameOfExecutable(void)
@@ -599,7 +601,7 @@ declare 166 {
declare 167 unix {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID,
- int forWriting, int checkUsage, ClientData *filePtr)
+ int forWriting, int checkUsage, void **filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
@@ -607,35 +609,35 @@ declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
- int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
+ Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
declare 170 {
- int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
+ Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
- Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *name)
+ Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
- CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
+ const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
-declare 175 {
- CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+declare 175 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
- CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
-declare 178 {
+declare 178 {deprecated {No longer in use, changed to macro}} {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 {
@@ -662,11 +664,11 @@ declare 185 {
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
- char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
+ char *Tcl_JoinPath(Tcl_Size argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
- int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr,
+ int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr,
int type)
}
@@ -676,16 +678,16 @@ declare 187 {
# }
declare 189 {
- Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode)
+ Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
-declare 190 {
+declare 190 {deprecated {}} {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
- Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
+ Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
- char *Tcl_Merge(int argc, CONST84 char *const *argv)
+ char *Tcl_Merge(Tcl_Size argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
@@ -702,8 +704,8 @@ declare 196 {
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
declare 197 {
- Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags)
+ Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, Tcl_Size argc,
+ const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
@@ -717,10 +719,10 @@ declare 199 {
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
- ClientData callbackData)
+ void *callbackData)
}
declare 201 {
- void Tcl_Preserve(ClientData data)
+ void Tcl_Preserve(void *data)
}
declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
@@ -729,13 +731,13 @@ declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
- CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
+ const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
- void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
+ void Tcl_QueueEvent(Tcl_Event *evPtr, int position)
}
declare 206 {
- int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
+ Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, Tcl_Size toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
@@ -764,23 +766,22 @@ declare 214 {
const char *pattern)
}
declare 215 {
- void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr, CONST84 char **endPtr)
+ void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index,
+ const char **startPtr, const char **endPtr)
}
declare 216 {
- void Tcl_Release(ClientData clientData)
+ void Tcl_Release(void *clientData)
}
declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 {
- int Tcl_ScanElement(const char *src, int *flagPtr)
+ Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
- int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
+ Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
-# Obsolete
-declare 220 {
+declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
@@ -791,10 +792,10 @@ declare 222 {
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
- Tcl_InterpDeleteProc *proc, ClientData clientData)
+ Tcl_InterpDeleteProc *proc, void *clientData)
}
declare 224 {
- void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
+ void Tcl_SetChannelBufferSize(Tcl_Channel chan, Tcl_Size sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -813,11 +814,11 @@ declare 228 {
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
-declare 230 {
- void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+declare 230 {nostub {Don't use this function in a stub-enabled extension}} {
+ const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
}
declare 231 {
- int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
+ Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth)
}
declare 232 {
void Tcl_SetResult(Tcl_Interp *interp, char *result,
@@ -835,56 +836,55 @@ declare 235 {
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
-declare 237 {
- CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+declare 237 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
- CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
- CONST84_RETURN char *Tcl_SignalId(int sig)
+ const char *Tcl_SignalId(int sig)
}
declare 240 {
- CONST84_RETURN char *Tcl_SignalMsg(int sig)
+ const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr)
+ const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
- void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
+ void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
-declare 244 {
- void Tcl_StaticPackage(Tcl_Interp *interp, const char *prefix,
- Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+declare 244 {nostub {Don't use this function in a stub-enabled extension}} {
+ void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
+ Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
-declare 245 {
+declare 245 {deprecated {No longer in use, changed to macro}} {
int Tcl_StringMatch(const char *str, const char *pattern)
}
-# Obsolete
-declare 246 {
+declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
-declare 247 {
+declare 247 {deprecated {No longer in use, changed to macro}} {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_VarTraceProc *proc, ClientData clientData)
+ Tcl_VarTraceProc *proc, void *clientData)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
- int flags, Tcl_VarTraceProc *proc, ClientData clientData)
+ int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
- int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead)
+ Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
@@ -892,26 +892,26 @@ declare 251 {
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
-declare 253 {
+declare 253 {deprecated {No longer in use, changed to macro}} {
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
-declare 255 {
+declare 255 {deprecated {No longer in use, changed to macro}} {
void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_VarTraceProc *proc, ClientData clientData)
+ Tcl_VarTraceProc *proc, void *clientData)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
- ClientData clientData)
+ void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
-declare 258 {
+declare 258 {deprecated {No longer in use, changed to macro}} {
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName, int flags)
}
@@ -922,20 +922,20 @@ declare 259 {
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
-declare 261 {
- ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
- int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
+declare 261 {deprecated {No longer in use, changed to macro}} {
+ void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
+ int flags, Tcl_VarTraceProc *procPtr, void *prevClientData)
}
declare 262 {
- ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
+ void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
- ClientData prevClientData)
+ void *prevClientData)
}
declare 263 {
- int Tcl_Write(Tcl_Channel chan, const char *s, int slen)
+ Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen)
}
declare 264 {
- void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
+ void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
@@ -944,47 +944,47 @@ declare 265 {
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
-declare 267 {
+declare 267 {deprecated {see TIP #422}} {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
-declare 268 {
+declare 268 {deprecated {see TIP #422}} {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
- CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
- CONST84 char **termPtr)
+ const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr)
}
-declare 271 {
- CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+declare 271 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
- CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
+ const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
-declare 273 {
+declare 273 {deprecated {No longer in use, changed to macro}} {
int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version)
}
# TIP #268: The internally used new Require function is in slot 573.
-declare 274 {
- CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+declare 274 {deprecated {No longer in use, changed to macro}} {
+ const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
-declare 275 {
+declare 275 {deprecated {see TIP #422}} {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
-declare 276 {
+declare 276 {deprecated {see TIP #422}} {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 {
+declare 278 {deprecated {see TIP #422}} {
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
@@ -1010,7 +1010,7 @@ declare 280 {
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
- const Tcl_ChannelType *typePtr, ClientData instanceData,
+ const Tcl_ChannelType *typePtr, void *instanceData,
int mask, Tcl_Channel prevChan)
}
declare 282 {
@@ -1038,43 +1038,43 @@ declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
- void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
- void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+ void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
-declare 290 {
+declare 290 {deprecated {Use Tcl_DiscardInterpState}} {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 {
- int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes,
+ int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes,
int flags)
}
declare 292 {
- int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
+ int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
- void Tcl_ExitThread(int status)
+ TCL_NORETURN void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- const char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr)
}
declare 297 {
void Tcl_FinalizeThread(void)
}
declare 298 {
- void Tcl_FinalizeNotifier(ClientData clientData)
+ void Tcl_FinalizeNotifier(void *clientData)
}
declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
@@ -1086,25 +1086,25 @@ declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
- CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
+ const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
- const void *tablePtr, int offset, const char *msg, int flags,
- int *indexPtr)
+ const void *tablePtr, Tcl_Size offset, const char *msg, int flags,
+ void *indexPtr)
}
declare 305 {
- void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
+ void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, Tcl_Size size)
}
declare 306 {
Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 307 {
- ClientData Tcl_InitNotifier(void)
+ void *Tcl_InitNotifier(void)
}
declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
@@ -1120,16 +1120,16 @@ declare 311 {
const Tcl_Time *timePtr)
}
declare 312 {
- int Tcl_NumUtfChars(const char *src, int length)
+ Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
- int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
- int charsToRead, int appendFlag)
+ Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
+ Tcl_Size charsToRead, int appendFlag)
}
-declare 314 {
+declare 314 {deprecated {Use Tcl_RestoreInterpState}} {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
-declare 315 {
+declare 315 {deprecated {Use Tcl_SaveInterpState}} {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 {
@@ -1144,83 +1144,83 @@ declare 318 {
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
- Tcl_QueuePosition position)
+ int position)
}
declare 320 {
- Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+ int Tcl_UniCharAtIndex(const char *src, Tcl_Size index)
}
declare 321 {
- Tcl_UniChar Tcl_UniCharToLower(int ch)
+ int Tcl_UniCharToLower(int ch)
}
declare 322 {
- Tcl_UniChar Tcl_UniCharToTitle(int ch)
+ int Tcl_UniCharToTitle(int ch)
}
declare 323 {
- Tcl_UniChar Tcl_UniCharToUpper(int ch)
+ int Tcl_UniCharToUpper(int ch)
}
declare 324 {
- int Tcl_UniCharToUtf(int ch, char *buf)
+ Tcl_Size Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
- CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
+ const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index)
}
declare 326 {
- int Tcl_UtfCharComplete(const char *src, int length)
+ int TclUtfCharComplete(const char *src, Tcl_Size length)
}
declare 327 {
- int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
+ Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
- CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
+ const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
- CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
+ const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
- CONST84_RETURN char *Tcl_UtfNext(const char *src)
+ const char *TclUtfNext(const char *src)
}
declare 331 {
- CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
+ const char *TclUtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ const char *src, Tcl_Size srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- const char *src, int srcLen, Tcl_DString *dsPtr)
+ const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr)
}
declare 334 {
- int Tcl_UtfToLower(char *src)
+ Tcl_Size Tcl_UtfToLower(char *src)
}
declare 335 {
- int Tcl_UtfToTitle(char *src)
+ Tcl_Size Tcl_UtfToTitle(char *src)
}
declare 336 {
- int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr)
+ Tcl_Size Tcl_UtfToChar16(const char *src, unsigned short *chPtr)
}
declare 337 {
- int Tcl_UtfToUpper(char *src)
+ Tcl_Size Tcl_UtfToUpper(char *src)
}
declare 338 {
- int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen)
+ Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen)
}
declare 339 {
- int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
+ Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
-declare 341 {
- CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
+declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
+ const char *Tcl_GetDefaultEncodingDir(void)
}
-declare 342 {
+declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
- void Tcl_AlertNotifier(ClientData clientData)
+ void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
@@ -1247,56 +1247,56 @@ declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
- int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
+ Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
-declare 353 {
- int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
+declare 353 {deprecated {Use Tcl_UtfNcmp}} {
+ int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct,
unsigned long numChars)
}
declare 354 {
- char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
- int uniLength, Tcl_DString *dsPtr)
+ char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr)
}
declare 355 {
- Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src,
- int length, Tcl_DString *dsPtr)
+ unsigned short *Tcl_UtfToChar16DString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
-declare 357 {
+declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
- int count)
+ Tcl_Size count)
}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
- const char *command, int length)
+ const char *command, Tcl_Size length)
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append,
+ const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start,
- int numBytes, int nested, Tcl_Parse *parsePtr)
+ Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr)
}
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append,
+ const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr, int append)
+ Tcl_Size numBytes, Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
@@ -1335,40 +1335,40 @@ declare 375 {
}
declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
- Tcl_Obj *textObj, int offset, int nmatches, int flags)
+ Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags)
}
declare 377 {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 {
- Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars)
+ Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars)
}
declare 379 {
- void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
- int numChars)
+ void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode,
+ Tcl_Size numChars)
}
declare 380 {
- int Tcl_GetCharLength(Tcl_Obj *objPtr)
+ Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
- Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+ int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
-declare 382 {
- Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
+declare 382 {deprecated {No longer in use, changed to macro}} {
+ unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
- Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
+ Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
}
declare 384 {
- void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
- int length)
+ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode,
+ Tcl_Size length)
}
declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
declare 386 {
- void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
+ void Tcl_SetNotifier(const Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
@@ -1380,8 +1380,8 @@ declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
- int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
+ int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
@@ -1391,15 +1391,15 @@ declare 392 {
}
declare 393 {
int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc,
- ClientData clientData, int stackSize, int flags)
+ void *clientData, TCL_HASH_TYPE stackSize, int flags)
}
# Introduced in 8.3.2
declare 394 {
- int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
+ Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead)
}
declare 395 {
- int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen)
+ Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, Tcl_Size srcLen)
}
declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
@@ -1408,7 +1408,7 @@ declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
- CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
+ const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
@@ -1418,7 +1418,7 @@ declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
-declare 401 {
+declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
}
@@ -1434,7 +1434,7 @@ declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
-declare 405 {
+declare 405 {deprecated {Use Tcl_ChannelWideSeekProc}} {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
}
@@ -1485,13 +1485,13 @@ declare 417 {
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
-declare 419 {
- int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
+declare 419 {deprecated {Use Tcl_UtfNcasecmp}} {
+ int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct,
unsigned long numChars)
}
-declare 420 {
- int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
- const Tcl_UniChar *uniPattern, int nocase)
+declare 420 {deprecated {Use Tcl_StringCaseMatch}} {
+ int Tcl_UniCharCaseMatch(const unsigned short *uniStr,
+ const unsigned short *uniPattern, int nocase)
}
declare 421 {
Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key)
@@ -1508,33 +1508,33 @@ declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
- ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
+ void *Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
- ClientData prevClientData)
+ void *prevClientData)
}
declare 426 {
int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
- Tcl_CommandTraceProc *proc, ClientData clientData)
+ Tcl_CommandTraceProc *proc, void *clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
- int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
+ int flags, Tcl_CommandTraceProc *proc, void *clientData)
}
declare 428 {
- char *Tcl_AttemptAlloc(unsigned int size)
+ char *Tcl_AttemptAlloc(TCL_HASH_TYPE size)
}
declare 429 {
- char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line)
+ char *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line)
}
declare 430 {
- char *Tcl_AttemptRealloc(char *ptr, unsigned int size)
+ char *Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size)
}
declare 431 {
- char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
+ char *Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line)
}
declare 432 {
- int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
+ int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
# TIP#10 (thread-aware channels) akupries
@@ -1544,16 +1544,16 @@ declare 433 {
# introduced in 8.4a3
declare 434 {
- Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
+ unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
-declare 435 {
+declare 435 {deprecated {}} {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
- Tcl_MathProc **procPtr, ClientData *clientDataPtr)
+ Tcl_MathProc **procPtr, void **clientDataPtr)
}
-declare 436 {
+declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
@@ -1584,8 +1584,8 @@ declare 443 {
}
declare 444 {
int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1,
- const char *sym2, Tcl_PackageInitProc **proc1Ptr,
- Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr,
+ const char *sym2, Tcl_LibraryInitProc **proc1Ptr,
+ Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 {
@@ -1640,7 +1640,7 @@ declare 459 {
int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 460 {
- Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
+ Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements)
}
declare 461 {
Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr)
@@ -1652,11 +1652,11 @@ declare 463 {
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
- Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
+ Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 465 {
- ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
+ void *Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
}
declare 466 {
@@ -1667,7 +1667,7 @@ declare 467 {
}
declare 468 {
Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem,
- ClientData clientData)
+ void *clientData)
}
declare 469 {
const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
@@ -1682,13 +1682,13 @@ declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
declare 473 {
- int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr)
+ int Tcl_FSRegister(void *clientData, const Tcl_Filesystem *fsPtr)
}
declare 474 {
int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr)
}
declare 475 {
- ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr)
+ void *Tcl_FSData(const Tcl_Filesystem *fsPtr)
}
declare 476 {
const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
@@ -1712,7 +1712,7 @@ declare 480 {
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
- int count)
+ Tcl_Size count)
}
# TIP#73 (access to current time) kbk
@@ -1722,8 +1722,8 @@ declare 482 {
# TIP#32 (object-enabled traces) kbk
declare 483 {
- Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
- Tcl_CmdObjTraceProc *objProc, ClientData clientData,
+ Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc *objProc, void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 484 {
@@ -1754,10 +1754,10 @@ declare 490 {
Tcl_StatBuf *Tcl_AllocStatBuf(void)
}
declare 491 {
- Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
+ long long Tcl_Seek(Tcl_Channel chan, long long offset, int mode)
}
declare 492 {
- Tcl_WideInt Tcl_Tell(Tcl_Channel chan)
+ long long Tcl_Tell(Tcl_Channel chan)
}
# TIP#91 (back-compat enhancements for channels) dkf
@@ -1798,11 +1798,11 @@ declare 500 {
}
declare 501 {
int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
+ Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr)
}
declare 502 {
int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- int keyc, Tcl_Obj *const *keyv)
+ Tcl_Size keyc, Tcl_Obj *const *keyv)
}
declare 503 {
Tcl_Obj *Tcl_NewDictObj(void)
@@ -1821,7 +1821,7 @@ declare 505 {
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
- ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
+ void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 507 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
@@ -1871,19 +1871,19 @@ declare 518 {
}
# TIP#121 (exit handler) dkf for Joe Mistachkin
-declare 519 {
+declare 519 {nostub {Don't use this function in a stub-enabled extension}} {
Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
- Tcl_LimitHandlerProc *handlerProc, ClientData clientData,
+ Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
declare 521 {
void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
- Tcl_LimitHandlerProc *handlerProc, ClientData clientData)
+ Tcl_LimitHandlerProc *handlerProc, void *clientData)
}
declare 522 {
int Tcl_LimitReady(Tcl_Interp *interp)
@@ -1895,7 +1895,7 @@ declare 524 {
int Tcl_LimitExceeded(Tcl_Interp *interp)
}
declare 525 {
- void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit)
+ void Tcl_LimitSetCommands(Tcl_Interp *interp, Tcl_Size commandLimit)
}
declare 526 {
void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr)
@@ -1996,12 +1996,12 @@ declare 551 {
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
- ClientData clientData)
+ void *clientData)
}
declare 553 {
void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
- ClientData *clientData)
+ void **clientData)
}
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
@@ -2012,24 +2012,24 @@ declare 554 {
# TIP#237 (arbitrary-precision integers) kbk
declare 555 {
- Tcl_Obj *Tcl_NewBignumObj(mp_int *value)
+ Tcl_Obj *Tcl_NewBignumObj(void *value)
}
declare 556 {
- Tcl_Obj *Tcl_DbNewBignumObj(mp_int *value, const char *file, int line)
+ Tcl_Obj *Tcl_DbNewBignumObj(void *value, const char *file, int line)
}
declare 557 {
- void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value)
+ void Tcl_SetBignumObj(Tcl_Obj *obj, void *value)
}
declare 558 {
- int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
+ int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
declare 559 {
- int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value)
+ int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
# TIP #208 ('chan' command) jeffh
declare 560 {
- int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
+ int Tcl_TruncateChannel(Tcl_Channel chan, long long length)
}
declare 561 {
Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
@@ -2053,7 +2053,7 @@ declare 565 {
# TIP #237 (additional conversion functions for bignum support) kbk/dgp
declare 566 {
int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval,
- mp_int *toInit)
+ void *toInit)
}
# TIP#181 (namespace unknown command) dgp for Neil Madden
@@ -2084,7 +2084,7 @@ declare 572 {
# TIP#268 (extended version numbers and requirements) akupries
declare 573 {
int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name,
- int objc, Tcl_Obj *const objv[], void *clientDataPtr)
+ Tcl_Size objc, Tcl_Obj *const objv[], void *clientDataPtr)
}
# TIP#270 (utility C routines for string formatting) dgp
@@ -2093,15 +2093,15 @@ declare 574 {
}
declare 575 {
void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes,
- int length, int limit, const char *ellipsis)
+ Tcl_Size length, Tcl_Size limit, const char *ellipsis)
}
declare 576 {
- Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc,
+ Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, Tcl_Size objc,
Tcl_Obj *const objv[])
}
declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- const char *format, int objc, Tcl_Obj *const objv[])
+ const char *format, Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 578 {
Tcl_Obj *Tcl_ObjPrintf(const char *format, ...)
@@ -2115,7 +2115,7 @@ declare 579 {
# TIP #285 (script cancellation support) jmistachkin
declare 580 {
int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
- ClientData clientData, int flags)
+ void *clientData, int flags)
}
declare 581 {
int Tcl_Canceled(Tcl_Interp *interp, int flags)
@@ -2131,30 +2131,30 @@ declare 582 {
declare 583 {
Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- Tcl_ObjCmdProc *nreProc, ClientData clientData,
+ 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, int objc,
+ int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags)
}
declare 586 {
- int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc,
+ int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size objc,
Tcl_Obj *const objv[], int flags)
}
declare 587 {
void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr,
- ClientData data0, ClientData data1, ClientData data2,
- ClientData data3)
+ 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,
- ClientData clientData, int objc, Tcl_Obj *const objv[])
+ void *clientData, Tcl_Size objc, Tcl_Obj *const objv[])
}
# TIP#316 (Tcl_StatBuf reader functions) dkf
@@ -2180,19 +2180,19 @@ declare 595 {
int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr)
}
declare 596 {
- Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 597 {
- Tcl_WideInt Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetModificationTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 598 {
- Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr)
+ long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr)
}
declare 599 {
- Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr)
+ unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr)
}
declare 600 {
- Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr)
+ unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr)
}
declare 601 {
unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr)
@@ -2245,15 +2245,15 @@ declare 610 {
}
declare 611 {
int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
- int buffersize, Tcl_Obj *gzipHeaderDictObj)
+ Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj)
}
declare 612 {
unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf,
- int len)
+ Tcl_Size len)
}
declare 613 {
unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf,
- int len)
+ Tcl_Size len)
}
declare 614 {
int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format,
@@ -2273,7 +2273,7 @@ declare 618 {
}
declare 619 {
int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data,
- int count)
+ Tcl_Size count)
}
declare 620 {
int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle)
@@ -2327,6 +2327,183 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
+# TIP #456/#468
+declare 631 {
+ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
+ const char *host, unsigned int flags, int backlog,
+ Tcl_TcpAcceptProc *acceptProc, void *callbackData)
+}
+
+# TIP #430
+declare 632 {
+ int TclZipfs_Mount(Tcl_Interp *interp, const char *zipname,
+ const char *mountPoint, const char *passwd)
+}
+declare 633 {
+ int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint)
+}
+declare 634 {
+ Tcl_Obj *TclZipfs_TclLibrary(void)
+}
+declare 635 {
+ int TclZipfs_MountBuffer(Tcl_Interp *interp, const void *data,
+ size_t datalen, const char *mountPoint, int copy)
+}
+
+# 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)
+}
+declare 640 {
+ int Tcl_HasStringRep(Tcl_Obj *objPtr)
+}
+
+# TIP #506
+declare 641 {
+ void Tcl_IncrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 642 {
+ void Tcl_DecrRefCount(Tcl_Obj *objPtr)
+}
+
+declare 643 {
+ int Tcl_IsShared(Tcl_Obj *objPtr)
+}
+
+# TIP#312 New Tcl_LinkArray() function
+declare 644 {
+ int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
+ int type, Tcl_Size size)
+}
+
+declare 645 {
+ int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Size endValue, Tcl_Size *indexPtr)
+}
+
+# TIP #548
+declare 646 {
+ Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr)
+}
+declare 647 {
+ char *Tcl_UniCharToUtfDString(const int *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr)
+}
+declare 648 {
+ int *Tcl_UtfToUniCharDString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr)
+}
+
+# TIP #568
+declare 649 {
+ unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int *numBytesPtr)
+}
+
+# TIP #575
+declare 654 {
+ int Tcl_UtfCharComplete(const char *src, Tcl_Size length)
+}
+declare 655 {
+ const char *Tcl_UtfNext(const char *src)
+}
+declare 656 {
+ const char *Tcl_UtfPrev(const char *src, const char *start)
+}
+declare 657 {
+ int Tcl_UniCharIsUnicode(int ch)
+}
+
+# TIP 656
+declare 658 {
+ int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
+ Tcl_Size *errorLocationPtr)
+}
+declare 659 {
+ int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
+ const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
+ Tcl_Size *errorLocationPtr)
+}
+
+# TIP #511
+declare 660 {
+ int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber)
+}
+
+# TIP #617
+declare 668 {
+ Tcl_Size Tcl_UniCharLen(const int *uniStr)
+}
+declare 669 {
+ Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
+}
+declare 670 {
+ Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
+}
+declare 671 {
+ const char *TclUtfAtIndex(const char *src, Tcl_Size index)
+}
+declare 672 {
+ Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
+}
+declare 673 {
+ int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
+}
+
+declare 674 {
+ int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags,
+ char *charPtr)
+}
+declare 675 {
+ int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags, char *charPtr)
+}
+# TIP #638.
+declare 680 {
+ int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ void **clientDataPtr, int *typePtr)
+}
+declare 681 {
+ int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes,
+ void **clientDataPtr, int *typePtr)
+}
+
+# TIP #220.
+declare 682 {
+ int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
+}
+
+# TIP 643
+declare 683 {
+ Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding)
+}
+
+# TIP #650
+declare 684 {
+ int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideUInt *uwidePtr)
+}
+
+# TIP 651
+declare 685 {
+ Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
+}
+
+# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
+
declare 688 {
void TclUnusedStubEntry(void)
}
@@ -2354,7 +2531,7 @@ declare 1 win {
char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr)
}
declare 3 win {
- void TclWinConvertError_(unsigned errCode)
+ void Tcl_WinConvertError(unsigned errCode)
}
################################
@@ -2363,15 +2540,15 @@ declare 3 win {
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
- int maxPathLen, char *libraryPath)
+ Tcl_Size maxPathLen, char *libraryPath)
}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
- int hasResourceFile, int maxPathLen, char *libraryPath)
+ int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath)
}
declare 2 macosx {
- void TclMacOSXNotifierAddRunLoopMode_(const void *runLoopMode)
+ void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
##############################################################################
@@ -2379,13 +2556,26 @@ declare 2 macosx {
# Public functions that are not accessible via the stubs table.
export {
- void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
+ void Tcl_Main(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
- void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc,
+ void Tcl_MainEx(Tcl_Size 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 {
+ const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
+}
+export {
+ Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
+}
+export {
+ const char *Tcl_FindExecutable(const char *argv0)
+}
+export {
const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact)
}
@@ -2400,6 +2590,12 @@ export {
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
+export {
+ const char *Tcl_InitSubsystems(void)
+}
+export {
+ const char *TclZipfs_AppHook(int *argc, char ***argv)
+}
# Local Variables:
diff --git a/generic/tcl.h b/generic/tcl.h
index 01eafba..5769cbd 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -38,14 +38,13 @@ extern "C" {
* update the version numbers:
*
* library/init.tcl (1 LOC patch)
- * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
- * win/configure.in (as above)
+ * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch)
+ * win/configure.ac (as above)
* 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)
- * tools/tcl.hpj.in (not patchlevel, for windows installer)
*/
#if !defined(TCL_MAJOR_VERSION)
@@ -54,13 +53,14 @@ extern "C" {
#if TCL_MAJOR_VERSION != 8
# error "This header-file is for Tcl 8 only"
#endif
-#define TCL_MINOR_VERSION 6
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 13
+#define TCL_MINOR_VERSION 7
+#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE
+#define TCL_RELEASE_SERIAL 6
-#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.13"
+#define TCL_VERSION "8.7"
+#define TCL_PATCH_LEVEL "8.7a6"
+#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED)
/*
*----------------------------------------------------------------------------
* The following definitions set up the proper options for Windows compilers.
@@ -90,6 +90,11 @@ extern "C" {
# define JOIN1(a,b) a##b
#endif
+#ifndef TCL_THREADS
+# define TCL_THREADS 1
+#endif
+#endif /* !TCL_NO_DEPRECATED */
+
/*
* A special definition used to allow this header file to be included from
* windows resource files so that they can obtain version information.
@@ -102,15 +107,10 @@ extern "C" {
#ifndef RC_INVOKED
/*
- * Special macro to define mutexes, that doesn't do anything if we are not
- * using threads.
+ * Special macro to define mutexes.
*/
-#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
-#else
-#define TCL_DECLARE_MUTEX(name)
-#endif
/*
* Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and
@@ -123,6 +123,7 @@ extern "C" {
*/
#include <stdio.h>
+#include <stddef.h>
/*
*----------------------------------------------------------------------------
@@ -136,7 +137,7 @@ extern "C" {
*/
#include <stdarg.h>
-#if !defined(TCL_NO_DEPRECATED)
+#ifndef TCL_NO_DEPRECATED
# define TCL_VARARGS(type, name) (type name, ...)
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
@@ -148,6 +149,7 @@ extern "C" {
# define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b)))
# endif
# define TCL_NORETURN __attribute__ ((noreturn))
+# define TCL_NOINLINE __attribute__ ((noinline))
# if defined(BUILD_tcl) || defined(BUILD_tk)
# define TCL_NORETURN1 __attribute__ ((noreturn))
# else
@@ -155,10 +157,12 @@ extern "C" {
# endif
#else
# define TCL_FORMAT_PRINTF(a,b)
-# if defined(_MSC_VER) && (_MSC_VER >= 1310)
+# if defined(_MSC_VER)
# define TCL_NORETURN _declspec(noreturn)
+# define TCL_NOINLINE __declspec(noinline)
# else
# define TCL_NORETURN /* nothing */
+# define TCL_NOINLINE /* nothing */
# endif
# define TCL_NORETURN1 /* nothing */
#endif
@@ -194,8 +198,7 @@ extern "C" {
* MSVCRT.
*/
-#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
-# define HAVE_DECLSPEC 1
+#ifdef _WIN32
# ifdef STATIC_BUILD
# define DLLIMPORT
# define DLLEXPORT
@@ -257,7 +260,6 @@ extern "C" {
#ifndef TCL_NO_DEPRECATED
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
-#endif
/*
* Definitions that allow this header file to be used either with or without
@@ -267,34 +269,14 @@ extern "C" {
#ifndef INLINE
# define INLINE
#endif
-
-#ifdef NO_CONST
-# ifndef const
-# define const
-# endif
-#endif
#ifndef CONST
# define CONST const
#endif
-#ifdef USE_NON_CONST
-# ifdef USE_COMPAT_CONST
-# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
-# endif
-# define CONST84
-# define CONST84_RETURN
-#else
-# ifdef USE_COMPAT_CONST
-# define CONST84
-# define CONST84_RETURN const
-# else
-# define CONST84 const
-# define CONST84_RETURN const
-# endif
-#endif
+#endif /* !TCL_NO_DEPRECATED */
#ifndef CONST86
-# define CONST86 CONST84
+# define CONST86 const
#endif
/*
@@ -318,14 +300,15 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
-#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
+#ifndef TCL_NO_DEPRECATED
+#if defined(_WIN32)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
-#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */
+#endif /* _WIN32 */
/*
* Macro to use instead of "void" for arguments that must have type "void *"
@@ -333,25 +316,15 @@ typedef long LONG;
*/
#ifndef __VXWORKS__
-# ifndef NO_VOID
-# define VOID void
-# else
-# define VOID char
-# endif
+# define VOID void
#endif
+#endif /* !TCL_NO_DEPRECATED */
/*
* Miscellaneous declarations.
*/
-#ifndef _CLIENTDATA
-# ifndef NO_VOID
- typedef void *ClientData;
-# else
- typedef int *ClientData;
-# endif
-# define _CLIENTDATA
-#endif
+typedef void *ClientData;
/*
* Darwin specific configure overrides (to support fat compiles, where
@@ -360,11 +333,9 @@ typedef long LONG;
#ifdef __APPLE__
# ifdef __LP64__
-# undef TCL_WIDE_INT_TYPE
# define TCL_WIDE_INT_IS_LONG 1
# define TCL_CFG_DO64BIT 1
# else /* !__LP64__ */
-# define TCL_WIDE_INT_TYPE long long
# undef TCL_WIDE_INT_IS_LONG
# undef TCL_CFG_DO64BIT
# endif /* __LP64__ */
@@ -376,8 +347,6 @@ typedef long LONG;
*/
#if defined(__GNUC__) && !defined(_WIN32) && !defined(__LP64__)
# undef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long long
#endif
/*
@@ -395,78 +364,75 @@ typedef long LONG;
*
* The following invariant should hold for any long value 'longVal':
* longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
- *
- * Note on converting between Tcl_WideInt and strings. This implementation (in
- * tclObj.c) depends on the function
- * snprintf(...,"%" TCL_LL_MODIFIER "d",...).
- */
-
-#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
-# ifdef _WIN32
-# define TCL_WIDE_INT_TYPE __int64
-# ifdef __BORLANDC__
-# define TCL_LL_MODIFIER "L"
-# elif defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO)
-# define TCL_LL_MODIFIER "I64"
-# else
-# define TCL_LL_MODIFIER "ll"
-# endif
-# elif defined(__GNUC__)
-# define TCL_WIDE_INT_TYPE long long
-# define TCL_LL_MODIFIER "ll"
-# else /* ! _WIN32 && ! __GNUC__ */
+ */
+
+#if !defined(TCL_WIDE_INT_TYPE) && !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__GNUC__)
/*
* Don't know what platform it is and configure hasn't discovered what is
* going on for us. Try to guess...
*/
-# include <limits.h>
-# if (INT_MAX < LONG_MAX)
-# define TCL_WIDE_INT_IS_LONG 1
-# else
-# define TCL_WIDE_INT_TYPE long long
-# endif
-# endif /* _WIN32 */
-#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
-#ifdef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long
-#endif /* TCL_WIDE_INT_IS_LONG */
+# include <limits.h>
+# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX)
+# define TCL_WIDE_INT_IS_LONG 1
+# endif
+#endif
+
+#ifndef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long long
+#endif /* !TCL_WIDE_INT_TYPE */
typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
-#ifdef TCL_WIDE_INT_IS_LONG
-# define Tcl_WideAsLong(val) ((long)(val))
-# define Tcl_LongAsWide(val) ((long)(val))
-# define Tcl_WideAsDouble(val) ((double)((long)(val)))
-# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "l"
-# endif /* !TCL_LL_MODIFIER */
-#else /* TCL_WIDE_INT_IS_LONG */
-/*
- * The next short section of defines are only done when not running on Windows
- * or some other strange platform.
- */
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "ll"
-# endif /* !TCL_LL_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)))
-#endif /* TCL_WIDE_INT_IS_LONG */
+#ifndef TCL_LL_MODIFIER
+# if defined(_WIN32) && (!defined(__USE_MINGW_ANSI_STDIO) || !__USE_MINGW_ANSI_STDIO)
+# define TCL_LL_MODIFIER "I64"
+# else
+# define TCL_LL_MODIFIER "ll"
+# endif
+#endif /* !TCL_LL_MODIFIER */
+#ifndef TCL_Z_MODIFIER
+# if defined(__GNUC__) && !defined(_WIN32)
+# define TCL_Z_MODIFIER "z"
+# elif defined(_WIN64)
+# define TCL_Z_MODIFIER TCL_LL_MODIFIER
+# else
+# define TCL_Z_MODIFIER ""
+# endif
+#endif /* !TCL_Z_MODIFIER */
+#ifndef TCL_T_MODIFIER
+# if defined(__GNUC__) && !defined(_WIN32)
+# define TCL_T_MODIFIER "t"
+# elif defined(_WIN64)
+# define TCL_T_MODIFIER TCL_LL_MODIFIER
+# else
+# define TCL_T_MODIFIER TCL_Z_MODIFIER
+# endif
+#endif /* !TCL_T_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)))
+
+#if TCL_MAJOR_VERSION < 9
+ typedef int Tcl_Size;
+# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1))
+# define TCL_SIZE_MODIFIER ""
+#else
+ typedef ptrdiff_t Tcl_Size;
+# define TCL_SIZE_MAX ((ptrdiff_t)(((size_t)-1)>>1))
+# define TCL_SIZE_MODIFIER TCL_T_MODIFIER
+#endif /* TCL_MAJOR_VERSION */
#ifdef _WIN32
-# ifdef __BORLANDC__
- typedef struct stati64 Tcl_StatBuf;
-# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T)
+# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
typedef struct __stat64 Tcl_StatBuf;
-# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T)
+# elif defined(_USE_32BIT_TIME_T)
typedef struct _stati64 Tcl_StatBuf;
# else
typedef struct _stat32i64 Tcl_StatBuf;
-# endif /* _MSC_VER < 1400 */
+# endif
#elif defined(__CYGWIN__)
typedef struct {
unsigned st_dev;
@@ -483,7 +449,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
struct {long tv_sec;} st_mtim;
struct {long tv_sec;} st_ctim;
} Tcl_StatBuf;
-#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
+#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) \
+ && (!defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64) \
+ && (!defined(_TIME_BITS) || _TIME_BITS != 64)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
@@ -510,35 +478,13 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
*/
typedef struct Tcl_Interp
-#if !defined(TCL_NO_DEPRECATED)
+#ifndef TCL_NO_DEPRECATED
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
-#ifdef USE_INTERP_RESULT
- char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* If the last command returned a string
- * result, this points to it. */
- void (*freeProc) (char *blockPtr)
- TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* Zero means the string result is statically
- * allocated. TCL_DYNAMIC means it was
- * allocated with ckalloc and should be freed
- * with ckfree. Other values give the address
- * of function to invoke to free the result.
- * Tcl_Eval must free it before executing next
- * command. */
-#else
char *resultDontUse; /* Don't use in extensions! */
void (*freeProcDontUse) (char *); /* Don't use in extensions! */
-#endif
-#ifdef USE_INTERP_ERRORLINE
- int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine");
- /* When TCL_ERROR is returned, this gives the
- * line number within the command where the
- * error occurred (1 if first line). */
-#else
int errorLineDontUse; /* Don't use in extensions! */
-#endif
}
#endif /* !TCL_NO_DEPRECATED */
Tcl_Interp;
@@ -572,9 +518,9 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream;
*/
#if defined _WIN32
-typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData);
+typedef unsigned (__stdcall Tcl_ThreadCreateProc) (void *clientData);
#else
-typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
+typedef void (Tcl_ThreadCreateProc) (void *clientData);
#endif
/*
@@ -640,19 +586,28 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
*/
typedef struct Tcl_RegExpIndices {
- long start; /* Character offset of first character in
+#if TCL_MAJOR_VERSION > 8
+ Tcl_Size start; /* Character offset of first character in
* match. */
- long end; /* Character offset of first character after
+ Tcl_Size end; /* Character offset of first character after
* the match. */
+#else
+ long start;
+ long end;
+#endif
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
- int nsubs; /* Number of subexpressions in the compiled
+ Tcl_Size nsubs; /* Number of subexpressions in the compiled
* expression. */
Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */
- long extendStart; /* The offset at which a subsequent match
+#if TCL_MAJOR_VERSION > 8
+ Tcl_Size extendStart; /* The offset at which a subsequent match
* might begin. */
+#else
+ long extendStart;
long reserved; /* Reserved for later use. */
+#endif
} Tcl_RegExpInfo;
/*
@@ -690,7 +645,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#ifndef TCL_NO_DEPRECATED
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -706,6 +663,7 @@ typedef struct stat *Tcl_OldStat_;
* Argument descriptors for math function callbacks in expressions:
*/
+#ifndef TCL_NO_DEPRECATED
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
@@ -717,6 +675,10 @@ typedef struct Tcl_Value {
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
+#else
+#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */
+#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */
+#endif
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
@@ -731,64 +693,71 @@ struct Tcl_Obj;
*/
typedef int (Tcl_AppInitProc) (Tcl_Interp *interp);
-typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_AsyncProc) (void *clientData, Tcl_Interp *interp,
int code);
-typedef void (Tcl_ChannelProc) (ClientData clientData, int mask);
-typedef void (Tcl_CloseProc) (ClientData data);
-typedef void (Tcl_CmdDeleteProc) (ClientData clientData);
-typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char *argv[]);
-typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
+typedef void (Tcl_ChannelProc) (void *clientData, int mask);
+typedef void (Tcl_CloseProc) (void *data);
+typedef void (Tcl_CmdDeleteProc) (void *clientData);
+typedef int (Tcl_CmdProc) (void *clientData, Tcl_Interp *interp,
+ int argc, const char *argv[]);
+typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, CONST84 char *argv[]);
-typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
+ 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) (ClientData clientData);
+#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc
+typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr);
-typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src,
+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);
-typedef void (Tcl_EncodingFreeProc) (ClientData clientData);
+typedef void (Tcl_EncodingFreeProc) (void *clientData);
typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags);
-typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags);
-typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData);
-typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags);
-typedef void (Tcl_ExitProc) (ClientData clientData);
-typedef void (Tcl_FileProc) (ClientData clientData, int mask);
-typedef void (Tcl_FileFreeProc) (ClientData clientData);
+typedef void (Tcl_EventCheckProc) (void *clientData, int flags);
+typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData);
+typedef void (Tcl_EventSetupProc) (void *clientData, int flags);
+typedef void (Tcl_ExitProc) (void *clientData);
+typedef void (Tcl_FileProc) (void *clientData, int mask);
+typedef void (Tcl_FileFreeProc) (void *clientData);
typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr);
typedef void (Tcl_FreeProc) (char *blockPtr);
-typedef void (Tcl_IdleProc) (ClientData clientData);
-typedef void (Tcl_InterpDeleteProc) (ClientData clientData,
+typedef void (Tcl_IdleProc) (void *clientData);
+typedef void (Tcl_InterpDeleteProc) (void *clientData,
Tcl_Interp *interp);
-typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_MathProc) (void *clientData, Tcl_Interp *interp,
Tcl_Value *args, Tcl_Value *resultPtr);
-typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData);
-typedef int (Tcl_ObjCmdProc) (ClientData 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_PackageInitProc) (Tcl_Interp *interp);
-typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags);
+#define Tcl_ObjCmdProc2 Tcl_ObjCmdProc
+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) (ClientData callbackData, Tcl_Channel chan,
+typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan,
char *address, int port);
-typedef void (Tcl_TimerProc) (ClientData clientData);
+typedef void (Tcl_TimerProc) (void *clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
-typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
- CONST84 char *part1, CONST84 char *part2, int flags);
-typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
+typedef char * (Tcl_VarTraceProc) (void *clientData, Tcl_Interp *interp,
+ const char *part1, const char *part2, int flags);
+typedef void (Tcl_CommandTraceProc) (void *clientData, Tcl_Interp *interp,
const char *oldName, const char *newName, int flags);
typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
- ClientData clientData);
+ void *clientData);
typedef void (Tcl_DeleteFileHandlerProc) (int fd);
-typedef void (Tcl_AlertNotifierProc) (ClientData clientData);
+typedef void (Tcl_AlertNotifierProc) (void *clientData);
typedef void (Tcl_ServiceModeHookProc) (int mode);
-typedef ClientData (Tcl_InitNotifierProc) (void);
-typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData);
+typedef void *(Tcl_InitNotifierProc) (void);
+typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
-
+
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_PackageInitProc Tcl_LibraryInitProc
+# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
+#endif
+
/*
*----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
@@ -813,6 +782,30 @@ typedef struct Tcl_ObjType {
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
} Tcl_ObjType;
+#define TCL_OBJTYPE_V0 /* just empty */
+
+/*
+ * The following structure stores an internal representation (internalrep) for
+ * a Tcl value. An internalrep is associated with an Tcl_ObjType when both
+ * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
+ * the handling of the internalrep.
+ */
+
+typedef union Tcl_ObjInternalRep { /* The internal representation: */
+ long longValue; /* - an long integer value. */
+ double doubleValue; /* - a double-precision floating value. */
+ void *otherValuePtr; /* - another, type-specific value, */
+ /* not used internally any more. */
+ Tcl_WideInt wideValue; /* - an integer value >= 64bits */
+ struct { /* - internal rep as two pointers. */
+ void *ptr1;
+ void *ptr2;
+ } twoPtrValue;
+ struct { /* - internal rep as a pointer and a long, */
+ void *ptr; /* not used internally any more. */
+ unsigned long value;
+ } ptrAndLongRep;
+} Tcl_ObjInternalRep;
/*
* One of the following structures exists for each object in the Tcl system.
@@ -821,7 +814,7 @@ typedef struct Tcl_ObjType {
*/
typedef struct Tcl_Obj {
- int refCount; /* When 0 the object will be freed. */
+ Tcl_Size refCount; /* When 0 the object will be freed. */
char *bytes; /* This points to the first byte of the
* object's string representation. The array
* must be followed by a null byte (i.e., at
@@ -833,45 +826,15 @@ typedef struct Tcl_Obj {
* should use Tcl_GetStringFromObj or
* Tcl_GetString to get a pointer to the byte
* array as a readonly value. */
- int length; /* The number of bytes at *bytes, not
+ Tcl_Size length; /* The number of bytes at *bytes, not
* including the terminating null. */
const Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
- union { /* The internal representation: */
- long longValue; /* - an long integer value. */
- double doubleValue; /* - a double-precision floating value. */
- void *otherValuePtr; /* - another, type-specific value,
- not used internally any more. */
- Tcl_WideInt wideValue; /* - a long long value. */
- struct { /* - internal rep as two pointers.
- * the main use of which is a bignum's
- * tightly packed fields, where the alloc,
- * used and signum flags are packed into
- * ptr2 with everything else hung off ptr1. */
- void *ptr1;
- void *ptr2;
- } twoPtrValue;
- struct { /* - internal rep as a pointer and a long,
- not used internally any more. */
- void *ptr;
- unsigned long value;
- } ptrAndLongRep;
- } internalRep;
+ Tcl_ObjInternalRep internalRep; /* The internal representation: */
} Tcl_Obj;
-/*
- * Macros to increment and decrement a Tcl_Obj's reference count, and to test
- * whether an object is shared (i.e. has reference count > 1). Note: clients
- * should use Tcl_DecrRefCount() when they are finished using an object, and
- * should never call TclFreeObj() directly. TclFreeObj() is only defined and
- * made public in tcl.h to support Tcl_DecrRefCount's macro definition.
- */
-
-void Tcl_IncrRefCount(Tcl_Obj *objPtr);
-void Tcl_DecrRefCount(Tcl_Obj *objPtr);
-int Tcl_IsShared(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------------------
@@ -880,6 +843,7 @@ int Tcl_IsShared(Tcl_Obj *objPtr);
* typically allocated on the stack.
*/
+#ifndef TCL_NO_DEPRECATED
typedef struct Tcl_SavedResult {
char *result;
Tcl_FreeProc *freeProc;
@@ -887,8 +851,9 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
+#endif
/*
*----------------------------------------------------------------------------
@@ -904,7 +869,7 @@ typedef struct Tcl_Namespace {
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
- ClientData clientData; /* Arbitrary value associated with this
+ void *clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Function invoked when deleting the
@@ -941,14 +906,14 @@ typedef struct Tcl_Namespace {
typedef struct Tcl_CallFrame {
Tcl_Namespace *nsPtr;
int dummy1;
- int dummy2;
+ Tcl_Size dummy2;
void *dummy3;
void *dummy4;
void *dummy5;
- int dummy6;
+ Tcl_Size dummy6;
void *dummy7;
void *dummy8;
- int dummy9;
+ Tcl_Size dummy9;
void *dummy10;
void *dummy11;
void *dummy12;
@@ -972,23 +937,25 @@ typedef struct Tcl_CallFrame {
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
- * Tcl_CreateObjCommand; 0 otherwise.
- * Tcl_SetCmdInfo does not modify this
- * field. */
+ * 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. */
- ClientData objClientData; /* ClientData for object proc. */
+ void *objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
- ClientData clientData; /* ClientData for string proc. */
+ void *clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
- ClientData deleteData; /* Value to pass to deleteProc (usually the
+ 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; /* Not used in Tcl 8.7. */
+ void *objClientData2; /* Not used in Tcl 8.7. */
} Tcl_CmdInfo;
/*
@@ -1002,9 +969,9 @@ typedef struct Tcl_CmdInfo {
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* staticSpace below or a malloced array. */
- int length; /* Number of non-NULL characters in the
+ Tcl_Size length; /* Number of non-NULL characters in the
* string. */
- int spaceAvl; /* Total number of bytes available for the
+ Tcl_Size spaceAvl; /* Total number of bytes available for the
* string and its terminating NULL char. */
char staticSpace[TCL_DSTRING_STATIC_SIZE];
/* Space to use in common case where string is
@@ -1013,12 +980,14 @@ typedef struct Tcl_DString {
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
-#define Tcl_DStringTrunc Tcl_DStringSetLength
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_DStringTrunc Tcl_DStringSetLength
+#endif
/*
* Definitions for the maximum number of digits of precision that may be
- * specified in the "tcl_precision" variable, and the number of bytes of
- * buffer space required by Tcl_PrintDouble.
+ * produced by Tcl_PrintDouble, and the number of bytes of buffer space
+ * required by Tcl_PrintDouble.
*/
#define TCL_MAX_PREC 17
@@ -1030,7 +999,21 @@ typedef struct Tcl_DString {
* 64-bit integers).
*/
-#define TCL_INTEGER_SPACE 24
+#define TCL_INTEGER_SPACE (3*(int)sizeof(Tcl_WideInt))
+
+/*
+ *----------------------------------------------------------------------------
+ * Type values returned by Tcl_GetNumberFromObj
+ * TCL_NUMBER_INT Representation is a Tcl_WideInt
+ * TCL_NUMBER_BIG Representation is an mp_int
+ * TCL_NUMBER_DOUBLE Representation is a double
+ * TCL_NUMBER_NAN Value is NaN.
+ */
+
+#define TCL_NUMBER_INT 2
+#define TCL_NUMBER_BIG 3
+#define TCL_NUMBER_DOUBLE 4
+#define TCL_NUMBER_NAN 5
/*
* Flag values passed to Tcl_ConvertElement.
@@ -1046,12 +1029,28 @@ typedef struct Tcl_DString {
#define TCL_DONT_QUOTE_HASH 8
/*
- * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
- * abbreviated strings.
+ * Flags that may be passed to Tcl_GetIndexFromObj.
+ * TCL_EXACT disallows abbreviated strings.
+ * TCL_NULL_OK allows the empty string or NULL to return TCL_OK.
+ * The returned value will be -1;
+ * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is
+ * a table that will not live long enough to make it worthwhile.
*/
-#define TCL_EXACT 1
+#define TCL_EXACT 1
+#define TCL_NULL_OK 32
+#define TCL_INDEX_TEMP_TABLE 64
+
+/*
+ * Flags that may be passed to Tcl_UniCharToUtf.
+ * TCL_COMBINE Combine surrogates (default in Tcl 8.x)
+ */
+#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.
@@ -1104,10 +1103,14 @@ typedef struct Tcl_DString {
#define TCL_TRACE_WRITES 0x20
#define TCL_TRACE_UNSETS 0x40
#define TCL_TRACE_DESTROYED 0x80
+
+#ifndef TCL_NO_DEPRECATED
#define TCL_INTERP_DESTROYED 0x100
+#endif
+
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
/* Required to support old variable/vdelete/vinfo traces. */
#define TCL_TRACE_OLD_STYLE 0x1000
#endif
@@ -1139,9 +1142,9 @@ typedef struct Tcl_DString {
* give the flag)
*/
-#if !defined(TCL_NO_DEPRECATED)
+#ifndef TCL_NO_DEPRECATED
# define TCL_PARSE_PART1 0x400
-#endif /* !TCL_NO_DEPRECATED */
+#endif
/*
* Types for linked variables:
@@ -1157,40 +1160,43 @@ typedef struct Tcl_DString {
#define TCL_LINK_SHORT 8
#define TCL_LINK_USHORT 9
#define TCL_LINK_UINT 10
+#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
+#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#else
#define TCL_LINK_LONG 11
#define TCL_LINK_ULONG 12
+#endif
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
+#define TCL_LINK_CHARS 15
+#define TCL_LINK_BINARY 16
#define TCL_LINK_READ_ONLY 0x80
-
+
/*
*----------------------------------------------------------------------------
* Forward declarations of Tcl_HashTable and related types.
*/
+#ifndef TCL_HASH_TYPE
+#if TCL_MAJOR_VERSION > 8
+# define TCL_HASH_TYPE size_t
+#else
+# define TCL_HASH_TYPE unsigned
+#endif
+#endif
+
typedef struct Tcl_HashKeyType Tcl_HashKeyType;
typedef struct Tcl_HashTable Tcl_HashTable;
typedef struct Tcl_HashEntry Tcl_HashEntry;
-typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
+typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr);
typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr);
typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr,
void *keyPtr);
typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr);
/*
- * This flag controls whether the hash table stores the hash of a key, or
- * recalculates it. There should be no reason for turning this flag off as it
- * is completely binary and source compatible unless you directly access the
- * bucketPtr member of the Tcl_HashTableEntry structure. This member has been
- * removed and the space used to store the hash value.
- */
-
-#ifndef TCL_HASH_KEY_STORE_HASH
-# define TCL_HASH_KEY_STORE_HASH 1
-#endif
-
-/*
* Structure definition for an entry in a hash table. No-one outside Tcl
* should access any of these fields directly; use the macros defined below.
*/
@@ -1199,16 +1205,10 @@ struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
-#if TCL_HASH_KEY_STORE_HASH
void *hash; /* Hash value, stored as pointer to ensure
* that the offsets of the fields in this
* structure are not changed. */
-#else
- Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first
- * entry in this entry's chain: used for
- * deleting the entry. */
-#endif
- ClientData clientData; /* Application stores something here with
+ void *clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
@@ -1296,16 +1296,21 @@ struct Tcl_HashTable {
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
- int numBuckets; /* Total number of buckets allocated at
+ Tcl_Size numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
- int numEntries; /* Total number of entries present in
+ Tcl_Size numEntries; /* Total number of entries present in
* table. */
- int rebuildSize; /* Enlarge table when numEntries gets to be
+ Tcl_Size 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. */
- int mask; /* Mask value used in hashing function. */
+#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
@@ -1326,7 +1331,7 @@ struct Tcl_HashTable {
typedef struct Tcl_HashSearch {
Tcl_HashTable *tablePtr; /* Table being searched. */
- int nextIndex; /* Index of next bucket to be enumerated after
+ Tcl_Size nextIndex; /* Index of next bucket to be enumerated after
* present one. */
Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current
* bucket. */
@@ -1367,8 +1372,8 @@ typedef struct Tcl_HashSearch {
typedef struct {
void *next; /* Search position for underlying hash
* table. */
- int epoch; /* Epoch marker for dictionary being searched,
- * or -1 if search has terminated. */
+ 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;
@@ -1400,11 +1405,12 @@ struct Tcl_Event {
};
/*
- * Positions to pass to Tcl_QueueEvent:
+ * Positions to pass to Tcl_QueueEvent/Tcl_ThreadQueueEvent:
*/
typedef enum {
- TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
+ TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ TCL_QUEUE_ALERT_IF_EMPTY=4
} Tcl_QueuePosition;
/*
@@ -1433,8 +1439,8 @@ typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr);
* TIP #233 (Virtualized Time)
*/
-typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData);
-typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
+typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, void *clientData);
+typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData);
/*
*----------------------------------------------------------------------------
@@ -1470,16 +1476,22 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
* interface.
*/
-#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *) 1)
+#if TCL_MAJOR_VERSION > 8
+# define TCL_CLOSE2PROC NULL
+#else
+# define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)(void *)(size_t)1)
+#endif
/*
* Channel version tag. This was introduced in 8.3.2/8.4.
*/
+#ifndef TCL_NO_DEPRECATED
#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2)
#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3)
#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4)
+#endif
#define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5)
/*
@@ -1493,41 +1505,41 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
* Typedefs for the various operations in a channel type:
*/
-typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode);
-typedef int (Tcl_DriverCloseProc) (ClientData instanceData,
+typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode);
+typedef int (Tcl_DriverCloseProc) (void *instanceData,
Tcl_Interp *interp);
-typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
+typedef int (Tcl_DriverClose2Proc) (void *instanceData,
Tcl_Interp *interp, int flags);
-typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
+typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf,
int toRead, int *errorCodePtr);
-typedef int (Tcl_DriverOutputProc) (ClientData instanceData,
- CONST84 char *buf, int toWrite, int *errorCodePtr);
-typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset,
+typedef int (Tcl_DriverOutputProc) (void *instanceData,
+ const char *buf, int toWrite, int *errorCodePtr);
+typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset,
int mode, int *errorCodePtr);
-typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
+typedef int (Tcl_DriverSetOptionProc) (void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
-typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
- Tcl_Interp *interp, CONST84 char *optionName,
+typedef int (Tcl_DriverGetOptionProc) (void *instanceData,
+ Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask);
-typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData,
- int direction, ClientData *handlePtr);
-typedef int (Tcl_DriverFlushProc) (ClientData instanceData);
-typedef int (Tcl_DriverHandlerProc) (ClientData instanceData,
+typedef void (Tcl_DriverWatchProc) (void *instanceData, int mask);
+typedef int (Tcl_DriverGetHandleProc) (void *instanceData,
+ int direction, void **handlePtr);
+typedef int (Tcl_DriverFlushProc) (void *instanceData);
+typedef int (Tcl_DriverHandlerProc) (void *instanceData,
int interestMask);
-typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
+typedef long long (Tcl_DriverWideSeekProc) (void *instanceData,
+ long long offset, int mode, int *errorCodePtr);
/*
* TIP #218, Channel Thread Actions
*/
-typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData,
+typedef void (Tcl_DriverThreadActionProc) (void *instanceData,
int action);
/*
* TIP #208, File Truncation (etc.)
*/
-typedef int (Tcl_DriverTruncateProc) (ClientData instanceData,
- Tcl_WideInt length);
+typedef int (Tcl_DriverTruncateProc) (void *instanceData,
+ long long length);
/*
* struct Tcl_ChannelType:
@@ -1548,7 +1560,7 @@ typedef struct Tcl_ChannelType {
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
- * TCL_CLOSE2PROC if the close2Proc should be
+ * NULL or TCL_CLOSE2PROC if the close2Proc should be
* used instead. */
Tcl_DriverInputProc *inputProc;
/* Function to call for input on channel. */
@@ -1708,13 +1720,13 @@ typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
typedef int (Tcl_FSLoadFileProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr);
typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr,
- ClientData *clientDataPtr);
+ void **clientDataPtr);
typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr);
typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr);
-typedef void (Tcl_FSFreeInternalRepProc) (ClientData clientData);
-typedef ClientData (Tcl_FSDupInternalRepProc) (ClientData clientData);
-typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (ClientData clientData);
-typedef ClientData (Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr);
+typedef void (Tcl_FSFreeInternalRepProc) (void *clientData);
+typedef void *(Tcl_FSDupInternalRepProc) (void *clientData);
+typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData);
+typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr);
typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
@@ -1744,7 +1756,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
typedef struct Tcl_Filesystem {
const char *typeName; /* The name of the filesystem. */
- int structureLength; /* Length of this structure, so future binary
+ Tcl_Size structureLength; /* Length of this structure, so future binary
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
@@ -1906,8 +1918,8 @@ typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
const char *start; /* First character in token. */
- int size; /* Number of bytes in token. */
- int numComponents; /* If this token is composed of other tokens,
+ Tcl_Size size; /* Number of bytes in token. */
+ Tcl_Size numComponents; /* If this token is composed of other tokens,
* this field tells how many of them there are
* (including components of components, etc.).
* The component tokens immediately follow
@@ -2021,28 +2033,34 @@ typedef struct Tcl_Token {
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
- int commentSize; /* Number of bytes in comments (up through
+ Tcl_Size 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. */
- int commandSize; /* Number of bytes in command, including first
+ Tcl_Size commandSize; /* Number of bytes in command, including first
* character of first word, up through the
* terminating newline, close bracket, or
* semicolon. */
- int numWords; /* Total number of words in command. May be
+ Tcl_Size 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. */
- int numTokens; /* Total number of tokens in command. */
- int tokensAvailable; /* Total number of tokens available at
+ Tcl_Size numTokens; /* Total number of tokens in command. */
+ Tcl_Size 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.
@@ -2061,10 +2079,9 @@ typedef struct Tcl_Parse {
* beginning of region where the error
* occurred (e.g. the open brace if the close
* brace is missing). */
- 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. */
+#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
@@ -2092,13 +2109,13 @@ typedef struct Tcl_EncodingType {
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
- ClientData clientData; /* Arbitrary value associated with encoding
+ void *clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion functions. */
- int nullSize; /* Number of zero bytes that signify
+ Tcl_Size nullSize; /* Number of zero bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
- * negative. Must be 1 or 2. */
+ * negative. Must be 1, 2, or 4. */
} Tcl_EncodingType;
/*
@@ -2125,10 +2142,10 @@ typedef struct Tcl_EncodingType {
* encountering an invalid byte sequence or a
* source character that has no mapping in the
* target encoding. If clear, the converter
- * substitues the problematic character(s) with
+ * substitutes the problematic character(s) with
* one or more "close" characters in the
* destination buffer and then continues to
- * convert the source.
+ * convert the source. Only for Tcl 8.x.
* TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a
* terminating NUL byte. Since it does not need
* an extra byte for a terminating NUL, it fills
@@ -2143,6 +2160,12 @@ typedef struct Tcl_EncodingType {
* content. Otherwise, the number of chars
* produced is controlled only by other limiting
* factors.
+ * TCL_ENCODING_PROFILE_* - Mutually exclusive encoding profile ids. Note
+ * these are bit masks.
+ *
+ * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
+ * DEFINED IN tclEncoding.c (ENCODING_INPUT et al). Be cognizant of this
+ * when adding bits.
*/
#define TCL_ENCODING_START 0x01
@@ -2150,6 +2173,16 @@ typedef struct Tcl_EncodingType {
#define TCL_ENCODING_STOPONERROR 0x04
#define TCL_ENCODING_NO_TERMINATE 0x08
#define TCL_ENCODING_CHAR_LIMIT 0x10
+/* Internal use bits, do not define bits in this space. See above comment */
+#define TCL_ENCODING_INTERNAL_USE_MASK 0xFF00
+/*
+ * Reserve top byte for profile values (disjoint, not a mask). In case of
+ * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if
+ * necessary.
+ */
+#define TCL_ENCODING_PROFILE_STRICT TCL_ENCODING_STOPONERROR
+#define TCL_ENCODING_PROFILE_TCL8 0x01000000
+#define TCL_ENCODING_PROFILE_REPLACE 0x02000000
/*
* The following definitions are the error codes returned by the conversion
@@ -2186,15 +2219,17 @@ typedef struct Tcl_EncodingType {
/*
* The maximum number of bytes that are necessary to represent a single
- * Unicode character in UTF-8. The valid values should be 3, 4 or 6. If 3 or
- * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6,
- * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode
- * is the default and recommended mode. UCS-4 is experimental and not
- * recommended. It works for the core, but most extensions expect UCS-2.
+ * Unicode character in UTF-8. The valid values are 3 and 4. If > 3,
+ * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default for the
+ * Tcl core). If == 3, then Tcl_UniChar must be 2-bytes in size (UTF-16).
*/
#ifndef TCL_UTF_MAX
-#define TCL_UTF_MAX 3
+# ifdef BUILD_tcl
+# define TCL_UTF_MAX 4
+# else
+# define TCL_UTF_MAX 3
+# endif
#endif
/*
@@ -2202,17 +2237,17 @@ typedef struct Tcl_EncodingType {
* reflected in regcustom.h.
*/
-#if TCL_UTF_MAX > 4
+#if TCL_UTF_MAX == 4
/*
- * unsigned int isn't 100% accurate as it should be a strict 4-byte value.
- * The size of this value must be reflected correctly in regcustom.h.
- * XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode
- * XXX: string rep that Tcl_UniChar represents. Changing the size
- * XXX: of Tcl_UniChar is /not/ supported.
+ * int isn't 100% accurate as it should be a strict 4-byte value
+ * (perhaps int32_t). ILP64/SILP64 systems may have troubles. The
+ * size of this value must be reflected correctly in regcustom.h.
*/
-typedef unsigned int Tcl_UniChar;
-#else
+typedef int Tcl_UniChar;
+#elif TCL_UTF_MAX == 3 && !defined(BUILD_tcl)
typedef unsigned short Tcl_UniChar;
+#else
+# error "This TCL_UTF_MAX value is not supported"
#endif
/*
@@ -2242,18 +2277,27 @@ typedef struct Tcl_Config {
* command- or time-limit is exceeded by an interpreter.
*/
-typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp);
-typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData);
+typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp);
+typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData);
+#if 0
/*
*----------------------------------------------------------------------------
- * Override definitions for libtommath.
+ * We would like to provide an anonymous structure "mp_int" here, which is
+ * compatible with libtommath's "mp_int", but without duplicating anything
+ * from <tommath.h> or including <tommath.h> here. But the libtommath project
+ * didn't honor our request. See: <https://github.com/libtom/libtommath/pull/473>
+ *
+ * That's why this part is commented out, and we are using (void *) in
+ * various API's in stead of the more correct (mp_int *).
*/
-typedef struct mp_int mp_int;
+#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
-typedef unsigned int mp_digit;
-#define MP_DIGIT_DECLARED
+typedef struct mp_int mp_int;
+#endif
+
+#endif
/*
*----------------------------------------------------------------------------
@@ -2272,7 +2316,7 @@ typedef struct {
* depends on type.*/
const char *helpStr; /* Documentation message describing this
* option. */
- ClientData clientData; /* Word to pass to function callbacks. */
+ void *clientData; /* Word to pass to function callbacks. */
} Tcl_ArgvInfo;
/*
@@ -2295,9 +2339,9 @@ typedef struct {
* argument types:
*/
-typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr,
+typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr,
void *dstPtr);
-typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
+typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv, void *dstPtr);
/*
@@ -2364,10 +2408,25 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
/*
*----------------------------------------------------------------------------
+ * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456]
+ */
+#define TCL_TCPSERVER_REUSEADDR (1<<0)
+#define TCL_TCPSERVER_REUSEPORT (1<<1)
+
+/*
+ * Constants for special Tcl_Size-typed values, see TIP #494
+ */
+
+#define TCL_IO_FAILURE ((Tcl_Size)-1)
+#define TCL_AUTO_LENGTH ((Tcl_Size)-1)
+#define TCL_INDEX_NONE ((Tcl_Size)-1)
+
+/*
+ *----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
-typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
+typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp,
int result);
/*
@@ -2376,7 +2435,11 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
* stubs tables.
*/
-#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
+#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
@@ -2386,17 +2449,31 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
*/
const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
- int exact);
+ int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
+#if defined(_WIN32)
+ TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
+#else
+# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
+#endif
-/*
- * When not using stubs, make it a macro.
- */
-
-#ifndef USE_TCL_STUBS
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgInitStubsCheck(interp, version, exact)
+#ifdef USE_TCL_STUBS
+# if TCL_UTF_MAX < 4
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+# else
+# define Tcl_InitStubs(interp, version, exact) \
+ (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
+ TCL_STUB_MAGIC)
+# endif
+#else
+# define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgInitStubsCheck(interp, version, \
+ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#endif
/*
@@ -2405,12 +2482,22 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- ((Tcl_CreateInterp)()))
-EXTERN void Tcl_MainEx(int argc, char **argv,
+ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)()))
+EXTERN void Tcl_MainEx(Tcl_Size 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_SetPreInitScript(const char *string);
+#ifndef TCL_NO_DEPRECATED
+# define Tcl_StaticPackage Tcl_StaticLibrary
+#endif
+#ifdef _WIN32
+EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv);
+#else
+EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
+#endif
/*
*----------------------------------------------------------------------------
@@ -2481,19 +2568,24 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#endif /* !TCL_MEM_DEBUG */
#ifdef TCL_MEM_DEBUG
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#else
+# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* https://wiki.c2.com/?TrivialDoWhileLoop
*/
+# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
@@ -2501,6 +2593,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
TclFreeObj(_objPtr); \
} \
} while(0)
+# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
@@ -2517,22 +2610,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
Tcl_DbNewBignumObj(val, __FILE__, __LINE__)
# undef Tcl_NewBooleanObj
# define Tcl_NewBooleanObj(val) \
- Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
+ Tcl_DbNewWideIntObj((val)!=0, __FILE__, __LINE__)
# undef Tcl_NewByteArrayObj
# define Tcl_NewByteArrayObj(bytes, len) \
Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
# undef Tcl_NewDoubleObj
# define Tcl_NewDoubleObj(val) \
Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
-# undef Tcl_NewIntObj
-# define Tcl_NewIntObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewListObj
# define Tcl_NewListObj(objc, objv) \
Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
-# undef Tcl_NewLongObj
-# define Tcl_NewLongObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewObj
# define Tcl_NewObj() \
Tcl_DbNewObj(__FILE__, __LINE__)
@@ -2550,7 +2637,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
*/
#define Tcl_GetHashValue(h) ((h)->clientData)
-#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
+#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *)(value))
#define Tcl_GetHashKey(tablePtr, h) \
((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
(tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
@@ -2571,27 +2658,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
/*
*----------------------------------------------------------------------------
- * Macros that eliminate the overhead of the thread synchronization functions
- * when compiling without thread support.
- */
-
-#ifndef TCL_THREADS
-#undef Tcl_MutexLock
-#define Tcl_MutexLock(mutexPtr)
-#undef Tcl_MutexUnlock
-#define Tcl_MutexUnlock(mutexPtr)
-#undef Tcl_MutexFinalize
-#define Tcl_MutexFinalize(mutexPtr)
-#undef Tcl_ConditionNotify
-#define Tcl_ConditionNotify(condPtr)
-#undef Tcl_ConditionWait
-#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
-#undef Tcl_ConditionFinalize
-#define Tcl_ConditionFinalize(condPtr)
-#endif /* TCL_THREADS */
-
-/*
- *----------------------------------------------------------------------------
* Deprecated Tcl functions:
*/
@@ -2610,7 +2676,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define panic Tcl_Panic
#endif
# define panicVA Tcl_PanicVA
-#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------------
@@ -2621,6 +2686,8 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
extern Tcl_AppInitProc Tcl_AppInit;
+#endif /* !TCL_NO_DEPRECATED */
+
#endif /* RC_INVOKED */
/*
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index c9d5113..800b0ae 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -6,9 +6,9 @@
* that don't exactly fit are passed up to the next larger size. Blocks
* over a certain size are directly allocated from the system.
*
- * Copyright (c) 1983 Regents of the University of California.
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
+ * Copyright © 1983 Regents of the University of California.
+ * Copyright © 1996-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
*
* Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
*
@@ -22,7 +22,7 @@
*/
#include "tclInt.h"
-#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
+#if !TCL_THREADS || !defined(USE_THREAD_ALLOC)
#if defined(USE_TCLALLOC) && USE_TCLALLOC
@@ -31,8 +31,8 @@
* until Tcl uses config.h properly.
*/
-#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
+#if defined(_MSC_VER) || defined(__MSVCRT__)
+typedef size_t caddr_t;
#endif
/*
@@ -56,7 +56,7 @@ union overhead {
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
- unsigned long size; /* actual block size */
+ size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
@@ -94,7 +94,7 @@ union overhead {
#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1))
#define NBUCKETS (13 - (MINBLOCK >> 4))
-#define MAXMALLOC (1<<(NBUCKETS+2))
+#define MAXMALLOC ((size_t)1 << (NBUCKETS+2))
static union overhead *nextf[NBUCKETS];
/*
@@ -121,7 +121,7 @@ static struct block bigBlocks={ /* Big blocks aren't suballocated. */
* variable.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
static Tcl_Mutex *allocMutexPtr;
#endif
static int allocInit = 0;
@@ -133,7 +133,7 @@ static int allocInit = 0;
* a given block size.
*/
-static unsigned int numMallocs[NBUCKETS+1];
+static size_t numMallocs[NBUCKETS+1];
#endif
#if !defined(NDEBUG)
@@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
-static void MoreCore(int bucket);
+static void MoreCore(size_t bucket);
/*
*-------------------------------------------------------------------------
@@ -171,7 +171,7 @@ TclInitAlloc(void)
{
if (!allocInit) {
allocInit = 1;
-#ifdef TCL_THREADS
+#if TCL_THREADS
allocMutexPtr = Tcl_GetAllocMutex();
#endif
}
@@ -249,12 +249,12 @@ TclFinalizeAllocSubsystem(void)
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
union overhead *overPtr;
- long bucket;
+ size_t bucket;
unsigned amount;
struct block *bigBlockPtr = NULL;
@@ -304,7 +304,7 @@ TclpAlloc(
#endif
Tcl_MutexUnlock(allocMutexPtr);
- return (void *)(overPtr+1);
+ return (char *)(overPtr+1);
}
/*
@@ -385,12 +385,12 @@ TclpAlloc(
static void
MoreCore(
- int bucket) /* Bucket to allocate to. */
+ size_t bucket) /* What bucket to allocate to. */
{
union overhead *overPtr;
- long size; /* size of desired block */
- long amount; /* amount to allocate */
- int numBlocks; /* how many blocks we get */
+ size_t size; /* size of desired block */
+ size_t amount; /* amount to allocate */
+ size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
@@ -398,7 +398,7 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
- size = 1 << (bucket + 3);
+ size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
@@ -446,9 +446,9 @@ MoreCore(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
- long size;
+ size_t size;
union overhead *overPtr;
struct block *bigBlockPtr;
@@ -509,16 +509,16 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloc'ed block. */
+ void *oldPtr, /* Pointer to alloc'ed block. */
unsigned int numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
- unsigned long maxSize;
+ size_t maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
@@ -581,9 +581,9 @@ TclpRealloc(
#endif
Tcl_MutexUnlock(allocMutexPtr);
- return (char *)(overPtr+1);
+ return (void *)(overPtr+1);
}
- maxSize = 1 << (i+3);
+ maxSize = (size_t)1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
@@ -645,29 +645,29 @@ void
mstats(
char *s) /* Where to write info. */
{
- int i, j;
+ unsigned int i, j;
union overhead *overPtr;
- int totalFree = 0, totalUsed = 0;
+ size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
- fprintf(stderr, " %d", j);
+ fprintf(stderr, " %u", j);
}
- totalFree += j * (1 << (i + 3));
+ totalFree += ((size_t)j) * ((size_t)1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %d", numMallocs[i]);
- totalUsed += numMallocs[i] * (1 << (i + 3));
+ fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]);
+ totalUsed += numMallocs[i] * ((size_t)1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
- totalUsed, totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n",
+ totalUsed, totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%" TCL_Z_MODIFIER "u) blocks in use: %" TCL_Z_MODIFIER "u\n",
MAXMALLOC, numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
@@ -692,11 +692,11 @@ mstats(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
- return (char *) malloc(numBytes);
+ return malloc(numBytes);
}
/*
@@ -717,7 +717,7 @@ TclpAlloc(
void
TclpFree(
- char *oldPtr) /* Pointer to memory to free. */
+ void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
@@ -739,12 +739,12 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *oldPtr, /* Pointer to alloced block. */
+ void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
- return (char *) realloc(oldPtr, numBytes);
+ return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100755
index 0000000..34fd635
--- /dev/null
+++ b/generic/tclArithSeries.c
@@ -0,0 +1,1104 @@
+/*
+ * tclArithSeries.c --
+ *
+ * This file contains the ArithSeries concrete abstract list
+ * implementation. It implements the inner workings of the lseq command.
+ *
+ * Copyright © 2022 Brian S. Griffin.
+ *
+ * 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>
+#include <math.h>
+
+/*
+ * The structure below defines the arithmetic series Tcl object type by
+ * means of procedures that can be invoked by generic object code.
+ *
+ * The arithmetic series object is a special case of Tcl list representing
+ * an interval of an arithmetic series in constant space.
+ *
+ * The arithmetic series is internally represented with three integers,
+ * *start*, *end*, and *step*, Where the length is calculated with
+ * the following algorithm:
+ *
+ * if RANGE == 0 THEN
+ * ERROR
+ * if RANGE > 0
+ * LEN is (((END-START)-1)/STEP) + 1
+ * else if RANGE < 0
+ * LEN is (((END-START)-1)/STEP) - 1
+ *
+ * And where the equivalent's list I-th element is calculated
+ * as:
+ *
+ * LIST[i] = START + (STEP * i)
+ *
+ * Zero elements ranges, like in the case of START=10 END=10 STEP=1
+ * are valid and will be equivalent to the empty list.
+ */
+
+/*
+ * The structure used for the ArithSeries internal representation.
+ * Note that the len can in theory be always computed by start,end,step
+ * but it's faster to cache it inside the internal representation.
+ */
+typedef struct {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ Tcl_WideInt start;
+ Tcl_WideInt end;
+ Tcl_WideInt step;
+} ArithSeries;
+typedef struct {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ double start;
+ double end;
+ double step;
+ int precision;
+} ArithSeriesDbl;
+
+/* -------------------------- ArithSeries object ---------------------------- */
+
+static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr);
+static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
+static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
+
+const Tcl_ObjType tclArithSeriesType = {
+ "arithseries", /* name */
+ FreeArithSeriesInternalRep, /* freeIntRepProc */
+ DupArithSeriesInternalRep, /* dupIntRepProc */
+ UpdateStringOfArithSeries, /* updateStringProc */
+ SetArithSeriesFromAny /* setFromAnyProc */
+};
+
+/*
+ * Helper functions
+ *
+ * - ArithRound -- Round doubles to the number of significant fractional
+ * digits
+ * - ArithSeriesIndexDbl -- base list indexing operation for doubles
+ * - ArithSeriesIndexInt -- " " " " " integers
+ * - ArithSeriesGetInternalRep -- Return the internal rep from a Tcl_Obj
+ * - Precision -- determine the number of factional digits for the given
+ * double value
+ * - maxPrecision -- Using the values provide, determine the longest percision
+ * in the arithSeries
+ */
+static inline double
+ArithRound(double d, unsigned int n) {
+ double scalefactor = pow(10, n);
+ return round(d*scalefactor)/scalefactor;
+}
+
+static inline double
+ArithSeriesIndexDbl(
+ ArithSeries *arithSeriesRepPtr,
+ Tcl_WideInt index)
+{
+ ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr;
+ if (arithSeriesRepPtr->isDouble) {
+ double d = dblRepPtr->start + (index * dblRepPtr->step);
+ unsigned n = (dblRepPtr->precision > 0 ? dblRepPtr->precision : 0);
+ return ArithRound(d, n);
+ } else {
+ return (double)(arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step));
+ }
+}
+
+static inline Tcl_WideInt
+ArithSeriesIndexInt(
+ ArithSeries *arithSeriesRepPtr,
+ Tcl_WideInt index)
+{
+ ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr;
+ if (arithSeriesRepPtr->isDouble) {
+ return (Tcl_WideInt)(dblRepPtr->start + ((index) * dblRepPtr->step));
+ } else {
+ return (arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step));
+ }
+}
+
+static inline ArithSeries*
+ArithSeriesGetInternalRep(Tcl_Obj *objPtr)
+{
+ const Tcl_ObjInternalRep *irPtr;
+ irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType);
+ return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL;
+}
+
+/*
+ * Compute number of significant factional digits
+ */
+static inline int
+Precision(double d)
+{
+ char tmp[TCL_DOUBLE_SPACE+2], *off;
+ tmp[0] = 0;
+ Tcl_PrintDouble(NULL,d,tmp);
+ off = strchr(tmp, '.');
+ return (off ? strlen(off+1) : 0);
+}
+
+/*
+ * Find longest number of digits after the decimal point.
+ */
+static inline int
+maxPrecision(double start, double end, double step)
+{
+ int dp = Precision(step);
+ int i = Precision(start);
+ dp = i>dp ? i : dp;
+ i = Precision(end);
+ dp = i>dp ? i : dp;
+ return dp;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesLen --
+ *
+ * Compute the length of the equivalent list where
+ * every element is generated starting from *start*,
+ * and adding *step* to generate every successive element
+ * that's < *end* for positive steps, or > *end* for negative
+ * steps.
+ *
+ * Results:
+ *
+ * The length of the list generated by the given range,
+ * that may be zero.
+ * The function returns -1 if the list is of length infinite.
+ *
+ * Side effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_WideInt
+ArithSeriesLenInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
+{
+ Tcl_WideInt len;
+
+ if (step == 0) {
+ return 0;
+ }
+ len = 1 + ((end-start)/step);
+ return (len < 0) ? -1 : len;
+}
+
+static Tcl_WideInt
+ArithSeriesLenDbl(double start, double end, double step, int precision)
+{
+ double istart, iend, istep, ilen;
+ if (step == 0) {
+ return 0;
+ }
+ istart = start * pow(10,precision);
+ iend = end * pow(10,precision);
+ istep = step * pow(10,precision);
+ ilen = ((iend-istart+istep)/istep);
+ return floor(ilen);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupArithSeriesInternalRep --
+ *
+ * Initialize the internal representation of a arithseries Tcl_Obj to a
+ * copy of the internal representation of an existing arithseries object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * We set "copyPtr"s internal rep to a pointer to a
+ * newly allocated ArithSeries structure.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupArithSeriesInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ ArithSeries *srcArithSeriesRepPtr =
+ (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1;
+
+ /*
+ * Allocate a new ArithSeries structure. */
+
+ if (srcArithSeriesRepPtr->isDouble) {
+ ArithSeriesDbl *srcArithSeriesDblRepPtr =
+ (ArithSeriesDbl *)srcArithSeriesRepPtr;
+ ArithSeriesDbl *copyArithSeriesDblRepPtr =
+ (ArithSeriesDbl *) ckalloc(sizeof(ArithSeriesDbl));
+ *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr;
+ copyArithSeriesDblRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr;
+ } else {
+ ArithSeries *copyArithSeriesRepPtr =
+ (ArithSeries *)ckalloc(sizeof(ArithSeries));
+ *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
+ copyArithSeriesRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ }
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &tclArithSeriesType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesInternalRep --
+ *
+ * Free any allocated memory in the ArithSeries Rep
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries *)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+
+ if (arithSeriesRepPtr->elements) {
+ Tcl_Size i;
+ for(i=0; i<arithSeriesRepPtr->len; i++) {
+ Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
+ }
+ ckfree((char *)arithSeriesRepPtr->elements);
+ arithSeriesRepPtr->elements = NULL;
+ }
+ ckfree((char *)arithSeriesRepPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewArithSeriesInt --
+ *
+ * Creates a new ArithSeries object. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static
+Tcl_Obj *
+NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len)
+{
+ Tcl_WideInt length;
+ Tcl_Obj *arithSeriesObj;
+ ArithSeries *arithSeriesRepPtr;
+
+ length = len>=0 ? len : -1;
+ if (length < 0) length = -1;
+
+ TclNewObj(arithSeriesObj);
+
+ if (length <= 0) {
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries));
+ arithSeriesRepPtr->isDouble = 0;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesObj->typePtr = &tclArithSeriesType;
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewArithSeriesDbl --
+ *
+ * Creates a new ArithSeries object with doubles. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+static
+Tcl_Obj *
+NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len)
+{
+ Tcl_WideInt length;
+ Tcl_Obj *arithSeriesObj;
+ ArithSeriesDbl *arithSeriesRepPtr;
+
+ length = len>=0 ? len : -1;
+ if (length < 0) {
+ length = -1;
+ }
+
+ TclNewObj(arithSeriesObj);
+
+ if (length <= 0) {
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl));
+ arithSeriesRepPtr->isDouble = 1;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesRepPtr->precision = maxPrecision(start,end,step);
+ arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesObj->typePtr = &tclArithSeriesType;
+
+ if (length > 0) {
+ Tcl_InvalidateStringRep(arithSeriesObj);
+ }
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * assignNumber --
+ *
+ * Create the appropriate Tcl_Obj value for the given numeric values.
+ * Used locally only for decoding [lseq] numeric arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer.
+ * No assignment on error.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static void
+assignNumber(
+ int useDoubles,
+ Tcl_WideInt *intNumberPtr,
+ double *dblNumberPtr,
+ Tcl_Obj *numberObj)
+{
+ void *clientData;
+ int tcl_number_type;
+
+ if (Tcl_GetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK
+ || tcl_number_type == TCL_NUMBER_BIG) {
+ return;
+ }
+ if (useDoubles) {
+ if (tcl_number_type != TCL_NUMBER_INT) {
+ *dblNumberPtr = *(double *)clientData;
+ } else {
+ *dblNumberPtr = (double)*(Tcl_WideInt *)clientData;
+ }
+ } else {
+ if (tcl_number_type == TCL_NUMBER_INT) {
+ *intNumberPtr = *(Tcl_WideInt *)clientData;
+ } else {
+ *intNumberPtr = (Tcl_WideInt)*(double *)clientData;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewArithSeriesObj --
+ *
+ * Creates a new ArithSeries object. Some arguments may be NULL and will
+ * be computed based on the other given arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * An empty Tcl_Obj if the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNewArithSeriesObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj **arithSeriesObj, /* return value */
+ int useDoubles, /* Flag indicates values start,
+ ** end, step, are treated as doubles */
+ Tcl_Obj *startObj, /* Starting value */
+ Tcl_Obj *endObj, /* Ending limit */
+ Tcl_Obj *stepObj, /* increment value */
+ Tcl_Obj *lenObj) /* Number of elements */
+{
+ double dstart, dend, dstep;
+ Tcl_WideInt start, end, step;
+ Tcl_WideInt len = -1;
+
+ if (startObj) {
+ assignNumber(useDoubles, &start, &dstart, startObj);
+ } else {
+ start = 0;
+ dstart = start;
+ }
+ if (stepObj) {
+ assignNumber(useDoubles, &step, &dstep, stepObj);
+ if (useDoubles) {
+ step = dstep;
+ } else {
+ dstep = step;
+ }
+ if (dstep == 0) {
+ TclNewObj(*arithSeriesObj);
+ return TCL_OK;
+ }
+ }
+ if (endObj) {
+ assignNumber(useDoubles, &end, &dend, endObj);
+ }
+ if (lenObj) {
+ if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (startObj && endObj) {
+ if (!stepObj) {
+ if (useDoubles) {
+ dstep = (dstart < dend) ? 1.0 : -1.0;
+ step = dstep;
+ } else {
+ step = (start < end) ? 1 : -1;
+ dstep = step;
+ }
+ }
+ assert(dstep!=0);
+ if (!lenObj) {
+ if (useDoubles) {
+ int precision = maxPrecision(dstart,dend,dstep);
+ len = ArithSeriesLenDbl(dstart, dend, dstep, precision);
+ } else {
+ len = ArithSeriesLenInt(start, end, step);
+ }
+ }
+ }
+
+ if (!endObj) {
+ if (useDoubles) {
+ dend = dstart + (dstep * (len-1));
+ end = dend;
+ } else {
+ end = start + (step * (len-1));
+ dend = end;
+ }
+ }
+
+ if (len > TCL_SIZE_MAX) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ if (arithSeriesObj) {
+ *arithSeriesObj = (useDoubles)
+ ? NewArithSeriesDbl(dstart, dend, dstep, len)
+ : NewArithSeriesInt(start, end, step, len);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjIndex --
+ *
+ * Returns the element with the specified index in the list
+ * represented by the specified Arithmetic Sequence object.
+ * If the index is out of range, NULL is returned.
+ *
+ * Results:
+ *
+ * The element on success, NULL on index out of range.
+ *
+ * Side Effects:
+ *
+ * On success, the integer pointed by *element is modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjIndex(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *arithSeriesObj,
+ Tcl_Size index)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesObj->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
+ if (index < 0 || index >= arithSeriesRepPtr->len) {
+ return Tcl_NewObj();
+ }
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ return Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index));
+ } else {
+ return Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index));
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesObjLength
+ *
+ * Returns the length of the arithmetic series.
+ *
+ * Results:
+ *
+ * The length of the series as Tcl_WideInt.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)
+ arithSeriesObj->internalRep.twoPtrValue.ptr1;
+ return arithSeriesRepPtr->len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesObjStep --
+ *
+ * Return a Tcl_Obj with the step value from the give ArithSeries Obj.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+ArithSeriesObjStep(
+ Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *stepObj;
+
+ if (arithSeriesObj->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
+ if (arithSeriesRepPtr->isDouble) {
+ TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
+ } else {
+ TclNewIntObj(stepObj, arithSeriesRepPtr->step);
+ }
+ return stepObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetArithSeriesFromAny --
+ *
+ * The Arithmetic Series object is just an way to optimize
+ * Lists space complexity, so no one should try to convert
+ * a string to an Arithmetic Series object.
+ *
+ * This function is here just to populate the Type structure.
+ *
+ * Results:
+ *
+ * The result is always TCL_ERROR. But see Side Effects.
+ *
+ * Side effects:
+ *
+ * Tcl Panic if called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArithSeriesFromAny(
+ TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */
+{
+ Tcl_Panic("SetArithSeriesFromAny: should never be called");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjRange --
+ *
+ * Makes a slice of an ArithSeries value.
+ * *arithSeriesObj must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the sliced series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjRange(
+ Tcl_Interp *interp, /* For error message(s) */
+ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
+ Tcl_Size fromIdx, /* Index of first element to include. */
+ Tcl_Size toIdx) /* Index of last element to include. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+
+ arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
+
+ if (fromIdx < TCL_INDEX_NONE) {
+ fromIdx = 0;
+ }
+
+ if (fromIdx > toIdx ||
+ (toIdx > arithSeriesRepPtr->len-1 &&
+ fromIdx > arithSeriesRepPtr->len-1)) {
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (toIdx < 0) {
+ toIdx = 0;
+ }
+ if (toIdx > arithSeriesRepPtr->len-1) {
+ toIdx = arithSeriesRepPtr->len-1;
+ }
+
+ startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx);
+ if (startObj == NULL) {
+ return NULL;
+ }
+ Tcl_IncrRefCount(startObj);
+ endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx);
+ if (endObj == NULL) {
+ return NULL;
+ }
+ Tcl_IncrRefCount(endObj);
+ stepObj = ArithSeriesObjStep(arithSeriesObj);
+ Tcl_IncrRefCount(stepObj);
+
+ if (Tcl_IsShared(arithSeriesObj) ||
+ ((arithSeriesObj->refCount > 1))) {
+ Tcl_Obj *newSlicePtr;
+ if (TclNewArithSeriesObj(interp, &newSlicePtr,
+ arithSeriesRepPtr->isDouble, startObj, endObj,
+ stepObj, NULL) != TCL_OK) {
+ newSlicePtr = NULL;
+ }
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+ return newSlicePtr;
+ }
+
+ /*
+ * In-place is possible.
+ */
+
+ /*
+ * Even if nothing below causes any changes, we still want the
+ * string-canonizing effect of [lrange 0 end].
+ */
+
+ TclInvalidateStringRep(arithSeriesObj);
+
+ if (arithSeriesRepPtr->isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr;
+ double start, end, step;
+
+ Tcl_GetDoubleFromObj(NULL, startObj, &start);
+ Tcl_GetDoubleFromObj(NULL, endObj, &end);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &step);
+ arithSeriesDblRepPtr->start = start;
+ arithSeriesDblRepPtr->end = end;
+ arithSeriesDblRepPtr->step = step;
+ arithSeriesDblRepPtr->precision = maxPrecision(start, end, step);
+ arithSeriesDblRepPtr->len =
+ ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision);
+ arithSeriesDblRepPtr->elements = NULL;
+
+ } else {
+ Tcl_WideInt start, end, step;
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = ArithSeriesLenInt(start, end, step);
+ arithSeriesRepPtr->elements = NULL;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesGetElements --
+ *
+ * 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 an Abstract 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:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclArithSeriesGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *objPtr, /* ArithSeries object for which an element
+ * array is to be returned. */
+ Tcl_Size *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. */
+{
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj **objv;
+ int i, objc;
+
+ arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
+
+ objc = arithSeriesRepPtr->len;
+ if (objc > 0) {
+ if (arithSeriesRepPtr->elements) {
+ /* If this exists, it has already been populated */
+ objv = arithSeriesRepPtr->elements;
+ } else {
+ /* Construct the elements array */
+ objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc);
+ if (objv == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ arithSeriesRepPtr->elements = objv;
+ for (i = 0; i < objc; i++) {
+ objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);
+ if (objv[i] == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(objv[i]);
+ }
+ }
+ } else {
+ objv = NULL;
+ }
+ *objvPtr = objv;
+ *objcPtr = objc;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an arithseries"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", (void *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjReverse --
+ *
+ * Reverse the order of the ArithSeries value.
+ * *arithSeriesObj must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the reordered series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjReverse(
+ Tcl_Interp *interp, /* For error message(s) */
+ Tcl_Obj *arithSeriesObj) /* List object to reverse. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+ Tcl_Obj *resultObj;
+ Tcl_WideInt start, end, step, len;
+ double dstart, dend, dstep;
+ int isDouble;
+
+ arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
+
+ isDouble = arithSeriesRepPtr->isDouble;
+ len = arithSeriesRepPtr->len;
+
+ startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1));
+ Tcl_IncrRefCount(startObj);
+ endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0);
+ Tcl_IncrRefCount(endObj);
+ stepObj = ArithSeriesObjStep(arithSeriesObj);
+ Tcl_IncrRefCount(stepObj);
+
+ if (isDouble) {
+ Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
+ Tcl_GetDoubleFromObj(NULL, endObj, &dend);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &dstep);
+ dstep = -dstep;
+ TclSetDoubleObj(stepObj, dstep);
+ } else {
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ step = -step;
+ TclSetIntObj(stepObj, step);
+ }
+
+ if (Tcl_IsShared(arithSeriesObj) ||
+ ((arithSeriesObj->refCount > 1))) {
+ Tcl_Obj *lenObj;
+ TclNewIntObj(lenObj, len);
+ if (TclNewArithSeriesObj(interp, &resultObj, isDouble,
+ startObj, endObj, stepObj, lenObj) != TCL_OK) {
+ resultObj = NULL;
+ }
+ Tcl_DecrRefCount(lenObj);
+ } else {
+
+ /*
+ * In-place is possible.
+ */
+
+ TclInvalidateStringRep(arithSeriesObj);
+
+ if (isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr =
+ (ArithSeriesDbl*)arithSeriesRepPtr;
+ arithSeriesDblRepPtr->start = dstart;
+ arithSeriesDblRepPtr->end = dend;
+ arithSeriesDblRepPtr->step = dstep;
+ } else {
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ }
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ for (i=0; i<len; i++) {
+ Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
+ }
+ ckfree((char*)arithSeriesRepPtr->elements);
+ }
+ arithSeriesRepPtr->elements = NULL;
+
+ resultObj = arithSeriesObj;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return resultObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfArithSeries --
+ *
+ * Update the string representation for an arithseries object.
+ * Note: This procedure 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.
+ *
+ * Notes:
+ * At the cost of overallocation it's possible to estimate
+ * the length of the string representation and make this procedure
+ * much faster. Because the programmer shouldn't expect the
+ * string conversion of a big arithmetic sequence to be fast
+ * this version takes more care of space than time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+ char *p;
+ Tcl_Obj *elemObj;
+ Tcl_Size i;
+ Tcl_Size length = 0;
+ Tcl_Size slen;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ if (!arithSeriesRepPtr->isDouble) {
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
+ slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1;
+ length += slen;
+ }
+ } else {
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
+ char tmp[TCL_DOUBLE_SPACE+2];
+ tmp[0] = 0;
+ Tcl_PrintDouble(NULL,d,tmp);
+ if ((length + strlen(tmp)) > TCL_SIZE_MAX) {
+ break; // overflow
+ }
+ length += strlen(tmp);
+ }
+ }
+ length += arithSeriesRepPtr->len; // Space for each separator
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length);
+ if (p == NULL) {
+ Tcl_Panic("Unable to allocate string size %d", length);
+ }
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i);
+ char *str = Tcl_GetStringFromObj(elemObj, &slen);
+ if (((p - arithSeriesObjPtr->bytes)+slen) > length) {
+ break;
+ }
+ strncpy(p, str, slen);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0';
+ arithSeriesObjPtr->length = length-1;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 2e5709a..e7ce6e6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -6,8 +6,8 @@
* This file contains the procedures that convert Tcl Assembly Language (TAL)
* to a sequence of bytecode instructions for the Tcl execution engine.
*
- * Copyright (c) 2010 by Ozgur Dogan Ugurlu.
- * Copyright (c) 2010 by Kevin B. Kenny.
+ * Copyright © 2010 Ozgur Dogan Ugurlu.
+ * Copyright © 2010 Kevin B. Kenny.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -32,6 +32,7 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure that represents a range of instructions in the bytecode.
@@ -130,7 +131,7 @@ enum BasicBlockFlags {
* Source instruction type recognized by the assembler.
*/
-typedef enum TalInstType {
+typedef enum {
ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be
* converted to appropriate exception
@@ -186,8 +187,10 @@ typedef enum TalInstType {
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
- ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by
+ ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
* LVT entry. Fixed arity */
+ ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2
+ * operands, produces 1, N > 0 */
} TalInstType;
/*
@@ -271,15 +274,12 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
const TalInstDesc*);
static int DefineLabel(AssemblyEnv* envPtr, const char* label);
static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
-static void DupAssembleCodeInternalRep(Tcl_Obj* src,
- Tcl_Obj* dest);
static void FillInJumpOffsets(AssemblyEnv*);
static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
Tcl_Obj* jumpTable);
static int FindLocalVar(AssemblyEnv* envPtr,
Tcl_Token** tokenPtrPtr);
static int FinishAssembly(AssemblyEnv*);
-static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
static void FreeAssemblyEnv(AssemblyEnv*);
static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
@@ -317,6 +317,9 @@ static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
* Tcl_ObjType that describes bytecode emitted by the assembler.
*/
+static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep;
+static Tcl_DupInternalRepProc DupAssembleCodeInternalRep;
+
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
@@ -360,6 +363,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
+ {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
@@ -469,8 +473,12 @@ static const TalInstDesc TalInstructionTable[] = {
{"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
+ {"strge", ASSEM_1BYTE, INST_STR_GE, 2, 1},
+ {"strgt", ASSEM_1BYTE, INST_STR_GT, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
+ {"strle", ASSEM_1BYTE, INST_STR_LE, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
+ {"strlt", ASSEM_1BYTE, INST_STR_LT, 2, 1},
{"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
@@ -527,7 +535,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
- INST_NUM_TYPE /* 180 */
+ INST_NUM_TYPE, /* 180 */
+ INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */
};
/*
@@ -618,10 +627,14 @@ BBUpdateStackReqs(
if (consumed == INT_MIN) {
/*
- * The instruction is variadic; it consumes 'count' operands.
+ * The instruction is variadic; it consumes 'count' operands, or
+ * 'count+1' for ASSEM_DICT_GET_DEF.
*/
consumed = count;
+ if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) {
+ consumed++;
+ }
}
if (produced < 0) {
/*
@@ -759,7 +772,7 @@ BBEmitInst1or4(
int
Tcl_AssembleObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData, /* clientData */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -769,12 +782,12 @@ Tcl_AssembleObjCmd(
* because there needs to be one in place to execute bytecode.
*/
- return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv);
}
int
TclNRAssembleObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -783,7 +796,6 @@ TclNRAssembleObjCmd(
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
@@ -853,9 +865,10 @@ CompileAssembleObj(
* is valid in the current context.
*/
- if (objPtr->typePtr == &assembleCodeType) {
+ ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr);
+
+ if (codePtr) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -869,7 +882,7 @@ CompileAssembleObj(
* Not valid, so free it and regenerate.
*/
- FreeAssembleCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
@@ -894,15 +907,13 @@ CompileAssembleObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &assembleCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
/*
* Record the local variable context to which the bytecode pertains
*/
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -949,8 +960,7 @@ TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
@@ -958,7 +968,6 @@ TclCompileAssembleCmd(
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
- (void)cmdPtr;
/*
* Make sure that the command has a single arg that is a simple word.
*/
@@ -1081,8 +1090,8 @@ TclAssembleCode(
#ifdef TCL_COMPILE_DEBUG
if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
- printf(" %4ld Assembling: ",
- (long)(envPtr->codeNext - envPtr->codeStart));
+ printf(" %4" TCL_Z_MODIFIER "d Assembling: ",
+ (size_t)(envPtr->codeNext - envPtr->codeStart));
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(instLen, 55));
printf("\n");
@@ -1257,7 +1266,7 @@ AssembleOneLine(
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
- enum TalInstType instType; /* Type of the instruction */
+ TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
@@ -1304,8 +1313,8 @@ AssembleOneLine(
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
- operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
@@ -1377,7 +1386,7 @@ AssembleOneLine(
if (opnd < 0 || opnd > 3) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be [0..3]", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (void *)NULL);
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
@@ -1397,6 +1406,7 @@ AssembleOneLine(
break;
case ASSEM_DICT_GET:
+ case ASSEM_DICT_GET_DEF:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
@@ -1470,8 +1480,8 @@ AssembleOneLine(
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
- operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
- litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
+ operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
@@ -1565,7 +1575,7 @@ AssembleOneLine(
* Add the (label_name, address) pair to the hash table.
*/
- if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
@@ -1617,7 +1627,7 @@ AssembleOneLine(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be >=2", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (void *)NULL);
}
goto cleanup;
}
@@ -1742,7 +1752,7 @@ AssembleOneLine(
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
- Tcl_GetString(instNameObj));
+ TclGetString(instNameObj));
}
status = TCL_OK;
@@ -1975,7 +1985,7 @@ CreateMirrorJumpTable(
* table. */
int i;
- if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
+ if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) {
return TCL_ERROR;
}
if (objc % 2 != 0) {
@@ -1983,10 +1993,13 @@ CreateMirrorJumpTable(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"jump table must have an even number of list elements",
-1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (void *)NULL);
}
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Allocate the jumptable.
@@ -2002,16 +2015,16 @@ CreateMirrorJumpTable(
DEBUG_PRINT("jump table {\n");
for (i = 0; i < objc; i+=2) {
- DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
- Tcl_GetString(objv[i+1]));
- hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
+ DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]),
+ TclGetString(objv[i+1]));
+ hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
- Tcl_GetString(objv[i])));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", NULL);
+ TclGetString(objv[i])));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (void *)NULL);
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
}
@@ -2096,7 +2109,7 @@ GetNextOperand(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"assembly code may not contain substitutions", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", (void *)NULL);
}
return TCL_ERROR;
}
@@ -2259,7 +2272,7 @@ GetListIndexOperand(
* when list size limits grow.
*/
status = TclIndexEncode(interp, value,
- TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);
+ TCL_INDEX_NONE,TCL_INDEX_NONE, result);
Tcl_DecrRefCount(value);
*tokenPtrPtr = TokenAfter(tokenPtr);
@@ -2307,7 +2320,7 @@ FindLocalVar(
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return -1;
}
- varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
+ varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return -1;
@@ -2319,7 +2332,7 @@ FindLocalVar(
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);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (void *)NULL);
}
return -1;
}
@@ -2354,7 +2367,7 @@ CheckNamespaceQualifiers(
if ((*p == ':') && (p[1] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable \"%s\" is not local", name));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, (void *)NULL);
return TCL_ERROR;
}
}
@@ -2390,7 +2403,7 @@ CheckOneByte(
if (value < 0 || value > 0xFF) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2425,7 +2438,7 @@ CheckSignedOneByte(
if (value > 0x7F || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2458,7 +2471,7 @@ CheckNonNegative(
if (value < 0) {
result = Tcl_NewStringObj("operand must be nonnegative", -1);
Tcl_SetObjResult(interp, result);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2491,7 +2504,7 @@ CheckStrictlyPositive(
if (value <= 0) {
result = Tcl_NewStringObj("operand must be positive", -1);
Tcl_SetObjResult(interp, result);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2543,7 +2556,7 @@ DefineLabel(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate definition of label \"%s\"", labelName));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -2820,7 +2833,7 @@ CalculateJumpRelocations(
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
@@ -2901,10 +2914,10 @@ CheckJumpTableLabels(
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), (valEntryPtr != NULL));
+ TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
@@ -2942,9 +2955,9 @@ ReportUndefinedLabel(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "undefined label \"%s\"", Tcl_GetString(jumpTarget)));
+ "undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
- Tcl_GetString(jumpTarget), NULL);
+ TclGetString(jumpTarget), (void *)NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
@@ -3027,7 +3040,7 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
@@ -3099,17 +3112,17 @@ ResolveJumpTableTargets(
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
- DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+ DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), jumpTargetBBPtr,
+ TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
@@ -3229,7 +3242,7 @@ CheckNonThrowingBlock(
"a context where an exception has been "
"caught and not disposed of.",
tclInstructionTable[opcode].name));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", (void *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
}
return TCL_ERROR;
@@ -3409,7 +3422,7 @@ StackCheckBasicBlock(
*/
Tcl_SetErrorLine(interp, blockPtr->startLine);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3432,7 +3445,7 @@ StackCheckBasicBlock(
if (initialStackDepth + blockPtr->minStackDepth < 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
@@ -3451,7 +3464,7 @@ StackCheckBasicBlock(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"code pops stack below level of enclosing catch", -1));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", (void *)NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
@@ -3481,7 +3494,7 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(blockPtr->jumpTarget));
+ TclGetString(blockPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
@@ -3498,7 +3511,7 @@ StackCheckBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
@@ -3560,7 +3573,7 @@ StackCheckExit(
* Emit a 'push' of the empty literal.
*/
- litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+ litIndex = TclRegisterLiteral(envPtr, "", 0, 0);
/*
* Assumes that 'push' is at slot 0 in TalInstructionTable.
@@ -3579,7 +3592,7 @@ StackCheckExit(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"stack is unbalanced on exit from the code (depth=%d)",
depth));
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3724,7 +3737,7 @@ ProcessCatchesInBasicBlock(
"execution reaches an instruction in inconsistent "
"exception contexts", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3783,7 +3796,7 @@ ProcessCatchesInBasicBlock(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"endCatch without a corresponding beginCatch", -1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3803,7 +3816,7 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3819,7 +3832,7 @@ ProcessCatchesInBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3859,7 +3872,7 @@ CheckForUnclosedCatches(
"catch still active on exit from assembly code", -1));
Tcl_SetErrorLine(interp,
assemEnvPtr->curr_bb->enclosingCatch->startLine);
- Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", (void *)NULL);
}
return TCL_ERROR;
}
@@ -4123,7 +4136,7 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(block->jumpTarget));
+ TclGetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
@@ -4265,7 +4278,7 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
- Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
+ TclSetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
@@ -4302,12 +4315,9 @@ AddBasicBlockRangeToErrorInfo(
static void
DupAssembleCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
- (void)srcPtr;
- (void)copyPtr;
-
return;
}
@@ -4333,12 +4343,12 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
- objPtr->typePtr = NULL;
+ ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
/*
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index d1871f9..9ce2c88 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -5,8 +5,8 @@
* in a safe way. The code here doesn't actually handle signals, though.
* This code is based on proposals made by Mark Diekhans and Don Libes.
*
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
+ * Copyright © 1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -25,9 +25,9 @@ typedef struct AsyncHandler {
int ready; /* Non-zero means this handler should be
* invoked in the next call to
* Tcl_AsyncInvoke. */
- struct AsyncHandler *nextPtr;
- /* Next in list of all handlers for the
- * process. */
+ struct AsyncHandler *nextPtr, *prevPtr;
+ /* Next, previous in list of all handlers
+ * for the process. */
Tcl_AsyncProc *proc; /* Procedure to call when handler is
* invoked. */
ClientData clientData; /* Value to pass to handler when it is
@@ -38,16 +38,10 @@ typedef struct AsyncHandler {
* associated to. */
Tcl_ThreadId originThrdId; /* Origin thread where this token was created
* and where it will be yielded. */
+ ClientData notifierData; /* Platform notifier data or NULL. */
} AsyncHandler;
typedef struct ThreadSpecificData {
- /*
- * The variables below maintain a list of all existing handlers specific
- * to the calling thread.
- */
- AsyncHandler *firstHandler; /* First handler defined for process, or NULL
- * if none. */
- AsyncHandler *lastHandler; /* Last handler or NULL. */
int asyncReady; /* This is set to 1 whenever a handler becomes
* ready and it is cleared to zero whenever
* Tcl_AsyncInvoke is called. It can be
@@ -58,24 +52,29 @@ typedef struct ThreadSpecificData {
* currently working. If so then we won't set
* asyncReady again until Tcl_AsyncInvoke
* returns. */
- Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list
- * lock */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+
+/* Mutex to protect linked-list of AsyncHandlers in the process. */
+TCL_DECLARE_MUTEX(asyncMutex)
+
+/* List of all existing handlers of the process. */
+static AsyncHandler *firstHandler = NULL;
+static AsyncHandler *lastHandler = NULL;
/*
*----------------------------------------------------------------------
*
* TclFinalizeAsync --
*
- * Finalizes the mutex in the thread local data structure for the async
+ * Finalizes the thread local data structure for the async
* subsystem.
*
* Results:
* None.
*
* Side effects:
- * Forgets knowledge of the mutex should it have been created.
+ * Cleans up left-over async handlers for the calling thread.
*
*----------------------------------------------------------------------
*/
@@ -83,10 +82,40 @@ static Tcl_ThreadDataKey dataKey;
void
TclFinalizeAsync(void)
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ AsyncHandler *token, *toDelete = NULL;
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
+
+ Tcl_MutexLock(&asyncMutex);
+ for (token = firstHandler; token != NULL;) {
+ AsyncHandler *nextToken = token->nextPtr;
- if (tsdPtr->asyncMutex != NULL) {
- Tcl_MutexFinalize(&tsdPtr->asyncMutex);
+ if (token->originThrdId == self) {
+ if (token->prevPtr == NULL) {
+ firstHandler = token->nextPtr;
+ if (firstHandler == NULL) {
+ lastHandler = NULL;
+ break;
+ }
+ } else {
+ token->prevPtr->nextPtr = token->nextPtr;
+ if (token == lastHandler) {
+ lastHandler = token->prevPtr;
+ }
+ }
+ if (token->nextPtr != NULL) {
+ token->nextPtr->prevPtr = token->prevPtr;
+ }
+ token->nextPtr = toDelete;
+ token->prevPtr = NULL;
+ toDelete = token;
+ }
+ token = nextToken;
+ }
+ Tcl_MutexUnlock(&asyncMutex);
+ while (toDelete != NULL) {
+ token = toDelete;
+ toDelete = toDelete->nextPtr;
+ ckfree(token);
}
}
@@ -118,22 +147,25 @@ Tcl_AsyncCreate(
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- asyncPtr = (AsyncHandler *)ckalloc(sizeof(AsyncHandler));
+ asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
+ asyncPtr->prevPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
+ asyncPtr->notifierData = TclpNotifierData();
- Tcl_MutexLock(&tsdPtr->asyncMutex);
- if (tsdPtr->firstHandler == NULL) {
- tsdPtr->firstHandler = asyncPtr;
+ Tcl_MutexLock(&asyncMutex);
+ if (firstHandler == NULL) {
+ firstHandler = asyncPtr;
} else {
- tsdPtr->lastHandler->nextPtr = asyncPtr;
+ asyncPtr->prevPtr = lastHandler;
+ lastHandler->nextPtr = asyncPtr;
}
- tsdPtr->lastHandler = asyncPtr;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ lastHandler = asyncPtr;
+ Tcl_MutexUnlock(&asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
@@ -162,13 +194,86 @@ Tcl_AsyncMark(
{
AsyncHandler *token = (AsyncHandler *) async;
- Tcl_MutexLock(&token->originTsd->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
token->ready = 1;
if (!token->originTsd->asyncActive) {
token->originTsd->asyncReady = 1;
Tcl_ThreadAlert(token->originThrdId);
}
- Tcl_MutexUnlock(&token->originTsd->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncMarkFromSignal --
+ *
+ * This procedure is similar to Tcl_AsyncMark but must be used
+ * in POSIX signal contexts. In addition to Tcl_AsyncMark the
+ * signal number is passed.
+ *
+ * Results:
+ * True, when the handler will be marked, false otherwise.
+ *
+ * Side effects:
+ * The handler gets marked for invocation later.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AsyncMarkFromSignal(
+ Tcl_AsyncHandler async, /* Token for handler. */
+ int sigNumber) /* Signal number. */
+{
+#if TCL_THREADS
+ AsyncHandler *token = (AsyncHandler *) async;
+
+ return TclAsyncNotifier(sigNumber, token->originThrdId,
+ token->notifierData, &token->ready, -1);
+#else
+ (void)sigNumber;
+
+ Tcl_AsyncMark(async);
+ return 1;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclAsyncMarkFromNotifier --
+ *
+ * This procedure is called from the notifier thread and
+ * invokes Tcl_AsyncMark for specifically marked handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Handlers get marked for invocation later.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclAsyncMarkFromNotifier(void)
+{
+ AsyncHandler *token;
+
+ Tcl_MutexLock(&asyncMutex);
+ for (token = firstHandler; token != NULL;
+ token = token->nextPtr) {
+ if (token->ready == -1) {
+ token->ready = 1;
+ if (!token->originTsd->asyncActive) {
+ token->originTsd->asyncReady = 1;
+ Tcl_ThreadAlert(token->originThrdId);
+ }
+ }
+ }
+ Tcl_MutexUnlock(&asyncMutex);
}
/*
@@ -200,11 +305,12 @@ Tcl_AsyncInvoke(
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
- Tcl_MutexLock(&tsdPtr->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
if (tsdPtr->asyncReady == 0) {
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
tsdPtr->asyncReady = 0;
@@ -224,8 +330,11 @@ Tcl_AsyncInvoke(
*/
while (1) {
- for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->originThrdId != self) {
+ continue;
+ }
if (asyncPtr->ready) {
break;
}
@@ -234,12 +343,12 @@ Tcl_AsyncInvoke(
break;
}
asyncPtr->ready = 0;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
code = asyncPtr->proc(asyncPtr->clientData, interp, code);
- Tcl_MutexLock(&tsdPtr->asyncMutex);
+ Tcl_MutexLock(&asyncMutex);
}
tsdPtr->asyncActive = 0;
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
@@ -271,9 +380,7 @@ void
Tcl_AsyncDelete(
Tcl_AsyncHandler async) /* Token for handler to delete. */
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
- AsyncHandler *prevPtr, *thisPtr;
/*
* Assure early handling of the constraint
@@ -283,33 +390,22 @@ Tcl_AsyncDelete(
Tcl_Panic("Tcl_AsyncDelete: async handler deleted by the wrong thread");
}
- /*
- * If we come to this point when TSD's for the current
- * thread have already been garbage-collected, we are
- * in the _serious_ trouble. OTOH, we tolerate calling
- * with already cleaned-up handler list (should we?).
- */
-
- Tcl_MutexLock(&tsdPtr->asyncMutex);
- if (tsdPtr->firstHandler != NULL) {
- prevPtr = thisPtr = tsdPtr->firstHandler;
- while (thisPtr != NULL && thisPtr != asyncPtr) {
- prevPtr = thisPtr;
- thisPtr = thisPtr->nextPtr;
- }
- if (thisPtr == NULL) {
- Tcl_Panic("Tcl_AsyncDelete: cannot find async handler");
+ Tcl_MutexLock(&asyncMutex);
+ if (asyncPtr->prevPtr == NULL) {
+ firstHandler = asyncPtr->nextPtr;
+ if (firstHandler == NULL) {
+ lastHandler = NULL;
}
- if (asyncPtr == tsdPtr->firstHandler) {
- tsdPtr->firstHandler = asyncPtr->nextPtr;
- } else {
- prevPtr->nextPtr = asyncPtr->nextPtr;
- }
- if (asyncPtr == tsdPtr->lastHandler) {
- tsdPtr->lastHandler = prevPtr;
+ } else {
+ asyncPtr->prevPtr->nextPtr = asyncPtr->nextPtr;
+ if (asyncPtr == lastHandler) {
+ lastHandler = asyncPtr->prevPtr;
}
}
- Tcl_MutexUnlock(&tsdPtr->asyncMutex);
+ if (asyncPtr->nextPtr != NULL) {
+ asyncPtr->nextPtr->prevPtr = asyncPtr->prevPtr;
+ }
+ Tcl_MutexUnlock(&asyncMutex);
ckfree(asyncPtr);
}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 8dde621..b01717e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -5,13 +5,13 @@
* including interpreter creation and deletion, command creation and
* deletion, and command/script execution.
*
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
- * Copyright (c) 2001, 2002 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
- * Copyright (c) 2006-2008 Joe Mistachkin. All rights reserved.
- * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
+ * Copyright © 1987-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
+ * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -20,10 +20,50 @@
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
-
+
+/*
+ * TCL_FPCLASSIFY_MODE:
+ * 0 - fpclassify
+ * 1 - _fpclass
+ * 2 - simulate
+ * 3 - __builtin_fpclassify
+ */
+
+#ifndef TCL_FPCLASSIFY_MODE
+#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */
+/*
+ * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify,
+ * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a
+ * version using a compiler built-in.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#elif defined(fpclassify) /* fpclassify */
+/*
+ * This is the C99 standard.
+ */
+#include <float.h>
+#define TCL_FPCLASSIFY_MODE 0
+#elif defined(_FPCLASS_NN) /* _fpclass */
+/*
+ * This case handles newer MSVC on Windows, which doesn't have the standard
+ * operation but does have something that can tell us the same thing.
+ */
+#define TCL_FPCLASSIFY_MODE 1
+#else /* !fpclassify && !_fpclass (older MSVC), simulate */
+/*
+ * Older MSVC on Windows. So broken that we just have to do it our way. This
+ * assumes that we're on x86 (or at least a system with classic little-endian
+ * double layout and a 32-bit 'int' type).
+ */
+#define TCL_FPCLASSIFY_MODE 2
+#endif /* !fpclassify */
+/* actually there is no fallback to builtin fpclassify */
+#endif /* !TCL_FPCLASSIFY_MODE */
+
+
/*
* Bug 7371b6270b: to check C call stack depth, prefer an approach which is
* compatible with AddressSanitizer (ASan) use-after-return detection.
@@ -49,12 +89,12 @@ TclGetCStackPtr(void)
#elif defined(_MSC_VER) && defined(HAVE_INTRIN_H)
return _AddressOfReturnAddress();
#else
- size_t unused = 0;
+ ptrdiff_t unused = 0;
/*
* LLVM recommends using volatile:
* https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31
*/
- size_t *volatile stackLevel = &unused;
+ ptrdiff_t *volatile stackLevel = &unused;
return (void *)stackLevel;
#endif
}
@@ -81,7 +121,7 @@ typedef struct OldMathFuncData {
Tcl_MathProc *proc; /* Handler function */
int numArgs; /* Number of args expected */
Tcl_ValueType *argTypes; /* Types of the args */
- ClientData clientData; /* Client data for the handler function */
+ void *clientData; /* Client data for the handler function */
} OldMathFuncData;
/*
@@ -100,8 +140,8 @@ typedef struct {
* cancellation. */
char *result; /* The script cancellation result or NULL for
* a default result. */
- int length; /* Length of the above error message. */
- ClientData clientData; /* Ignored */
+ Tcl_Size length; /* Length of the above error message. */
+ void *clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
@@ -109,6 +149,17 @@ static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);
/*
+ * Table used to map command implementation functions to a human-readable type
+ * name, for [info type]. The keys in the table are function addresses, and
+ * the values in the table are static char* containing strings in Tcl's
+ * internal encoding (almost UTF-8).
+ */
+
+static Tcl_HashTable commandTypeTable;
+static int commandTypeInit = 0;
+TCL_DECLARE_MUTEX(commandTypeLock);
+
+/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
* are used to save the evaluation state between NR calls to each coro.
*/
@@ -129,15 +180,16 @@ TCL_DECLARE_MUTEX(cancelLock);
* Static functions in this file:
*/
+static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
-static int CancelEvalProc(ClientData clientData,
+static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
-static void DeleteCoroutine(ClientData clientData);
+static void DeleteCoroutine(void *clientData);
static Tcl_FreeProc DeleteInterpProc;
-static void DeleteOpCmdClientData(ClientData clientData);
+static void DeleteOpCmdClientData(void *clientData);
#ifdef USE_DTRACE
static Tcl_ObjCmdProc DTraceObjCmd;
static Tcl_NRPostProc DTraceCmdReturn;
@@ -149,36 +201,46 @@ static Tcl_ObjCmdProc ExprBinaryFunc;
static Tcl_ObjCmdProc ExprBoolFunc;
static Tcl_ObjCmdProc ExprCeilFunc;
static Tcl_ObjCmdProc ExprDoubleFunc;
-static Tcl_ObjCmdProc ExprEntierFunc;
static Tcl_ObjCmdProc ExprFloorFunc;
static Tcl_ObjCmdProc ExprIntFunc;
static Tcl_ObjCmdProc ExprIsqrtFunc;
+static Tcl_ObjCmdProc ExprIsFiniteFunc;
+static Tcl_ObjCmdProc ExprIsInfinityFunc;
+static Tcl_ObjCmdProc ExprIsNaNFunc;
+static Tcl_ObjCmdProc ExprIsNormalFunc;
+static Tcl_ObjCmdProc ExprIsSubnormalFunc;
+static Tcl_ObjCmdProc ExprIsUnorderedFunc;
+static Tcl_ObjCmdProc ExprMaxFunc;
+static Tcl_ObjCmdProc ExprMinFunc;
static Tcl_ObjCmdProc ExprRandFunc;
static Tcl_ObjCmdProc ExprRoundFunc;
static Tcl_ObjCmdProc ExprSqrtFunc;
static Tcl_ObjCmdProc ExprSrandFunc;
static Tcl_ObjCmdProc ExprUnaryFunc;
static Tcl_ObjCmdProc ExprWideFunc;
+static Tcl_ObjCmdProc FloatClassifyObjCmd;
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
+#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
-static void OldMathFuncDeleteProc(ClientData clientData);
+static void OldMathFuncDeleteProc(void *clientData);
+#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
static void TEOV_PushExceptionHandlers(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[], int flags);
+ Tcl_Size objc, Tcl_Obj *const objv[], int flags);
static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp,
Tcl_Obj *namePtr, Namespace *lookupNsPtr);
-static int TEOV_NotFound(Tcl_Interp *interp, int objc,
+static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
- Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
+ Command **cmdPtrPtr, Tcl_Obj *commandPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
@@ -191,9 +253,13 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc EvalObjvCore;
static Tcl_NRPostProc Dispatch;
-static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_ObjCmdProc NRInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
+static Tcl_ObjCmdProc TclNRCoroInjectObjCmd;
+static Tcl_ObjCmdProc TclNRCoroProbeObjCmd;
+static Tcl_NRPostProc InjectHandler;
+static Tcl_NRPostProc InjectHandlerPostCall;
MODULE_SCOPE const TclStubs tclStubs;
@@ -202,8 +268,8 @@ MODULE_SCOPE const TclStubs tclStubs;
* after particular kinds of [yield].
*/
-#define CORO_ACTIVATE_YIELD PTR2INT(NULL)
-#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1
+#define CORO_ACTIVATE_YIELD NULL
+#define CORO_ACTIVATE_YIELDM INT2PTR(1)
#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1)
#define COROUTINE_ARGUMENTS_ARBITRARY (-2)
@@ -228,6 +294,24 @@ typedef struct {
* it for it. Defined in tclInt.h. */
/*
+ * The following struct states that the command it talks about (a subcommand
+ * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an
+ * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these
+ * structs.) Alas, we can't sensibly just store the information directly in
+ * the commands.
+ */
+
+typedef struct {
+ const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for
+ * the end of the list of commands to hide. */
+ const char *commandName; /* The name of the command within the
+ * ensemble. If this is NULL, we want to also
+ * make the overall command be hidden, an ugly
+ * hack because it is expected by security
+ * policies in the wild. */
+} UnsafeEnsembleInfo;
+
+/*
* The built-in commands, and the functions that implement them:
*/
@@ -239,12 +323,14 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef EXCLUDE_OBSOLETE_COMMANDS
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
{"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
+ {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE},
+ {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
{"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE},
@@ -252,22 +338,27 @@ static const CmdInfo builtInCmds[] = {
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE},
{"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE},
+ {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE},
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE},
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE},
{"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
+ {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
{"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
+ {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE},
{"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},
+ {"lseq", Tcl_LseqObjCmd, 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},
@@ -321,9 +412,7 @@ static const CmdInfo builtInCmds[] = {
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
-#ifdef TCL_TIMERATE
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
-#endif
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -331,6 +420,69 @@ static const CmdInfo builtInCmds[] = {
};
/*
+ * Information about which pieces of ensembles to hide when making an
+ * interpreter safe:
+ */
+
+static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = {
+ /* [encoding] has two unsafe commands. Assumed by older security policies
+ * to be overall unsafe; it isn't but... */
+ {"encoding", NULL},
+ {"encoding", "dirs"},
+ {"encoding", "system"},
+ /* [file] has MANY unsafe commands! Assumed by older security policies to
+ * be overall unsafe; it isn't but... */
+ {"file", NULL},
+ {"file", "atime"},
+ {"file", "attributes"},
+ {"file", "copy"},
+ {"file", "delete"},
+ {"file", "dirname"},
+ {"file", "executable"},
+ {"file", "exists"},
+ {"file", "extension"},
+ {"file", "isdirectory"},
+ {"file", "isfile"},
+ {"file", "link"},
+ {"file", "lstat"},
+ {"file", "mtime"},
+ {"file", "mkdir"},
+ {"file", "nativename"},
+ {"file", "normalize"},
+ {"file", "owned"},
+ {"file", "readable"},
+ {"file", "readlink"},
+ {"file", "rename"},
+ {"file", "rootname"},
+ {"file", "size"},
+ {"file", "stat"},
+ {"file", "tail"},
+ {"file", "tempdir"},
+ {"file", "tempfile"},
+ {"file", "type"},
+ {"file", "volumes"},
+ {"file", "writable"},
+ /* [info] has two unsafe commands */
+ {"info", "cmdtype"},
+ {"info", "nameofexecutable"},
+ /* [tcl::process] has ONLY unsafe commands! */
+ {"process", "list"},
+ {"process", "status"},
+ {"process", "purge"},
+ {"process", "autopurge"},
+ /* [zipfs] has MANY unsafe commands! */
+ {"zipfs", "lmkimg"},
+ {"zipfs", "lmkzip"},
+ {"zipfs", "mkimg"},
+ {"zipfs", "mkkey"},
+ {"zipfs", "mkzip"},
+ {"zipfs", "mount"},
+ {"zipfs", "mount_data"},
+ {"zipfs", "unmount"},
+ {NULL, NULL}
+};
+
+/*
* Math functions. All are safe.
*/
@@ -338,37 +490,45 @@ typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
- ClientData clientData; /* Client data for the function */
+ double (*fn)(double x); /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
- { "acos", ExprUnaryFunc, (ClientData) acos },
- { "asin", ExprUnaryFunc, (ClientData) asin },
- { "atan", ExprUnaryFunc, (ClientData) atan },
- { "atan2", ExprBinaryFunc, (ClientData) atan2 },
+ { "acos", ExprUnaryFunc, acos },
+ { "asin", ExprUnaryFunc, asin },
+ { "atan", ExprUnaryFunc, atan },
+ { "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) atan2},
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
- { "cos", ExprUnaryFunc, (ClientData) cos },
- { "cosh", ExprUnaryFunc, (ClientData) cosh },
+ { "cos", ExprUnaryFunc, cos },
+ { "cosh", ExprUnaryFunc, cosh },
{ "double", ExprDoubleFunc, NULL },
- { "entier", ExprEntierFunc, NULL },
- { "exp", ExprUnaryFunc, (ClientData) exp },
+ { "entier", ExprIntFunc, NULL },
+ { "exp", ExprUnaryFunc, exp },
{ "floor", ExprFloorFunc, NULL },
- { "fmod", ExprBinaryFunc, (ClientData) fmod },
- { "hypot", ExprBinaryFunc, (ClientData) hypot },
+ { "fmod", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) fmod},
+ { "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) hypot},
{ "int", ExprIntFunc, NULL },
+ { "isfinite", ExprIsFiniteFunc, NULL },
+ { "isinf", ExprIsInfinityFunc, NULL },
+ { "isnan", ExprIsNaNFunc, NULL },
+ { "isnormal", ExprIsNormalFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
- { "log", ExprUnaryFunc, (ClientData) log },
- { "log10", ExprUnaryFunc, (ClientData) log10 },
- { "pow", ExprBinaryFunc, (ClientData) pow },
+ { "issubnormal", ExprIsSubnormalFunc, NULL, },
+ { "isunordered", ExprIsUnorderedFunc, NULL, },
+ { "log", ExprUnaryFunc, log },
+ { "log10", ExprUnaryFunc, log10 },
+ { "max", ExprMaxFunc, NULL },
+ { "min", ExprMinFunc, NULL },
+ { "pow", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) pow},
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
- { "sin", ExprUnaryFunc, (ClientData) sin },
- { "sinh", ExprUnaryFunc, (ClientData) sinh },
+ { "sin", ExprUnaryFunc, sin },
+ { "sinh", ExprUnaryFunc, sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
- { "tan", ExprUnaryFunc, (ClientData) tan },
- { "tanh", ExprUnaryFunc, (ClientData) tanh },
+ { "tan", ExprUnaryFunc, tan },
+ { "tanh", ExprUnaryFunc, tanh },
{ "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
@@ -435,6 +595,14 @@ static const OpCmdInfo mathOpCmds[] = {
/* unused */ {0}, NULL},
{ "eq", TclSortingOpCmd, TclCompileStreqOpCmd,
/* unused */ {0}, NULL},
+ { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd,
+ /* unused */ {0}, NULL},
+ { "le", TclSortingOpCmd, TclCompileStrLeOpCmd,
+ /* unused */ {0}, NULL},
+ { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd,
+ /* unused */ {0}, NULL},
+ { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd,
+ /* unused */ {0}, NULL},
{ NULL, NULL, NULL,
{0}, NULL}
};
@@ -464,11 +632,120 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
*----------------------------------------------------------------------
*
+ * buildInfoObjCmd --
+ *
+ * Implements tcl::build-info command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+buildInfoObjCmd(
+ void *clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?option?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ Tcl_Size len;
+ const char *arg = TclGetStringFromObj(objv[1], &len);
+ if (len == 7 && !strcmp(arg, "version")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '.');
+ if (p) {
+ const char *q = strchr(p+1, '.');
+ const char *r = strchr(p+1, '+');
+ p = (q < r) ? q : r;
+ }
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, (void *)NULL);
+ }
+ return TCL_OK;
+ } else if (len == 10 && !strcmp(arg, "patchlevel")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '+');
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, (void *)NULL);
+ }
+ return TCL_OK;
+ } else if (len == 6 && !strcmp(arg, "commit")) {
+ const char *q, *p = strchr((char *)clientData, '+');
+ if (p) {
+ if ((q = strchr(p, '.'))) {
+ char buf[80];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, (void *)NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, (void *)NULL);
+ }
+ }
+ return TCL_OK;
+ } else if (len == 8 && !strcmp(arg, "compiler")) {
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4)
+ || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) {
+ const char *q = strchr(p+1, '.');
+ if (q) {
+ char buf[16];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, (void *)NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, (void *)NULL);
+ }
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", (void *)NULL);
+ return TCL_OK;
+ }
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) {
+ Tcl_AppendResult(interp, "1", (void *)NULL);
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", (void *)NULL);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, (char *)clientData, (void *)NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -506,7 +783,7 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
- const char *version = TclInitSubsystems();
+ const char *version = Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -524,8 +801,8 @@ Tcl_CreateInterp(void)
* the same way. Therefore, this is not officially supported.
* In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
*/
- if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
- || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
+ if ((offsetof(Tcl_StatBuf,st_atime) != 32)
+ || (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
@@ -540,6 +817,20 @@ Tcl_CreateInterp(void)
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");
+ TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
+ TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
+ TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass");
+ TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -549,9 +840,14 @@ Tcl_CreateInterp(void)
iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
+#ifdef TCL_NO_DEPRECATED
+ iPtr->result = &tclEmptyString;
+#else
iPtr->result = iPtr->resultSpace;
+#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
+ iPtr->stubTable = &tclStubs;
TclNewObj(iPtr->objResultPtr);
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->handle = TclHandleCreate(iPtr);
@@ -609,9 +905,11 @@ Tcl_CreateInterp(void)
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
+#ifndef TCL_NO_DEPRECATED
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
+#endif
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
@@ -621,15 +919,16 @@ Tcl_CreateInterp(void)
#endif
/* TIP #268 */
+#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
iPtr->packagePrefer = PKG_PREFER_STABLE;
- } else {
+ } else
+#endif
iPtr->packagePrefer = PKG_PREFER_LATEST;
- }
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
- iPtr->compileEpoch = 0;
+ iPtr->compileEpoch = 1;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
@@ -644,7 +943,9 @@ Tcl_CreateInterp(void)
TclNewObj(iPtr->emptyObjPtr);
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
+#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
+#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
@@ -755,12 +1056,6 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
/*
- * Initialise the stub table pointer.
- */
-
- iPtr->stubTable = &tclStubs;
-
- /*
* Initialize the ensemble error message rewriting support.
*/
@@ -777,7 +1072,7 @@ Tcl_CreateInterp(void)
* cache was already initialised by the call to alloc the interp struct.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
@@ -787,14 +1082,9 @@ Tcl_CreateInterp(void)
iPtr->deferredCallbacks = NULL;
/*
- * Create the core commands. Do it here, rather than calling
- * Tcl_CreateCommand, because it's faster (there's no need to check for a
- * preexisting command by the same name). If a command has a Tcl_CmdProc
- * but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
- * TclInvokeStringCommand. This is an object-based wrapper function that
- * extracts strings, calls the string function, and creates an object for
- * the result. Similarly, if a command has a Tcl_ObjCmdProc but no
- * Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
+ * Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand,
+ * because it's faster (there's no need to check for a preexisting command
+ * by the same name). Set the Tcl_CmdProc to TclInvokeObjectCommand.
*/
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
@@ -847,6 +1137,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -887,14 +1178,10 @@ Tcl_CreateInterp(void)
/* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
- NRCoroInjectObjCmd, NULL, NULL);
+ NRInjectObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
CoroTypeObjCmd, NULL, NULL);
- /* Create an unsupported command for timerate */
- Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate",
- Tcl_TimeRateObjCmd, NULL, NULL);
-
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
@@ -924,7 +1211,7 @@ Tcl_CreateInterp(void)
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
- builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
+ builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
@@ -986,24 +1273,26 @@ Tcl_CreateInterp(void)
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
- Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY);
/* TIP #291 */
Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize",
- Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY);
/*
* Set up other variables such as tcl_version and tcl_library
*/
- Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
+#endif /* !TCL_NO_DEPRECATED */
TclpSetVariables(interp);
-#ifdef TCL_THREADS
+#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
@@ -1017,16 +1306,20 @@ Tcl_CreateInterp(void)
/*
* 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", version, &tclStubs);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_CreateObjCommand(interp, "::tcl::build-info",
+ buildInfoObjCmd, (void *)version, NULL);
if (TclTommath_Init(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
if (TclOOInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
/*
@@ -1036,7 +1329,10 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", Tcl_GetStringResult(interp));
+ }
+ if (TclZipfs_Init(interp) != TCL_OK) {
+ Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
#endif
@@ -1046,7 +1342,7 @@ Tcl_CreateInterp(void)
static void
DeleteOpCmdClientData(
- ClientData clientData)
+ void *clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
@@ -1054,6 +1350,71 @@ DeleteOpCmdClientData(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclRegisterCommandTypeName, TclGetCommandTypeName --
+ *
+ * Command type registration and lookup mechanism. Everything is keyed by
+ * the Tcl_ObjCmdProc for the command, and that is used as the *key* into
+ * the hash table that maps to constant strings that are names. (It is
+ * recommended that those names be ASCII.)
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr)
+{
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit == 0) {
+ 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);
+}
+
+const char *
+TclGetCommandTypeName(
+ Tcl_Command command)
+{
+ Command *cmdPtr = (Command *) command;
+ Tcl_ObjCmdProc *procPtr = cmdPtr->objProc;
+ const char *name = "native";
+
+ if (procPtr == NULL) {
+ procPtr = cmdPtr->nreProc;
+ }
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
+
+ if (hPtr && Tcl_GetHashValue(hPtr)) {
+ name = (const char *) Tcl_GetHashValue(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+
+ return name;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
@@ -1074,6 +1435,7 @@ TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
+ const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
@@ -1083,12 +1445,83 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
- TclMakeEncodingCommandSafe(interp); /* Ugh! */
- TclMakeFileCommandSafe(interp); /* Ugh! */
+
+ for (unsafePtr = unsafeEnsembleCommands;
+ unsafePtr->ensembleNsName; unsafePtr++) {
+ if (unsafePtr->commandName) {
+ /*
+ * Hide an ensemble subcommand.
+ */
+
+ Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+ Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName);
+
+ if (TclRenameCommand(interp, TclGetString(cmdName),
+ "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp",
+ TclGetString(hideName)) != TCL_OK) {
+ Tcl_Panic("problem making '%s %s' safe: %s",
+ unsafePtr->ensembleNsName, unsafePtr->commandName,
+ Tcl_GetStringResult(interp));
+ }
+ Tcl_CreateObjCommand(interp, TclGetString(cmdName),
+ BadEnsembleSubcommand, (void *)unsafePtr, NULL);
+ TclDecrRefCount(cmdName);
+ TclDecrRefCount(hideName);
+ } else {
+ /*
+ * Hide an ensemble main command (for compatibility).
+ */
+
+ if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
+ unsafePtr->ensembleNsName) != TCL_OK) {
+ Tcl_Panic("problem making '%s' safe: %s",
+ unsafePtr->ensembleNsName,
+ Tcl_GetStringResult(interp));
+ }
+ }
+ }
+
return TCL_OK;
}
/*
+ *----------------------------------------------------------------------
+ *
+ * BadEnsembleSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * ensembles are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is description of what was hidden.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadEnsembleSubcommand(
+ void *clientData,
+ Tcl_Interp *interp,
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /* objv */)
+{
+ const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of %s",
+ infoPtr->commandName, infoPtr->ensembleNsName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", (void *)NULL);
+ return TCL_ERROR;
+}
+
+/*
*--------------------------------------------------------------
*
* Tcl_CallWhenDeleted --
@@ -1114,7 +1547,7 @@ Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
@@ -1162,7 +1595,7 @@ Tcl_DontCallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTablePtr;
@@ -1210,7 +1643,7 @@ Tcl_SetAssocData(
const char *name, /* Name for association. */
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
* be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
@@ -1292,7 +1725,7 @@ Tcl_DeleteAssocData(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetAssocData(
Tcl_Interp *interp, /* Interpreter associated with. */
const char *name, /* Name of association. */
@@ -1426,7 +1859,7 @@ DeleteInterpProc(
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
ResolverScheme *resPtr, *nextResPtr;
- int i;
+ Tcl_Size i;
/*
* Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
@@ -1461,7 +1894,7 @@ DeleteInterpProc(
*/
Tcl_MutexLock(&cancelLock);
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ hPtr = Tcl_FindHashEntry(&cancelTable, iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
@@ -1527,28 +1960,28 @@ DeleteInterpProc(
ckfree(hTablePtr);
}
- /*
- * Invoke deletion callbacks; note that a callback can create new
- * callbacks, so we iterate.
- */
- while (iPtr->assocData != NULL) {
+ if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
- iPtr->assocData = NULL;
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
+ Tcl_DeleteHashEntry(hPtr);
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
+ iPtr->assocData = NULL;
}
/*
@@ -1569,8 +2002,10 @@ DeleteInterpProc(
* could have transferred ownership of the result string to Tcl.
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_FreeResult(interp);
iPtr->result = NULL;
+#endif
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
Tcl_DecrRefCount(iPtr->ecVar);
@@ -1592,10 +2027,12 @@ DeleteInterpProc(
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
+#ifndef TCL_NO_DEPRECATED
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
+#endif
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
@@ -1662,7 +2099,7 @@ DeleteInterpProc(
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
- for (i=0; i< eclPtr->nuloc; i++) {
+ for (i=0; i<eclPtr->nuloc; i++) {
ckfree(eclPtr->loc[i].line);
}
@@ -1693,7 +2130,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -1785,8 +2222,8 @@ Tcl_HideCommand(
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot use namespace qualifiers in hidden command"
- " token (rename)", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", NULL);
+ " token (rename)", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (void *)NULL);
return TCL_ERROR;
}
@@ -1810,8 +2247,8 @@ Tcl_HideCommand(
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only hide global namespace commands (use rename then hide)",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", NULL);
+ TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (void *)NULL);
return TCL_ERROR;
}
@@ -1837,7 +2274,7 @@ Tcl_HideCommand(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"hidden command named \"%s\" already exists",
hiddenCmdToken));
- Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "HIDE", "ALREADY_HIDDEN", (void *)NULL);
return TCL_ERROR;
}
@@ -1940,8 +2377,8 @@ Tcl_ExposeCommand(
if (strstr(cmdName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot expose to a namespace (use expose to toplevel, then rename)",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", NULL);
+ TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (void *)NULL);
return TCL_ERROR;
}
@@ -1958,7 +2395,7 @@ Tcl_ExposeCommand(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
- hiddenCmdToken, NULL);
+ hiddenCmdToken, (void *)NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
@@ -1977,7 +2414,7 @@ Tcl_ExposeCommand(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"trying to expose a non-global command namespace command",
- -1));
+ TCL_INDEX_NONE));
return TCL_ERROR;
}
@@ -1996,7 +2433,7 @@ Tcl_ExposeCommand(
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"exposed command \"%s\" already exists", cmdName));
- Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", (void *)NULL);
return TCL_ERROR;
}
@@ -2093,7 +2530,7 @@ Tcl_CreateCommand(
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
- ClientData clientData, /* Arbitrary value passed to string proc. */
+ void *clientData, /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
@@ -2291,7 +2728,7 @@ Tcl_CreateObjCommand(
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
@@ -2341,7 +2778,7 @@ TclCreateObjCommandInNs(
Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
@@ -2484,7 +2921,10 @@ TclCreateObjCommandInNs(
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
+
dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
+ cmdPtr->refCount++;
+ TclCleanupCommandMacro(dataPtr->realCmdPtr);
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
@@ -2524,7 +2964,7 @@ TclCreateObjCommandInNs(
int
TclInvokeStringCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2535,7 +2975,7 @@ TclInvokeStringCommand(
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
+ argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
@@ -2572,7 +3012,7 @@ TclInvokeStringCommand(
int
TclInvokeObjectCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2673,7 +3113,7 @@ TclRenameCommand(
"can't %s \"%s\": command doesn't exist",
((newName == NULL)||(*newName == '\0'))? "delete":"rename",
oldName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, (void *)NULL);
return TCL_ERROR;
}
@@ -2695,7 +3135,7 @@ TclRenameCommand(
/*
* 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.
+ * create the containing namespaces just like Tcl_CreateObjCommand would.
*/
TclGetNamespaceForQualName(interp, newName, NULL,
@@ -2704,7 +3144,7 @@ TclRenameCommand(
if ((newNsPtr == NULL) || (newTail == NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": bad command name", newName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL);
result = TCL_ERROR;
goto done;
}
@@ -2712,7 +3152,7 @@ TclRenameCommand(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't rename to \"%s\": command already exists", newName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
- "TARGET_EXISTS", NULL);
+ "TARGET_EXISTS", (void *)NULL);
result = TCL_ERROR;
goto done;
}
@@ -2783,13 +3223,13 @@ TclRenameCommand(
*/
Tcl_DStringInit(&newFullName);
- Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1);
+ Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE);
if (newNsPtr != iPtr->globalNsPtr) {
TclDStringAppendLiteral(&newFullName, "::");
}
- Tcl_DStringAppend(&newFullName, newTail, -1);
+ Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE);
cmdPtr->refCount++;
- CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
+ CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -2992,7 +3432,6 @@ Tcl_GetCommandInfoFromToken(
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-
return 1;
}
@@ -3001,7 +3440,7 @@ Tcl_GetCommandInfoFromToken(
*
* Tcl_GetCommandName --
*
- * Given a token returned by Tcl_CreateCommand, this function returns the
+ * Given a token returned by Tcl_CreateObjCommand, this function returns the
* current name of the command (which may have changed due to renaming).
*
* Results:
@@ -3015,9 +3454,9 @@ Tcl_GetCommandInfoFromToken(
const char *
Tcl_GetCommandName(
- Tcl_Interp *interp, /* Interpreter containing the command. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Command command) /* Token for command returned by a previous
- * call to Tcl_CreateCommand. The command must
+ * call to Tcl_CreateObjCommand. The command must
* not have been deleted. */
{
Command *cmdPtr = (Command *) command;
@@ -3040,7 +3479,7 @@ Tcl_GetCommandName(
*
* Tcl_GetCommandFullName --
*
- * Given a token returned by, e.g., Tcl_CreateCommand or Tcl_FindCommand,
+ * Given a token returned by, e.g., Tcl_CreateObjCommand or Tcl_FindCommand,
* this function appends to an object the command's full name, qualified
* by a sequence of parent namespace names. The command's fully-qualified
* name may have changed due to renaming.
@@ -3059,7 +3498,7 @@ void
Tcl_GetCommandFullName(
Tcl_Interp *interp, /* Interpreter containing the command. */
Tcl_Command command, /* Token for command returned by a previous
- * call to Tcl_CreateCommand. The command must
+ * call to Tcl_CreateObjCommand. The command must
* not have been deleted. */
Tcl_Obj *objPtr) /* Points to the object onto which the
* command's full name is appended. */
@@ -3074,16 +3513,16 @@ Tcl_GetCommandFullName(
* separator, and the command name.
*/
- if (cmdPtr != NULL) {
+ if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) {
if (cmdPtr->nsPtr != NULL) {
- Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
+ Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (cmdPtr->hPtr != NULL) {
name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
- Tcl_AppendToObj(objPtr, name, -1);
+ Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE);
}
}
}
@@ -3156,13 +3595,6 @@ Tcl_DeleteCommandFromToken(
Tcl_Command importCmd;
/*
- * Bump the command epoch counter. This will invalidate all cached
- * references that point to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
* The code here is tricky. We can't delete the hash table entry before
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
@@ -3171,7 +3603,7 @@ Tcl_DeleteCommandFromToken(
* and skip nested deletes.
*/
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* Another deletion is already in progress. Remove the hash table
* entry now, but don't invoke a callback or free the command
@@ -3184,6 +3616,14 @@ Tcl_DeleteCommandFromToken(
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
return 0;
}
@@ -3195,17 +3635,18 @@ Tcl_DeleteCommandFromToken(
* be ignored.
*/
- cmdPtr->flags |= CMD_IS_DELETED;
+ cmdPtr->flags |= CMD_DYING;
/*
- * Call trace functions for the command being deleted. Then delete its
- * traces.
+ * Call each functions and then delete the trace.
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
+ /* CallCommandTraces() does not cmdPtr, that's
+ * done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
/*
@@ -3360,7 +3801,7 @@ CallCommandTraces(
* While a rename trace is active, we will not process any more rename
* traces; while a delete trace is active we will never reach here -
* because Tcl_DeleteCommandFromToken checks for the condition
- * (cmdPtr->flags & CMD_IS_DELETED) and returns immediately when a
+ * (cmdPtr->flags & CMD_DYING) and returns immediately when a
* command deletion is in progress. For all other traces, delete
* traces will not be invoked but a call to TraceCommandProc will
* ensure that tracePtr->clientData is freed whenever the command
@@ -3459,8 +3900,8 @@ CallCommandTraces(
static int
CancelEvalProc(
- ClientData clientData, /* Interp to cancel the script in progress. */
- Tcl_Interp *interp, /* Ignored */
+ void *clientData, /* Interp to cancel the script in progress. */
+ TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
CancelInfo *cancelInfo = (CancelInfo *)clientData;
@@ -3567,6 +4008,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3578,7 +4020,7 @@ Tcl_CreateMathFunc(
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
- ClientData clientData) /* Additional value to pass to the
+ void *clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
@@ -3619,7 +4061,7 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Pointer to OldMathFuncData describing the
+ void *clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
@@ -3647,13 +4089,18 @@ OldMathFuncProc(
args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
- /* TODO: Convert to TclGetNumberFromObj? */
+ /* TODO: Convert to Tcl_GetNumberFromObj? */
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
- if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
- d = valuePtr->internalRep.doubleValue;
- result = TCL_OK;
+ if (result != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(valuePtr, &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ result = TCL_OK;
+ }
}
#endif
if (result != TCL_OK) {
@@ -3664,7 +4111,7 @@ OldMathFuncProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
- TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
+ TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
@@ -3732,9 +4179,9 @@ OldMathFuncProc(
*/
if (funcResult.type == TCL_INT) {
- TclNewLongObj(valuePtr, funcResult.intValue);
+ TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
- valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
+ TclNewIntObj(valuePtr, funcResult.wideValue);
} else {
return CheckDoubleResult(interp, funcResult.doubleValue);
}
@@ -3761,7 +4208,7 @@ OldMathFuncProc(
static void
OldMathFuncDeleteProc(
- ClientData clientData)
+ void *clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
@@ -3800,7 +4247,7 @@ Tcl_GetMathFuncInfo(
int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Tcl_Obj *cmdNameObj;
Command *cmdPtr;
@@ -3822,7 +4269,7 @@ Tcl_GetMathFuncInfo(
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown math function \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, (void *)NULL);
*numArgsPtr = -1;
*argTypesPtr = NULL;
*procPtr = NULL;
@@ -3900,6 +4347,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -3926,8 +4374,8 @@ TclInterpReady(
Interp *iPtr = (Interp *) interp;
/*
- * Reset both the interpreter's string and object results and clear out
- * any previous error information.
+ * Reset the interpreter's result and clear out any previous error
+ * information.
*/
Tcl_ResetResult(interp);
@@ -3938,9 +4386,9 @@ TclInterpReady(
if (iPtr->flags & DELETED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to call eval in deleted interpreter", -1));
+ "attempt to call eval in deleted interpreter", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "IDELETE",
- "attempt to call eval in deleted interpreter", NULL);
+ "attempt to call eval in deleted interpreter", (void *)NULL);
return TCL_ERROR;
}
@@ -3962,13 +4410,13 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
+ if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "too many nested evaluations (infinite loop?)", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
+ "too many nested evaluations (infinite loop?)", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL);
return TCL_ERROR;
}
@@ -4076,7 +4524,7 @@ Tcl_Canceled(
if (flags & TCL_LEAVE_ERR_MSG) {
const char *id, *message = NULL;
- int length;
+ Tcl_Size length;
/*
* Setup errorCode variables so that we can differentiate between
@@ -4084,7 +4532,7 @@ Tcl_Canceled(
*/
if (iPtr->asyncCancelMsg != NULL) {
- message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+ message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
@@ -4101,8 +4549,8 @@ Tcl_Canceled(
}
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
- Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (void *)NULL);
}
/*
@@ -4141,7 +4589,7 @@ Tcl_CancelEval(
* script. */
Tcl_Obj *resultObjPtr, /* The script cancellation error message or
* NULL for a default error message. */
- ClientData clientData, /* Passed to CancelEvalProc. */
+ void *clientData, /* Passed to CancelEvalProc. */
int flags) /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
@@ -4164,7 +4612,7 @@ Tcl_CancelEval(
goto done;
}
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+ hPtr = Tcl_FindHashEntry(&cancelTable, interp);
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
@@ -4183,7 +4631,7 @@ Tcl_CancelEval(
*/
if (resultObjPtr != NULL) {
- result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
+ result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
@@ -4247,7 +4695,7 @@ int
Tcl_EvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
- int objc, /* Number of words in command. */
+ Tcl_Size 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
@@ -4266,7 +4714,7 @@ int
TclNREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
- int objc, /* Number of words in command. */
+ Tcl_Size 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
@@ -4300,13 +4748,13 @@ TclNREvalObjv(
static int
EvalObjvCore(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
- int objc = PTR2INT(data[2]);
+ Tcl_Size objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
Namespace *lookupNsPtr = NULL;
@@ -4392,7 +4840,7 @@ EvalObjvCore(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
- Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", (void *)NULL);
return TCL_ERROR;
}
}
@@ -4460,12 +4908,12 @@ EvalObjvCore(
static int
Dispatch(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
- ClientData clientData = data[1];
+ void *clientData = data[1];
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
@@ -4511,7 +4959,9 @@ TclNRRunCallbacks(
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4523,9 +4973,11 @@ TclNRRunCallbacks(
* are for NR function calls, and those are Tcl_Obj based.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* This is the trampoline.
@@ -4544,11 +4996,12 @@ TclNRRunCallbacks(
static int
NRCommand(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
iPtr->numLevels--;
@@ -4557,7 +5010,10 @@ NRCommand(
*/
if (data[1] && (data[1] != INT2PTR(1))) {
- TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ listPtr = (Tcl_Obj *)data[1];
+ data[1] = NULL;
+
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL);
}
/* OPT ??
@@ -4595,7 +5051,7 @@ NRCommand(
static void
TEOV_PushExceptionHandlers(
Tcl_Interp *interp,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[],
int flags)
{
@@ -4644,7 +5100,7 @@ TEOV_SwitchVarFrame(
static int
TEOV_RestoreVarFrame(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4654,7 +5110,7 @@ TEOV_RestoreVarFrame(
static int
TEOV_Exception(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4683,15 +5139,15 @@ TEOV_Exception(
static int
TEOV_Error(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
- int cmdLen;
- int objc = PTR2INT(data[0]);
+ Tcl_Size cmdLen;
+ Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
@@ -4702,7 +5158,7 @@ TEOV_Error(
*/
listPtr = Tcl_NewListObj(objc, objv);
- cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
+ cmdString = TclGetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
@@ -4713,13 +5169,13 @@ TEOV_Error(
static int
TEOV_NotFound(
Tcl_Interp *interp,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
{
Command * cmdPtr;
Interp *iPtr = (Interp *) interp;
- int i, newObjc, handlerObjc;
+ Tcl_Size i, newObjc, handlerObjc;
Tcl_Obj **newObjv, **handlerObjv;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *currNsPtr = NULL;/* Used to check for and invoke any registered
@@ -4751,7 +5207,7 @@ TEOV_NotFound(
* itself.
*/
- TclListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
+ TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
@@ -4783,7 +5239,7 @@ TEOV_NotFound(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(objv[0]), NULL);
+ TclGetString(objv[0]), (void *)NULL);
/*
* Release any resources we locked and allocated during the handler
@@ -4809,16 +5265,16 @@ TEOV_NotFound(
static int
TEOV_NotFoundCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- int objc = PTR2INT(data[0]);
+ Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
Namespace *savedNsPtr = (Namespace *)data[2];
- int i;
+ Tcl_Size i;
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
@@ -4841,14 +5297,14 @@ TEOV_RunEnterTraces(
Tcl_Interp *interp,
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
- int length, traceCode = TCL_OK;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int traceCode = TCL_OK;
+ const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
@@ -4889,20 +5345,20 @@ TEOV_RunEnterTraces(
static int
TEOV_RunLeaveTraces(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
- int objc = PTR2INT(data[0]);
+ Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
- int length;
- const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+ Tcl_Size length;
+ const char *command = TclGetStringFromObj(commandPtr, &length);
- if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -4982,13 +5438,14 @@ Tcl_EvalTokensStandard(
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
- int count) /* Number of tokens to consider at tokenPtr.
+ Tcl_Size count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -5023,7 +5480,7 @@ Tcl_EvalTokens(
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
- int count) /* Number of tokens to consider at tokenPtr.
+ Tcl_Size count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
Tcl_Obj *resPtr;
@@ -5036,6 +5493,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5063,7 +5521,7 @@ Tcl_EvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
- int numBytes, /* Number of bytes in script. If < 0, the
+ Tcl_Size numBytes, /* Number of bytes in script. If -1, the
* script consists of all bytes up to the
* first null character. */
int flags) /* Collection of OR-ed bits that control the
@@ -5078,14 +5536,14 @@ TclEvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
- int numBytes, /* Number of bytes in script. If < 0, the
+ Tcl_Size 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. */
- int line, /* The line the script starts on. */
- int *clNextOuter, /* Information about an outer context for */
+ Tcl_Size line, /* The line the script starts on. */
+ Tcl_Size *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'
@@ -5105,16 +5563,18 @@ TclEvalEx(
{
Interp *iPtr = (Interp *) interp;
const char *p, *next;
- const unsigned int minObjs = 20;
+ const int minObjs = 20;
Tcl_Obj **objv, **objvSpace;
- int *expand, *lines, *lineSpace;
+ int *expand;
+ Tcl_Size *lines, *lineSpace;
Tcl_Token *tokenPtr;
- int commandLength, bytesLeft, expandRequested, code = TCL_OK;
+ int expandRequested, code = TCL_OK;
+ Tcl_Size bytesLeft, 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;
- unsigned int i, objectsUsed = 0;
+ Tcl_Size i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
@@ -5124,10 +5584,10 @@ TclEvalEx(
Tcl_Obj **stackObjArray = (Tcl_Obj **)
TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
- int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
+ Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size));
/* TIP #280 Structures for tracking of command
* locations. */
- int *clNext = NULL; /* Pointer for the tracking of invisible
+ Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible
* continuation lines. Initialized only if the
* caller gave us a table of locations to
* track, via scriptCLLocPtr. It always refers
@@ -5249,11 +5709,11 @@ TclEvalEx(
* per-command parsing.
*/
- int wordLine = line;
+ Tcl_Size wordLine = line;
const char *wordStart = parsePtr->commandStart;
- int *wordCLNext = clNext;
- unsigned int objectsNeeded = 0;
- unsigned int numWords = parsePtr->numWords;
+ Tcl_Size *wordCLNext = clNext;
+ Tcl_Size objectsNeeded = 0;
+ Tcl_Size numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
@@ -5262,7 +5722,7 @@ TclEvalEx(
if (numWords > minObjs) {
expand = (int *)ckalloc(numWords * sizeof(int));
objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *));
- lineSpace = (int *)ckalloc(numWords * sizeof(int));
+ lineSpace = (Tcl_Size *)ckalloc(numWords * sizeof(Tcl_Size));
}
expandRequested = 0;
objv = objvSpace;
@@ -5304,9 +5764,9 @@ TclEvalEx(
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
- int numElements;
+ Tcl_Size numElements;
- code = TclListObjLength(interp, objv[objectsUsed],
+ code = TclListObjLengthM(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
@@ -5342,23 +5802,23 @@ TclEvalEx(
*/
Tcl_Obj **copy = objvSpace;
- int *lcopy = lineSpace;
- int wordIdx = numWords;
- int objIdx = objectsNeeded - 1;
+ Tcl_Size *lcopy = lineSpace;
+ Tcl_Size wordIdx = numWords;
+ Tcl_Size objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
(Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
- lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int));
+ lines = lineSpace = (Tcl_Size *)ckalloc(objectsNeeded * sizeof(Tcl_Size));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
- int numElements;
+ Tcl_Size numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
- TclListObjGetElements(NULL, temp, &numElements,
+ TclListObjGetElementsM(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
@@ -5548,7 +6008,7 @@ TclEvalEx(
void
TclAdvanceLines(
- int *line,
+ Tcl_Size *line,
const char *start,
const char *end)
{
@@ -5583,8 +6043,8 @@ TclAdvanceLines(
void
TclAdvanceContinuations(
- int *line,
- int **clNextPtrPtr,
+ Tcl_Size *line,
+ Tcl_Size **clNextPtrPtr,
int loc)
{
/*
@@ -5643,11 +6103,12 @@ void
TclArgumentEnter(
Tcl_Interp *interp,
Tcl_Obj **objv,
- int objc,
+ Tcl_Size objc,
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
- int isNew, i;
+ int isNew;
+ Tcl_Size i;
Tcl_HashEntry *hPtr;
CFWord *cfwPtr;
@@ -5711,15 +6172,15 @@ void
TclArgumentRelease(
Tcl_Interp *interp,
Tcl_Obj **objv,
- int objc)
+ Tcl_Size objc)
{
Interp *iPtr = (Interp *) interp;
- int i;
+ Tcl_Size i;
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
+ Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
@@ -5759,19 +6220,19 @@ void
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
- int objc,
+ Tcl_Size objc,
void *codePtr,
CmdFrame *cfPtr,
- int cmd,
- int pc)
+ Tcl_Size cmd,
+ Tcl_Size pc)
{
ExtCmdLoc *eclPtr;
- int word;
+ Tcl_Size word;
ECL *ePtr;
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
@@ -5877,7 +6338,7 @@ TclArgumentBCRelease(
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
@@ -5933,7 +6394,7 @@ TclArgumentGet(
* up by the caller. It knows better than us.
*/
- if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) {
+ if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) {
return;
}
@@ -5942,7 +6403,7 @@ TclArgumentGet(
* stack. That is nearest.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
@@ -5956,7 +6417,7 @@ TclArgumentGet(
* that stack.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
@@ -5991,6 +6452,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -5998,7 +6460,7 @@ Tcl_Eval(
* previous call to Tcl_CreateInterp). */
const char *script) /* Pointer to TCL command to execute. */
{
- int code = Tcl_EvalEx(interp, script, -1, 0);
+ int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0);
/*
* For backwards compatibility with old C code that predates the object
@@ -6043,6 +6505,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6127,7 +6590,7 @@ TclNREvalObjEx(
if (TclListObjIsCanonical(objPtr)) {
CmdFrame *eoFramePtr = NULL;
- int objc;
+ Tcl_Size objc;
Tcl_Obj *listPtr, **objv;
/*
@@ -6196,7 +6659,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6237,7 +6700,7 @@ TclNREvalObjEx(
*/
const char *script;
- int numSrcBytes;
+ Tcl_Size numSrcBytes;
/*
* Now we check if we have data about invisible continuation lines for
@@ -6264,7 +6727,7 @@ TclNREvalObjEx(
Tcl_IncrRefCount(objPtr);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
@@ -6276,7 +6739,7 @@ TclNREvalObjEx(
static int
TEOEx_ByteCodeCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6291,11 +6754,11 @@ TEOEx_ByteCodeCallback(
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
- int numSrcBytes;
+ Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
@@ -6322,7 +6785,7 @@ TEOEx_ByteCodeCallback(
static int
TEOEx_ListCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6376,16 +6839,16 @@ ProcessUnexpectedResult(
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "invoked \"break\" outside of a loop", -1));
+ "invoked \"break\" outside of a loop", TCL_INDEX_NONE));
} else if (returnCode == TCL_CONTINUE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "invoked \"continue\" outside of a loop", -1));
+ "invoked \"continue\" outside of a loop", TCL_INDEX_NONE));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"command returned bad code: %d", returnCode));
}
snprintf(buf, sizeof(buf), "%d", returnCode);
- Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UNEXPECTED_RESULT_CODE", buf, (void *)NULL);
}
/*
@@ -6425,7 +6888,7 @@ Tcl_ExprLong(
*ptr = 0;
} else {
- exprPtr = Tcl_NewStringObj(exprstring, -1);
+ exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprLongObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
@@ -6453,7 +6916,7 @@ Tcl_ExprDouble(
*ptr = 0.0;
} else {
- exprPtr = Tcl_NewStringObj(exprstring, -1);
+ exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
@@ -6481,7 +6944,7 @@ Tcl_ExprBoolean(
return TCL_OK;
} else {
int result;
- Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);
+ Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
@@ -6529,14 +6992,14 @@ Tcl_ExprLongObj(
Tcl_Obj *resultPtr;
int result, type;
double d;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) {
return TCL_ERROR;
}
@@ -6552,8 +7015,7 @@ Tcl_ExprLongObj(
resultPtr = Tcl_NewBignumObj(&big);
}
/* FALLTHRU */
- case TCL_NUMBER_LONG:
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
@@ -6576,14 +7038,14 @@ Tcl_ExprDoubleObj(
{
Tcl_Obj *resultPtr;
int result, type;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
- result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type);
+ result = Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type);
if (result == TCL_OK) {
switch (type) {
case TCL_NUMBER_NAN:
@@ -6647,7 +7109,7 @@ int
TclObjInvokeNamespace(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
- int objc, /* Count of arguments. */
+ Tcl_Size objc, /* Count of arguments. */
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
* name of the command to invoke. */
Tcl_Namespace *nsPtr, /* The namespace to use. */
@@ -6691,7 +7153,7 @@ int
TclObjInvoke(
Tcl_Interp *interp, /* Interpreter in which command is to be
* invoked. */
- int objc, /* Count of arguments. */
+ Tcl_Size objc, /* Count of arguments. */
Tcl_Obj *const objv[], /* Argument objects; objv[0] points to the
* name of the command to invoke. */
int flags) /* Combination of flags controlling the call:
@@ -6703,7 +7165,7 @@ TclObjInvoke(
}
if ((objc < 1) || (objv == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "illegal argument vector", -1));
+ "illegal argument vector", TCL_INDEX_NONE));
return TCL_ERROR;
}
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
@@ -6714,7 +7176,7 @@ TclObjInvoke(
int
TclNRInvoke(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6734,7 +7196,7 @@ TclNRInvoke(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
@@ -6757,7 +7219,7 @@ TclNRInvoke(
static int
NRPostInvoke(
- ClientData clientData[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -6800,9 +7262,9 @@ Tcl_ExprString(
* An empty string. Just set the interpreter's result to 0.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
- Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1);
+ Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE);
Tcl_IncrRefCount(exprObj);
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
@@ -6874,6 +7336,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6883,6 +7346,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6911,7 +7375,7 @@ Tcl_AddObjErrorInfo(
* pertains. */
const char *message, /* Points to the first byte of an array of
* bytes of the message. */
- int length) /* The number of bytes in the message. If < 0,
+ Tcl_Size length) /* The number of bytes in the message. If < 0,
* then append all bytes up to a NULL byte. */
{
Interp *iPtr = (Interp *) interp;
@@ -6923,7 +7387,8 @@ Tcl_AddObjErrorInfo(
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
- if (iPtr->result[0] != 0) {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ if (*(iPtr->result) != 0) {
/*
* The interp's string result is set, apparently by some extension
* making a deprecated direct write to it. That extension may
@@ -6932,13 +7397,13 @@ Tcl_AddObjErrorInfo(
* interp->result completely.
*/
- iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
- } else {
+ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, TCL_INDEX_NONE);
+ } else
+#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
- }
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
- Tcl_SetErrorCode(interp, "NONE", NULL);
+ Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
}
}
@@ -6957,7 +7422,7 @@ Tcl_AddObjErrorInfo(
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
@@ -6966,12 +7431,12 @@ Tcl_AddObjErrorInfo(
*
* Results:
* A standard Tcl return result. An error message or other result may be
- * left in the interp's result.
+ * left in the interp.
*
* Side effects:
* Depends on what was done by the command.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
@@ -6998,7 +7463,7 @@ Tcl_VarEvalVA(
Tcl_DStringAppend(&buf, string, -1);
}
- result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
+ result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
@@ -7013,13 +7478,14 @@ Tcl_VarEvalVA(
*
* Results:
* A standard Tcl return result. An error message or other result may be
- * left in interp->result.
+ * left in the interp.
*
* Side effects:
* Depends on what was done by the command.
*
*----------------------------------------------------------------------
*/
+
int
Tcl_VarEval(
Tcl_Interp *interp,
@@ -7054,6 +7520,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -7067,10 +7534,11 @@ Tcl_GlobalEval(
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
- result = Tcl_Eval(interp, command);
+ result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -7089,14 +7557,14 @@ Tcl_GlobalEval(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_SetRecursionLimit(
Tcl_Interp *interp, /* Interpreter whose nesting limit is to be
* set. */
- int depth) /* New value for maximum depth. */
+ Tcl_Size depth) /* New value for maximum depth. */
{
Interp *iPtr = (Interp *) interp;
- int old;
+ Tcl_Size old;
old = iPtr->maxNestingDepth;
if (depth > 0) {
@@ -7192,7 +7660,7 @@ Tcl_GetVersion(
static int
ExprCeilFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7208,9 +7676,13 @@ ExprCeilFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7228,7 +7700,7 @@ ExprCeilFunc(
static int
ExprFloorFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7244,9 +7716,13 @@ ExprFloorFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7264,12 +7740,12 @@ ExprFloorFunc(
static int
ExprIsqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
- ClientData ptr;
+ void *ptr;
int type;
double d;
Tcl_WideInt w;
@@ -7290,7 +7766,7 @@ ExprIsqrtFunc(
* Make sure that the arg is a number.
*/
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
@@ -7318,7 +7794,7 @@ ExprIsqrtFunc(
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
- if (big.sign) {
+ if (mp_isneg(&big)) {
mp_clear(&big);
goto negarg;
}
@@ -7346,25 +7822,31 @@ ExprIsqrtFunc(
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
} else {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "square root of negative argument", -1));
+ "square root of negative argument", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
- "domain error: argument not in valid range", NULL);
+ "domain error: argument not in valid range", (void *)NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
- ClientData clientData, /* Ignored */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7380,21 +7862,32 @@ ExprSqrtFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
- if ((d >= 0.0) && TclIsInfinite(d)
+ if ((d >= 0.0) && isinf(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
+ mp_err err;
- mp_init(&root);
- mp_sqrt(&big, &root);
+ err = mp_init(&root);
+ if (err == MP_OKAY) {
+ err = mp_sqrt(&big, &root);
+ }
mp_clear(&big);
+ if (err != MP_OKAY) {
+ mp_clear(&root);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
mp_clear(&root);
} else {
@@ -7405,7 +7898,7 @@ ExprSqrtFunc(
static int
ExprUnaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes one double argument and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7423,10 +7916,14 @@ ExprUnaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7442,12 +7939,12 @@ CheckDoubleResult(
double dResult)
{
#ifndef ACCEPT_NAN
- if (TclIsNaN(dResult)) {
+ if (isnan(dResult)) {
TclExprFloatError(interp, dResult);
return TCL_ERROR;
}
#endif
- if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
+ if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) {
/*
* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf
*/
@@ -7465,7 +7962,7 @@ CheckDoubleResult(
static int
ExprBinaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes two double arguments and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7483,10 +7980,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
- d1 = objv[1]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d1 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7494,10 +7995,14 @@ ExprBinaryFunc(
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
- if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
- d2 = objv[2]->internalRep.doubleValue;
- Tcl_ResetResult(interp);
- code = TCL_OK;
+ if (code != TCL_OK) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+
+ if (irPtr) {
+ d2 = irPtr->doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
}
#endif
if (code != TCL_OK) {
@@ -7509,13 +8014,13 @@ ExprBinaryFunc(
static int
ExprAbsFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
- ClientData ptr;
+ void *ptr;
int type;
mp_int big;
@@ -7524,32 +8029,45 @@ ExprAbsFunc(
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
- if (type == TCL_NUMBER_LONG) {
- long l = *((const long *) ptr);
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
- if (l > (long)0) {
+ if (l > 0) {
goto unChanged;
- } else if (l == (long)0) {
- const char *string = objv[1]->bytes;
- if (string) {
- while (*string != '0') {
- if (*string == '-') {
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ } else if (l == 0) {
+ if (TclHasStringRep(objv[1])) {
+ Tcl_Size numBytes;
+ const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
+
+ while (numBytes) {
+ if (*bytes == '-') {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
- string++;
+ bytes++; numBytes--;
}
}
goto unChanged;
- } else if (l == LONG_MIN) {
- TclBNInitBignumFromLong(&big, l);
+ } else if (l == WIDE_MIN) {
+ if (sizeof(Tcl_WideInt) > sizeof(int64_t)) {
+ Tcl_WideUInt ul = -(Tcl_WideUInt)WIDE_MIN;
+ if (mp_init(&big) != MP_OKAY || mp_unpack(&big, 1, 1,
+ sizeof(Tcl_WideInt), 0, 0, &ul) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ } else if (mp_init_i64(&big, l) != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto tooLarge;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
@@ -7573,27 +8091,13 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
-
- if (w >= (Tcl_WideInt)0) {
- goto unChanged;
- }
- if (w == LLONG_MIN) {
- TclBNInitBignumFromWideInt(&big, w);
- goto tooLarge;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
- return TCL_OK;
- }
-#endif
-
if (type == TCL_NUMBER_BIG) {
- if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) {
+ if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
- (void)mp_neg(&big, &big);
+ if (mp_neg(&big, &big) != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
@@ -7618,7 +8122,7 @@ ExprAbsFunc(
static int
ExprBoolFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7639,7 +8143,7 @@ ExprBoolFunc(
static int
ExprDoubleFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7653,7 +8157,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objv[1]->typePtr == &tclDoubleType) {
+ if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7665,8 +8169,8 @@ ExprDoubleFunc(
}
static int
-ExprEntierFunc(
- ClientData clientData, /* Ignored. */
+ExprIntFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7674,31 +8178,19 @@ ExprEntierFunc(
{
double d;
int type;
- ClientData ptr;
+ void *ptr;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
d = *((const double *) ptr);
- if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) {
- long result = (long) d;
-
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
- return TCL_OK;
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) {
- Tcl_WideInt result = (Tcl_WideInt) d;
-
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
- return TCL_OK;
-#endif
- } else {
+ if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7707,6 +8199,11 @@ ExprEntierFunc(
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
+ } else {
+ Tcl_WideInt result = (Tcl_WideInt) d;
+
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
}
}
@@ -7728,73 +8225,91 @@ ExprEntierFunc(
}
static int
-ExprIntFunc(
- ClientData clientData, /* Ignored. */
+ExprWideFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- long iResult;
- Tcl_Obj *objPtr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in long range.
- */
-
- mp_int big;
+ Tcl_WideInt wResult;
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &iResult);
- Tcl_DecrRefCount(objPtr);
+ if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
+ TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
+/*
+ * Common implmentation of max() and min().
+ */
static int
-ExprWideFunc(
- ClientData clientData, /* Ignored. */
+ExprMaxMinFunc(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
- Tcl_Obj *const *objv) /* Actual parameter vector. */
+ Tcl_Obj *const *objv, /* Actual parameter vector. */
+ int op) /* Comparison direction */
{
- Tcl_WideInt wResult;
- Tcl_Obj *objPtr;
+ Tcl_Obj *res;
+ double d;
+ int type, i;
+ void *ptr;
- if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ if (objc < 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in wide int range.
- */
-
- mp_int big;
+ res = objv[1];
+ for (i = 1; i < objc; i++) {
+ if (Tcl_GetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ /*
+ * Get the error message for NaN.
+ */
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &wResult);
- Tcl_DecrRefCount(objPtr);
+ Tcl_GetDoubleFromObj(interp, objv[i], &d);
+ return TCL_ERROR;
+ }
+ if (TclCompareTwoNumbers(objv[i], res) == op) {
+ res = objv[i];
+ }
}
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
+
+ Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
+ExprMaxFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(NULL, interp, objc, objv, MP_GT);
+}
+
+static int
+ExprMinFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
+ return ExprMaxMinFunc(NULL, interp, objc, objv, MP_LT);
+}
+
+static int
ExprRandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
@@ -7887,14 +8402,14 @@ ExprRandFunc(
static int
ExprRoundFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
double d;
- ClientData ptr;
+ void *ptr;
int type;
if (objc != 2) {
@@ -7902,13 +8417,13 @@ ExprRoundFunc(
return TCL_ERROR;
}
- if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_DOUBLE) {
double fractPart, intPart;
- long max = LONG_MAX, min = LONG_MIN;
+ Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN;
fractPart = modf(*((const double *) ptr), &intPart);
if (fractPart <= -0.5) {
@@ -7918,27 +8433,31 @@ ExprRoundFunc(
}
if ((intPart >= (double)max) || (intPart <= (double)min)) {
mp_int big;
+ mp_err err = MP_OKAY;
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
/* Infinity */
return TCL_ERROR;
}
if (fractPart <= -0.5) {
- mp_sub_d(&big, 1, &big);
+ err = mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
- mp_add_d(&big, 1, &big);
+ err = mp_add_d(&big, 1, &big);
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
- long result = (long)intPart;
+ Tcl_WideInt result = (Tcl_WideInt)intPart;
if (fractPart <= -0.5) {
result--;
} else if (fractPart >= 0.5) {
result++;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
}
@@ -7962,14 +8481,14 @@ ExprRoundFunc(
static int
ExprSrandFunc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
- long i = 0; /* Initialized to avoid compiler warning. */
+ Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
@@ -7980,20 +8499,8 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
- Tcl_Obj *objPtr;
- mp_int big;
-
- if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
- /* TODO: more ::errorInfo here? or in caller? */
- return TCL_ERROR;
- }
-
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &i);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -8002,8 +8509,7 @@ ExprSrandFunc(
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7FFFFFFF;
+ iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
@@ -8014,7 +8520,396 @@ ExprSrandFunc(
* will always succeed.
*/
- return ExprRandFunc(clientData, interp, 1, objv);
+ return ExprRandFunc(NULL, interp, 1, objv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Double Classification Functions --
+ *
+ * This page contains the functions that implement all of the built-in
+ * math functions for classifying IEEE doubles.
+ *
+ * These have to be a little bit careful while Tcl_GetDoubleFromObj()
+ * rejects NaN values, which these functions *explicitly* accept.
+ *
+ * Results:
+ * Each function returns TCL_OK if it succeeds and pushes an Tcl object
+ * holding the result. If it fails it returns TCL_ERROR and leaves an
+ * error message in the interpreter's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ *
+ * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course.
+ * But it does sometimes have _fpclass() which does almost the same job; if
+ * even that is absent, we grobble around directly in the platform's binary
+ * representation of double.
+ *
+ * The ClassifyDouble() function makes all that conform to a common API
+ * (effectively the C99 standard API renamed), and just delegates to the
+ * standard macro on platforms that do it correctly.
+ */
+
+static inline int
+ClassifyDouble(
+ double d)
+{
+#if TCL_FPCLASSIFY_MODE == 0
+ return fpclassify(d);
+#else /* TCL_FPCLASSIFY_MODE != 0 */
+ /*
+ * If we don't have fpclassify(), we also don't have the values it returns.
+ * Hence we define those here.
+ */
+#ifndef FP_NAN
+# define FP_NAN 1 /* Value is NaN */
+# define FP_INFINITE 2 /* Value is an infinity */
+# define FP_ZERO 3 /* Value is a zero */
+# define FP_NORMAL 4 /* Value is a normal float */
+# define FP_SUBNORMAL 5 /* Value has lost accuracy */
+#endif /* !FP_NAN */
+
+#if TCL_FPCLASSIFY_MODE == 3
+ return __builtin_fpclassify(
+ FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d);
+#elif TCL_FPCLASSIFY_MODE == 2
+ /*
+ * We assume this hack is only needed on little-endian systems.
+ * Specifically, x86 running Windows. It's fairly easy to enable for
+ * others if they need it (because their libc/libm is broken) but we'll
+ * jump that hurdle when requred. We can solve the word ordering then.
+ */
+
+ union {
+ double d; /* Interpret as double */
+ struct {
+ unsigned int low; /* Lower 32 bits */
+ unsigned int high; /* Upper 32 bits */
+ } w; /* Interpret as unsigned integer words */
+ } doubleMeaning; /* So we can look at the representation of a
+ * double directly. Platform (i.e., processor)
+ * specific; this is for x86 (and most other
+ * little-endian processors, but those are
+ * untested). */
+ unsigned int exponent, mantissaLow, mantissaHigh;
+ /* The pieces extracted from the double. */
+ int zeroMantissa; /* Was the mantissa zero? That's special. */
+
+ /*
+ * Shifts and masks to use with the doubleMeaning variable above.
+ */
+
+#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */
+#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */
+#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */
+
+ /*
+ * Extract the exponent (11 bits) and mantissa (52 bits). Note that we
+ * totally ignore the sign bit.
+ */
+
+ doubleMeaning.d = d;
+ exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK;
+ mantissaLow = doubleMeaning.w.low;
+ mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK;
+ zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0);
+
+ /*
+ * Look for the special cases of exponent.
+ */
+
+ switch (exponent) {
+ case 0:
+ /*
+ * When the exponent is all zeros, it's a ZERO or a SUBNORMAL.
+ */
+
+ return zeroMantissa ? FP_ZERO : FP_SUBNORMAL;
+ case EXPONENT_MASK:
+ /*
+ * When the exponent is all ones, it's an INF or a NAN.
+ */
+
+ return zeroMantissa ? FP_INFINITE : FP_NAN;
+ default:
+ /*
+ * Everything else is a NORMAL double precision float.
+ */
+
+ return FP_NORMAL;
+ }
+#elif TCL_FPCLASSIFY_MODE == 1
+ switch (_fpclass(d)) {
+ case _FPCLASS_NZ:
+ case _FPCLASS_PZ:
+ return FP_ZERO;
+ case _FPCLASS_NN:
+ case _FPCLASS_PN:
+ return FP_NORMAL;
+ case _FPCLASS_ND:
+ case _FPCLASS_PD:
+ return FP_SUBNORMAL;
+ case _FPCLASS_NINF:
+ case _FPCLASS_PINF:
+ return FP_INFINITE;
+ default:
+ Tcl_Panic("result of _fpclass() outside documented range!");
+ case _FPCLASS_QNAN:
+ case _FPCLASS_SNAN:
+ return FP_NAN;
+ }
+#else /* TCL_FPCLASSIFY_MODE not in (0..3) */
+#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
+#endif /* TCL_FPCLASSIFY_MODE */
+#endif /* !fpclassify */
+}
+
+static int
+ExprIsFiniteFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ type = ClassifyDouble(d);
+ result = (type != FP_INFINITE && type != FP_NAN);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsInfinityFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_INFINITE);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsNaNFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 1;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_NAN);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsNormalFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_NORMAL);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsSubnormalFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type != TCL_NUMBER_NAN) {
+ if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ result = (ClassifyDouble(d) == FP_SUBNORMAL);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+ExprIsUnorderedFunc(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ void *ptr;
+ int type, result = 0;
+
+ if (objc != 3) {
+ MathFuncWrongNumArgs(interp, 3, objc, objv);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ result = 1;
+ } else {
+ d = *((const double *) ptr);
+ result = (ClassifyDouble(d) == FP_NAN);
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ result |= 1;
+ } else {
+ d = *((const double *) ptr);
+ result |= (ClassifyDouble(d) == FP_NAN);
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
+}
+
+static int
+FloatClassifyObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count */
+ Tcl_Obj *const *objv) /* Actual parameter list */
+{
+ double d;
+ Tcl_Obj *objPtr;
+ void *ptr;
+ int type;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "floatValue");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_NAN) {
+ goto gotNaN;
+ } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (ClassifyDouble(d)) {
+ case FP_INFINITE:
+ TclNewLiteralStringObj(objPtr, "infinite");
+ break;
+ case FP_NAN:
+ gotNaN:
+ TclNewLiteralStringObj(objPtr, "nan");
+ break;
+ case FP_NORMAL:
+ TclNewLiteralStringObj(objPtr, "normal");
+ break;
+ case FP_SUBNORMAL:
+ TclNewLiteralStringObj(objPtr, "subnormal");
+ break;
+ case FP_ZERO:
+ TclNewLiteralStringObj(objPtr, "zero");
+ break;
+ default:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unable to classify number: %f", d));
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
}
/*
@@ -8041,7 +8936,7 @@ MathFuncWrongNumArgs(
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- const char *name = Tcl_GetString(objv[0]);
+ const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name+1) {
@@ -8054,7 +8949,7 @@ MathFuncWrongNumArgs(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s arguments for math function \"%s\"",
(found < expected ? "not enough" : "too many"), name));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
}
#ifdef USE_DTRACE
@@ -8076,8 +8971,8 @@ MathFuncWrongNumArgs(
static int
DTraceObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
@@ -8179,7 +9074,7 @@ TclDTraceInfo(
static int
DTraceCmdReturn(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8224,8 +9119,8 @@ int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
- ClientData clientData,
- int objc,
+ void *clientData,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
NRE_callback *rootPtr = TOP_CB(interp);
@@ -8276,14 +9171,15 @@ Tcl_NRCreateCommand(
* calls. */
Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
- ClientData clientData, /* Arbitrary value to pass to object
+ 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. */
{
Command *cmdPtr = (Command *)
- Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc);
+ Tcl_CreateObjCommand(interp, cmdName, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8296,11 +9192,12 @@ TclNRCreateCommandInNs(
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc)
{
Command *cmdPtr = (Command *)
- TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+ TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData,
+ deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8323,7 +9220,7 @@ int
Tcl_NREvalObjv(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* command. Also used for error reporting. */
- int objc, /* Number of words in command. */
+ Tcl_Size 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
@@ -8338,7 +9235,7 @@ int
Tcl_NRCmdSwap(
Tcl_Interp *interp,
Tcl_Command cmd,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[],
int flags)
{
@@ -8458,7 +9355,7 @@ TclSetTailcall(
int
TclNRTailcallObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8472,8 +9369,8 @@ TclNRTailcallObjCmd(
if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "tailcall can only be called from a proc, lambda or method", -1));
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ "tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL);
return TCL_ERROR;
}
@@ -8502,7 +9399,7 @@ TclNRTailcallObjCmd(
* namespace, the rest the command to be tailcalled.
*/
- nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
@@ -8523,17 +9420,17 @@ TclNRTailcallObjCmd(
int
TclNRTailcallEval(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
- int objc;
+ Tcl_Size objc;
Tcl_Obj **objv;
- TclListObjGetElements(interp, listPtr, &objc, &objv);
+ TclListObjGetElementsM(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
@@ -8562,8 +9459,8 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
@@ -8583,10 +9480,10 @@ void
Tcl_NRAddCallback(
Tcl_Interp *interp,
Tcl_NRPostProc *postProcPtr,
- ClientData data0,
- ClientData data1,
- ClientData data2,
- ClientData data3)
+ void *data0,
+ void *data1,
+ void *data2,
+ void *data3)
{
if (!(postProcPtr)) {
Tcl_Panic("Adding a callback without an objProc?!");
@@ -8620,7 +9517,7 @@ Tcl_NRAddCallback(
int
TclNRYieldObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8634,8 +9531,8 @@ TclNRYieldObjCmd(
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "yield can only be called in a coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
+ "yield can only be called in a coroutine", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL);
return TCL_ERROR;
}
@@ -8651,7 +9548,7 @@ TclNRYieldObjCmd(
int
TclNRYieldToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8667,16 +9564,16 @@ TclNRYieldToObjCmd(
if (!corPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "yieldto can only be called in a coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
+ "yieldto can only be called in a coroutine", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (void *)NULL);
return TCL_ERROR;
}
if (((Namespace *) nsPtr)->flags & NS_DYING) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "yieldto called in deleted namespace", -1));
+ "yieldto called in deleted namespace", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -8687,7 +9584,7 @@ TclNRYieldToObjCmd(
*/
listPtr = Tcl_NewListObj(objc, objv);
- nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
/*
@@ -8695,19 +9592,21 @@ TclNRYieldToObjCmd(
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
+ /* Not calling Tcl_IncrRefCount(listPtr) here because listPtr is private */
TclSetTailcall(interp, listPtr);
+ corPtr->yieldPtr = listPtr;
iPtr->execEnvPtr = corPtr->eePtr;
- return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
+ return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv);
}
static int
RewindCoroutineCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
- return Tcl_RestoreInterpState(interp, data[0]);
+ return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]);
}
static int
@@ -8730,7 +9629,7 @@ RewindCoroutine(
static void
DeleteCoroutine(
- ClientData clientData)
+ void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
@@ -8743,7 +9642,7 @@ DeleteCoroutine(
static int
NRCoroutineCallerCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8774,7 +9673,7 @@ NRCoroutineCallerCallback(
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
- if (cmdPtr->flags & CMD_IS_DELETED) {
+ if (cmdPtr->flags & CMD_DYING) {
/*
* The command was deleted while it was running: wind down the
* execEnv, this will do the complete cleanup. RewindCoroutine will
@@ -8789,7 +9688,7 @@ NRCoroutineCallerCallback(
static int
NRCoroutineExitCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8854,13 +9753,11 @@ NRCoroutineExitCallback(
int
TclNRCoroutineActivateCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
- int type = PTR2INT(data[1]);
- int numLevels;
void *stackLevel = TclGetCStackPtr();
if (!corPtr->stackLevel) {
@@ -8879,7 +9776,7 @@ TclNRCoroutineActivateCallback(
*/
corPtr->stackLevel = stackLevel;
- numLevels = corPtr->auxNumLevels;
+ Tcl_Size numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
SAVE_CONTEXT(corPtr->caller);
@@ -8893,13 +9790,30 @@ TclNRCoroutineActivateCallback(
*/
if (corPtr->stackLevel != stackLevel) {
+ NRE_callback *runPtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ if (corPtr->yieldPtr) {
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->data[1] == corPtr->yieldPtr) {
+ Tcl_DecrRefCount((Tcl_Obj *)runPtr->data[1]);
+ runPtr->data[1] = NULL;
+ corPtr->yieldPtr = NULL;
+ break;
+ }
+ }
+ }
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot yield: C stack busy", -1));
+ "cannot yield: C stack busy", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
+ void *type = data[1];
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
@@ -8908,9 +9822,10 @@ TclNRCoroutineActivateCallback(
Tcl_Panic("Yield received an option which is not implemented");
}
+ corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
- numLevels = iPtr->numLevels;
+ Tcl_Size numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
@@ -8933,11 +9848,11 @@ TclNRCoroutineActivateCallback(
static int
TclNREvalList(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result /*result*/)
+ TCL_UNUSED(int) /*result*/)
{
- int objc;
+ Tcl_Size objc;
Tcl_Obj **objv;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
@@ -8945,7 +9860,7 @@ TclNREvalList(
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
- TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
@@ -8961,7 +9876,7 @@ TclNREvalList(
static int
CoroTypeObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8981,9 +9896,9 @@ CoroTypeObjCmd(
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can only get coroutine type of a coroutine", -1));
+ "can only get coroutine type of a coroutine", TCL_INDEX_NONE));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
- TclGetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
@@ -8994,7 +9909,7 @@ CoroTypeObjCmd(
corPtr = (CoroutineData *)cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE));
return TCL_OK;
}
@@ -9005,15 +9920,15 @@ CoroTypeObjCmd(
switch (corPtr->nargs) {
case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
- Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE));
return TCL_OK;
case COROUTINE_ARGUMENTS_ARBITRARY:
- Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE));
return TCL_OK;
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unknown coroutine type", -1));
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
+ "unknown coroutine type", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (void *)NULL);
return TCL_ERROR;
}
}
@@ -9021,27 +9936,91 @@ CoroTypeObjCmd(
/*
*----------------------------------------------------------------------
*
- * NRCoroInjectObjCmd --
+ * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd --
*
- * Implementation of [::tcl::unsupported::inject] command.
+ * Implementation of [coroinject] and [coroprobe] commands.
*
*----------------------------------------------------------------------
*/
+static inline CoroutineData *
+GetCoroutineFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ const char *errMsg)
+{
+ /*
+ * How to get a coroutine from its handle.
+ */
+
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+ TclGetString(objPtr), (void *)NULL);
+ return NULL;
+ }
+ return (CoroutineData *)cmdPtr->objClientData;
+}
+
static int
-NRCoroInjectObjCmd(
- ClientData clientData,
+TclNRCoroInjectObjCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Command *cmdPtr;
CoroutineData *corPtr;
+
+ /*
+ * Usage more or less like tailcall:
+ * coroinject coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed.
+ */
+
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ return TCL_OK;
+}
+
+static int
+TclNRCoroProbeObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
/*
* Usage more or less like tailcall:
- * inject coroName cmd ?arg1 arg2 ...?
+ * coroprobe coroName cmd ?arg1 arg2 ...?
*/
if (objc < 3) {
@@ -9049,20 +10028,207 @@ NRCoroInjectObjCmd(
return TCL_ERROR;
}
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
- if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a probe command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
+ if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can only inject a command into a coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
- TclGetString(objv[1]), NULL);
+ "can only inject a probe command into a suspended coroutine",
+ TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL);
return TCL_ERROR;
}
- corPtr = cmdPtr->objClientData;
+ /*
+ * Add the callback to the coro's execEnv, so that it is the first thing
+ * to happen when the coro is resumed.
+ */
+
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+ iPtr->execEnvPtr = corPtr->eePtr;
+ TclNRAddCallback(interp, InjectHandler, corPtr,
+ Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
+ iPtr->execEnvPtr = savedEEPtr;
+
+ /*
+ * Now we immediately transfer control to the coroutine to run our probe.
+ * TRICKY STUFF copied from the [yield] implementation.
+ *
+ * Push the callback to restore the caller's context on yield back.
+ */
+
+ TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
+ NULL, NULL, NULL);
+
+ /*
+ * Record the stackLevel at which the resume is happening, then swap
+ * the interp's environment to make it suitable to run this coroutine.
+ */
+
+ corPtr->stackLevel = &corPtr;
+ Tcl_Size numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = iPtr->numLevels;
+
+ /*
+ * Do the actual stack swap.
+ */
+
+ SAVE_CONTEXT(corPtr->caller);
+ corPtr->callerEEPtr = iPtr->execEnvPtr;
+ RESTORE_CONTEXT(corPtr->running);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ iPtr->numLevels += numLevels;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InjectHandler, InjectHandlerPostProc --
+ *
+ * Part of the implementation of [coroinject] and [coroprobe]. These are
+ * run inside the context of the coroutine being injected/probed into.
+ *
+ * InjectHandler runs a script (possibly adding arguments) in the context
+ * of the coroutine. The script is specified as a one-shot list (with
+ * reference count equal to 1) in data[1]. This function also arranges
+ * for InjectHandlerPostProc to be the part that runs after the script
+ * completes.
+ *
+ * InjectHandlerPostProc cleans up after InjectHandler (deleting the
+ * list) and, for the [coroprobe] command *only*, yields back to the
+ * caller context (i.e., where [coroprobe] was run).
+ *s
+ *----------------------------------------------------------------------
+ */
+
+static int
+InjectHandler(
+ void *data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int) /*result*/)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
+ Tcl_Size nargs = PTR2INT(data[2]);
+ void *isProbe = data[3];
+ Tcl_Size objc;
+ Tcl_Obj **objv;
+
+ if (!isProbe) {
+ /*
+ * If this is [coroinject], add the extra arguments now.
+ */
+
+ if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yield", TCL_INDEX_NONE));
+ } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) {
+ Tcl_ListObjAppendElement(NULL, listPtr,
+ Tcl_NewStringObj("yieldto", TCL_INDEX_NONE));
+ } else {
+ /*
+ * I don't think this is reachable...
+ */
+ Tcl_Obj *nargsObj;
+ TclNewIndexObj(nargsObj, nargs);
+ Tcl_ListObjAppendElement(NULL, listPtr, nargsObj);
+ }
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp));
+ }
+
+ /*
+ * 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,
+ int result)
+{
+ CoroutineData *corPtr = (CoroutineData *)data[0];
+ Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
+ Tcl_Size nargs = PTR2INT(data[2]);
+ void *isProbe = data[3];
+
+ /*
+ * Delete the command words for what we just executed.
+ */
+
+ Tcl_DecrRefCount(listPtr);
+
+ /*
+ * If we were doing a probe, splice ourselves back out of the stack
+ * cleanly here. General injection should instead just look after itself.
+ *
+ * Code from guts of [yield] implementation.
+ */
+
+ if (isProbe) {
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (injected coroutine probe command)");
+ }
+ corPtr->nargs = nargs;
+ corPtr->stackLevel = NULL;
+ Tcl_Size numLevels = iPtr->numLevels;
+ iPtr->numLevels = corPtr->auxNumLevels;
+ corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRInjectObjCmd --
+ *
+ * Implementation of [::tcl::unsupported::inject] command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NRInjectObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CoroutineData *corPtr;
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
+
+ /*
+ * Usage more or less like tailcall:
+ * inject coroName cmd ?arg1 arg2 ...?
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?");
+ return TCL_ERROR;
+ }
+
+ corPtr = GetCoroutineFromObj(interp, objv[1],
+ "can only inject a command into a coroutine");
+ if (!corPtr) {
+ return TCL_ERROR;
+ }
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can only inject a command into a suspended coroutine", -1));
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
+ "can only inject a command into a suspended coroutine", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (void *)NULL);
return TCL_ERROR;
}
@@ -9081,7 +10247,7 @@ NRCoroInjectObjCmd(
int
TclNRInterpCoroutine(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9091,8 +10257,8 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
- Tcl_GetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
+ TclGetString(objv[0])));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", (void *)NULL);
return TCL_ERROR;
}
@@ -9112,11 +10278,11 @@ TclNRInterpCoroutine(
}
break;
default:
- if (corPtr->nargs != objc-1) {
+ if (corPtr->nargs + 1 != objc) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("wrong coro nargs; how did we get here? "
- "not implemented!", -1));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ "not implemented!", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
return TCL_ERROR;
}
/* fallthrough */
@@ -9145,7 +10311,7 @@ TclNRInterpCoroutine(
int
TclNRCoroutineObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -9170,14 +10336,14 @@ TclNRCoroutineObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
procName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", (void *)NULL);
return TCL_ERROR;
}
if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
procName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, (void *)NULL);
return TCL_ERROR;
}
@@ -9233,6 +10399,7 @@ TclNRCoroutineObjCmd(
corPtr->running.lineLABCPtr = corPtr->lineLABCPtr;
corPtr->stackLevel = NULL;
corPtr->auxNumLevels = 0;
+ corPtr->yieldPtr = NULL;
/*
* Create the coro's execEnv, switch to it to push the exit and coro
@@ -9278,7 +10445,7 @@ TclNRCoroutineObjCmd(
int
TclInfoCoroutineCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -9290,7 +10457,7 @@ TclInfoCoroutineCmd(
return TCL_ERROR;
}
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_Obj *namePtr;
TclNewObj(namePtr);
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 9836d02..9b59ee7 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -4,17 +4,18 @@
* This file contains the implementation of the "binary" Tcl built-in
* command and the Tcl binary data object.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 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 "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
+#include <assert.h>
/*
* The following constants are used by GetFormatSpec to indicate various
@@ -56,11 +57,14 @@
static void DupByteArrayInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
+static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr);
static int FormatNumber(Tcl_Interp *interp, int type,
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
+static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(const char **formatPtr, char *cmdPtr,
- int *countPtr, int *flagsPtr);
+ Tcl_Size *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
int flags, Tcl_HashTable **numberCachePtr);
static int SetByteArrayFromAny(Tcl_Interp *interp,
@@ -139,35 +143,80 @@ static const EnsembleImplMap decodeMap[] = {
};
/*
- * The following object type represents an array of bytes. An array of bytes
- * is not equivalent to an internationalized string. Conceptually, a string is
- * an array of 16-bit quantities organized as a sequence of properly formed
- * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
- * Accessor functions are provided to convert a ByteArray to a String or a
- * String to a ByteArray. Two or more consecutive bytes in an array of bytes
- * may look like a single UTF-8 character if the array is casually treated as
- * a string. But obtaining the String from a ByteArray is guaranteed to
- * produced properly formed UTF-8 sequences so that there is a one-to-one map
- * between bytes and characters.
- *
- * Converting a ByteArray to a String proceeds by casting each byte in the
- * array to a 16-bit quantity, treating that number as a Unicode character,
- * and storing the UTF-8 version of that Unicode character in the String. For
- * ByteArrays consisting entirely of values 1..127, the corresponding String
- * representation is the same as the ByteArray representation.
- *
- * Converting a String to a ByteArray proceeds by getting the Unicode
- * representation of each character in the String, casting it to a byte by
- * truncating the upper 8 bits, and then storing the byte in the ByteArray.
- * Converting from ByteArray to String and back to ByteArray is not lossy, but
- * converting an arbitrary String to a ByteArray may be.
+ * The following Tcl_ObjType represents an array of bytes. The intent is to
+ * allow arbitrary binary data to pass through Tcl as a Tcl value without loss
+ * or damage. Such values are useful for things like encoded strings or Tk
+ * images to name just two.
+ *
+ * It's strange to have two Tcl_ObjTypes in place for this task when one would
+ * do, so a bit of detail and history will aid understanding.
+ *
+ * A bytearray is an ordered sequence of bytes. Each byte is an integer value
+ * in the range [0-255]. To be a Tcl value type, we need a way to encode each
+ * value in the value set as a Tcl string. A simple encoding is to
+ * represent each byte value as the same codepoint value. A bytearray of N
+ * bytes is encoded into a Tcl string of N characters where the codepoint of
+ * each character is the value of corresponding byte. This approach creates a
+ * one-to-one map between all bytearray values and a subset of Tcl string
+ * values.
+ *
+ * When converting a Tcl string value to the bytearray internal rep, the
+ * question arises what to do with strings outside that subset? That is,
+ * those Tcl strings containing at least one codepoint greater than 255? The
+ * obviously correct answer is to raise an error! That string value does not
+ * represent any valid bytearray value.
+ *
+ * Unfortunately this was not the path taken by the authors of the original
+ * tclByteArrayType. They chose to accept all Tcl string values as acceptable
+ * string encodings of the bytearray values that result from masking away the
+ * high bits of any codepoint value at all. This meant that every bytearray
+ * value had multiple accepted string representations.
+ *
+ * The implications of this choice are truly ugly, and motivated the proposal
+ * of TIP 568 to migrate away from it and to the more sensible design where
+ * each bytearray value has only one string representation. Full details are
+ * recorded in that TIP for those who seek them.
+ *
+ * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation
+ * of bytearrays. Any Tcl value with the type properByteArrayType can have
+ * its bytearray value fetched and used with confidence that acting on that
+ * value is equivalent to acting on the true Tcl string value. This still
+ * implies a side testing burden -- past mistakes will not let us avoid that
+ * immediately, but it is at least a conventional test of type, and can be
+ * implemented entirely by examining the objPtr fields, with no need to query
+ * the internalrep, as a canonical flag would require. This benefit is made
+ * available to extensions through the public routine Tcl_GetBytesFromObj(),
+ * first available in Tcl 8.7.
+ *
+ * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength()
+ * must continue to follow their documented behavior through the 8.* series of
+ * releases. To support that legacy operation, we need a mechanism to retain
+ * compatibility with the deployed callers of the broken interface. That's
+ * what the retained "tclByteArrayType" provides. In those unusual
+ * circumstances where we convert an invalid bytearray value to a bytearray
+ * type, it is to this legacy type. Essentially any time this legacy type
+ * shows up, it's a signal of a bug being ignored.
+ *
+ * In Tcl 9, the incompatibility in the behavior of these public routines
+ * has been approved, and the legacy internal rep is no longer retained.
+ * The internal changes seen below are the limit of what can be done
+ * in a Tcl 8.* release. They provide a great expansion of the histories
+ * over which bytearray values can be useful.
*/
+static const Tcl_ObjType properByteArrayType = {
+ "bytearray",
+ FreeProperByteArrayInternalRep,
+ DupProperByteArrayInternalRep,
+ UpdateStringOfByteArray,
+ NULL
+};
+
const Tcl_ObjType tclByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
- UpdateStringOfByteArray,
+ NULL,
SetByteArrayFromAny
};
@@ -179,23 +228,31 @@ const Tcl_ObjType tclByteArrayType = {
*/
typedef struct ByteArray {
+ unsigned int bad; /* Index of first character that is a nonbyte.
+ * If all characters are bytes, bad = used. */
unsigned int used; /* The number of bytes used in the byte
- * array. */
- unsigned int allocated; /* The number of bytes allocated for storage
- * of the following "bytes" field. */
+ * array. Must be <= allocated. The bytes
+ * used to store the value are indexed from
+ * 0 to used-1. */
+ unsigned int allocated; /* The number of bytes of space allocated. */
unsigned char bytes[TCLFLEXARRAY];
/* The array of bytes. The actual size of this
- * field depends on the 'allocated' field
+ * field is stored in the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_SIZE(len) \
- (((unsigned)TclOffset(ByteArray, bytes) + (len)))
-#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
-#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
-
+ (offsetof(ByteArray, bytes) + (len))
+#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1)
+#define SET_BYTEARRAY(irPtr, baPtr) \
+ (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr)
+
+int
+TclIsPureByteArray(
+ Tcl_Obj * objPtr)
+{
+ return TclHasInternalRep(objPtr, &properByteArrayType);
+}
/*
*----------------------------------------------------------------------
@@ -206,7 +263,7 @@ typedef struct ByteArray {
* from the given array of bytes.
*
* Results:
- * The newly create object is returned. This object will have no initial
+ * The newly created object is returned. This object has no initial
* string representation. The returned object has a ref count of 0.
*
* Side effects:
@@ -221,16 +278,16 @@ Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
- int length) /* Length of the array of bytes, which must be
- * >= 0. */
+ int numBytes) /* Number of bytes in the array,
+ * must be >= 0. */
{
#ifdef TCL_MEM_DEBUG
- return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
+ return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetByteArrayObj(objPtr, bytes, length);
+ Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
return objPtr;
#endif /* TCL_MEM_DEBUG */
}
@@ -251,7 +308,7 @@ Tcl_NewByteArrayObj(
* result of calling Tcl_NewByteArrayObj.
*
* Results:
- * The newly create object is returned. This object will have no initial
+ * The newly created object is returned. This object has no initial
* string representation. The returned object has a ref count of 0.
*
* Side effects:
@@ -260,27 +317,37 @@ Tcl_NewByteArrayObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
- int length, /* Length of the array of bytes, which must be
- * >= 0. */
+ int numBytes, /* Number of bytes in the array,
+ * must be >= 0. */
const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
-#ifdef TCL_MEM_DEBUG
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetByteArrayObj(objPtr, bytes, length);
+ Tcl_SetByteArrayObj(objPtr, bytes, numBytes);
return objPtr;
+}
#else /* if not TCL_MEM_DEBUG */
- return Tcl_NewByteArrayObj(bytes, length);
-#endif /* TCL_MEM_DEBUG */
+Tcl_Obj *
+Tcl_DbNewByteArrayObj(
+ const unsigned char *bytes, /* The array of bytes used to initialize the
+ * new object. */
+ int numBytes, /* Number of bytes in the array,
+ * must be >= 0. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ return Tcl_NewByteArrayObj(bytes, numBytes);
}
+#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
@@ -304,30 +371,86 @@ void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new value.
- * May be NULL even if length > 0. */
- int length) /* Length of the array of bytes, which must
- * be >= 0. */
+ * May be NULL even if numBytes > 0. */
+ int numBytes) /* Number of bytes in the array,
+ * must be >= 0. */
{
ByteArray *byteArrayPtr;
+ Tcl_ObjInternalRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
- TclFreeIntRep(objPtr);
TclInvalidateStringRep(objPtr);
- if (length < 0) {
- length = 0;
+ assert(numBytes >= 0);
+ byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes));
+ byteArrayPtr->bad = numBytes;
+ byteArrayPtr->used = numBytes;
+ byteArrayPtr->allocated = numBytes;
+
+ if ((bytes != NULL) && (numBytes > 0)) {
+ memcpy(byteArrayPtr->bytes, bytes, numBytes);
}
- byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
- byteArrayPtr->used = length;
- byteArrayPtr->allocated = length;
+ SET_BYTEARRAY(&ir, byteArrayPtr);
- if ((bytes != NULL) && (length > 0)) {
- memcpy(byteArrayPtr->bytes, bytes, length);
+ Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBytesFromObj --
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned char *
+Tcl_GetBytesFromObj(
+ Tcl_Interp *interp, /* For error reporting */
+ Tcl_Obj *objPtr, /* Value to extract from */
+ int *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
+{
+ ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ if (interp) {
+ const char *nonbyte;
+ int ucs4;
+
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ baPtr = GET_BYTEARRAY(irPtr);
+ nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
+ Tcl_UtfToUniChar(nonbyte, &ucs4);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected byte sequence but character %d "
+ "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL);
+ }
+ return NULL;
+ }
}
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
+ }
+ return baPtr->bytes;
}
/*
@@ -351,18 +474,24 @@ Tcl_SetByteArrayObj(
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
- int *lengthPtr) /* If non-NULL, filled with length of the
- * array of bytes in the ByteArray object. */
+ Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes
+ * in the array here */
{
ByteArray *baPtr;
+ const Tcl_ObjInternalRep *irPtr;
+ unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr);
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+ if (result) {
+ return result;
}
- baPtr = GET_BYTEARRAY(objPtr);
- if (lengthPtr != NULL) {
- *lengthPtr = baPtr->used;
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ assert(irPtr != NULL);
+
+ baPtr = GET_BYTEARRAY(irPtr);
+
+ if (numBytesPtr != NULL) {
+ *numBytesPtr = baPtr->used;
}
return (unsigned char *) baPtr->bytes;
}
@@ -392,27 +521,44 @@ Tcl_GetByteArrayFromObj(
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
- int length) /* New length for internal byte array. */
+ int numBytes) /* Number of bytes in resized array */
{
ByteArray *byteArrayPtr;
+ unsigned newLength;
+ Tcl_ObjInternalRep *irPtr;
+
+ assert(numBytes >= 0);
+ newLength = (unsigned int)numBytes;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
- }
- if (length < 0) {
- length = 0;
+
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- if ((unsigned int)length > byteArrayPtr->allocated) {
- byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
- byteArrayPtr->allocated = length;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+
+ /* Note that during truncation, the implementation does not free
+ * memory that is no longer needed. */
+
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
+ if (newLength > byteArrayPtr->allocated) {
+ byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength));
+ byteArrayPtr->allocated = newLength;
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
- byteArrayPtr->used = length;
+ objPtr->typePtr = &properByteArrayType;
+ byteArrayPtr->bad = newLength;
+ byteArrayPtr->used = newLength;
return byteArrayPtr->bytes;
}
@@ -434,32 +580,51 @@ Tcl_SetByteArrayLength(
static int
SetByteArrayFromAny(
- Tcl_Interp *interp, /* Not used. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- int length;
+ int length, bad;
const char *src, *srcEnd;
unsigned char *dst;
- ByteArray *byteArrayPtr;
Tcl_UniChar ch = 0;
+ ByteArray *byteArrayPtr;
+ Tcl_ObjInternalRep ir;
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(objPtr, &length);
- srcEnd = src + length;
+ if (TclHasInternalRep(objPtr, &properByteArrayType)) {
+ return TCL_OK;
+ }
+ if (TclHasInternalRep(objPtr, &tclByteArrayType)) {
+ return TCL_OK;
+ }
+
+ src = TclGetStringFromObj(objPtr, &length);
+ bad = length;
+ srcEnd = src + length;
- byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
- for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
- src += TclUtfToUniChar(src, &ch);
- *dst++ = UCHAR(ch);
+ /* Note the allocation is over-sized, possibly by a factor of four,
+ * or even a factor of two with a proper byte array value. */
+
+ byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
+ src += TclUtfToUniChar(src, &ch);
+ if ((bad == length) && (ch > 255)) {
+ bad = dst - byteArrayPtr->bytes;
}
+ *dst++ = UCHAR(ch);
+ }
- byteArrayPtr->used = dst - byteArrayPtr->bytes;
- byteArrayPtr->allocated = length;
+ SET_BYTEARRAY(&ir, byteArrayPtr);
+ byteArrayPtr->allocated = length;
+ byteArrayPtr->used = dst - byteArrayPtr->bytes;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ if (bad == length) {
+ byteArrayPtr->bad = byteArrayPtr->used;
+ Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir);
+ } else {
+ byteArrayPtr->bad = bad;
+ Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir);
}
+
return TCL_OK;
}
@@ -484,8 +649,14 @@ static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ckfree(GET_BYTEARRAY(objPtr));
- objPtr->typePtr = NULL;
+ ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType)));
+}
+
+static void
+FreeProperByteArrayInternalRep(
+ Tcl_Obj *objPtr) /* Object with internal rep to free. */
+{
+ ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType)));
}
/*
@@ -512,17 +683,41 @@ DupByteArrayInternalRep(
{
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjInternalRep ir;
- srcArrayPtr = GET_BYTEARRAY(srcPtr);
+ srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
- SET_BYTEARRAY(copyPtr, copyArrayPtr);
- copyPtr->typePtr = &tclByteArrayType;
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir);
+}
+
+static void
+DupProperByteArrayInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ unsigned int length;
+ ByteArray *srcArrayPtr, *copyArrayPtr;
+ Tcl_ObjInternalRep ir;
+
+ srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType));
+ length = srcArrayPtr->used;
+
+ copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
+ copyArrayPtr->bad = length;
+ copyArrayPtr->used = length;
+ copyArrayPtr->allocated = length;
+ memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
+
+ SET_BYTEARRAY(&ir, copyArrayPtr);
+ Tcl_StoreInternalRep(copyPtr, &properByteArrayType, &ir);
}
/*
@@ -530,9 +725,7 @@ DupByteArrayInternalRep(
*
* UpdateStringOfByteArray --
*
- * Update the string representation for a ByteArray data object. Note:
- * This procedure does not invalidate an existing old string rep so
- * storage will be lost if this has not already been done.
+ * Update the string representation for a ByteArray data object.
*
* Results:
* None.
@@ -541,9 +734,6 @@ DupByteArrayInternalRep(
* The object's string is set to a valid string that results from the
* ByteArray-to-string conversion.
*
- * The object becomes a string object -- the internal rep is discarded
- * and the typePtr becomes NULL.
- *
*----------------------------------------------------------------------
*/
@@ -552,20 +742,16 @@ UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
- unsigned int i, length, size;
- unsigned char *src;
- char *dst;
- ByteArray *byteArrayPtr;
-
- byteArrayPtr = GET_BYTEARRAY(objPtr);
- src = byteArrayPtr->bytes;
- length = byteArrayPtr->used;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
+ unsigned char *src = byteArrayPtr->bytes;
+ unsigned int i, length = byteArrayPtr->used;
+ unsigned int size = length;
/*
* How much space will string rep need?
*/
- size = length;
for (i = 0; i < length && size <= INT_MAX; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
@@ -575,18 +761,17 @@ UpdateStringOfByteArray(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- dst = (char *)ckalloc(size + 1U);
- objPtr->bytes = dst;
- objPtr->length = size;
-
if (size == length) {
- memcpy(dst, src, size);
- dst[size] = '\0';
+ char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);
+
+ TclOOM(dst, size);
} else {
+ char *dst = Tcl_InitStringRep(objPtr, NULL, size);
+
+ TclOOM(dst, size);
for (i = 0; i < length; i++) {
dst += Tcl_UniCharToUtf(src[i], dst);
}
- *dst = '\0';
}
}
@@ -616,7 +801,8 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
- unsigned int needed;
+ unsigned int length, needed;
+ Tcl_ObjInternalRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -632,16 +818,27 @@ TclAppendBytesToByteArray(
return;
}
- if (objPtr->typePtr != &tclByteArrayType) {
- SetByteArrayFromAny(NULL, objPtr);
+
+ length = (unsigned int) len;
+
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ if (irPtr == NULL) {
+ SetByteArrayFromAny(NULL, objPtr);
+ irPtr = TclFetchInternalRep(objPtr, &properByteArrayType);
+ if (irPtr == NULL) {
+ irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType);
+ }
+ }
}
- byteArrayPtr = GET_BYTEARRAY(objPtr);
+ byteArrayPtr = GET_BYTEARRAY(irPtr);
- if ((unsigned int)len > INT_MAX - byteArrayPtr->used) {
+ if (length > INT_MAX - byteArrayPtr->used) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- needed = byteArrayPtr->used + len;
+ needed = byteArrayPtr->used + length;
/*
* If we need to, resize the allocated space in the byte array.
*/
@@ -664,7 +861,7 @@ TclAppendBytesToByteArray(
*/
unsigned int limit = INT_MAX - needed;
- unsigned int extra = len + TCL_MIN_GROWTH;
+ unsigned int extra = length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
@@ -680,14 +877,15 @@ TclAppendBytesToByteArray(
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
- memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
+ memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length);
}
- byteArrayPtr->used += len;
+ byteArrayPtr->used += length;
TclInvalidateStringRep(objPtr);
+ objPtr->typePtr = &properByteArrayType;
}
/*
@@ -737,7 +935,7 @@ TclInitBinaryCmd(
static int
BinaryFormatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -861,11 +1059,10 @@ BinaryFormatCmd(
* The macro evals its args more than once: avoid arg++
*/
- if (TclListObjGetElements(interp, objv[arg], &listc,
- &listv) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[arg], &listc
+ ) != TCL_OK) {
return TCL_ERROR;
}
- arg++;
if (count == BINARY_ALL) {
count = listc;
@@ -875,6 +1072,11 @@ BinaryFormatCmd(
-1));
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, objv[arg], &listc,
+ &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
}
offset += count*size;
break;
@@ -1143,7 +1345,7 @@ BinaryFormatCmd(
listc = 1;
count = 1;
} else {
- TclListObjGetElements(interp, objv[arg], &listc, &listv);
+ TclListObjGetElementsM(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
@@ -1209,11 +1411,11 @@ BinaryFormatCmd(
badField:
{
- int ch;
- char buf[8] = "";
+ Tcl_UniChar ch = 0;
+ char buf[5] = "";
- TclUtfToUCS4(errorString, &ch);
- buf[TclUCS4ToUtf(ch, buf)] = '\0';
+ TclUtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
@@ -1242,7 +1444,7 @@ BinaryFormatCmd(
static int
BinaryScanCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1260,9 +1462,8 @@ BinaryScanCmd(
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
- int offset, size, length;
+ int offset, size, length, i;
- int i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
@@ -1286,7 +1487,8 @@ BinaryScanCmd(
}
switch (cmd) {
case 'a':
- case 'A': {
+ case 'A':
+ case 'C': {
unsigned char *src;
if (arg >= objc) {
@@ -1308,10 +1510,18 @@ BinaryScanCmd(
size = count;
/*
- * Trim trailing nulls and spaces, if necessary.
+ * Apply C string semantics or trim trailing
+ * nulls and spaces, if necessary.
*/
- if (cmd == 'A') {
+ if (cmd == 'C') {
+ for (i = 0; i < size; i++) {
+ if (src[i] == '\0') {
+ size = i;
+ break;
+ }
+ }
+ } else if (cmd == 'A') {
while (size > 0) {
if (src[size - 1] != '\0' && src[size - 1] != ' ') {
break;
@@ -1564,7 +1774,7 @@ BinaryScanCmd(
*/
done:
- Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3));
DeleteScanNumberCache(numberCachePtr);
return TCL_OK;
@@ -1579,11 +1789,11 @@ BinaryScanCmd(
badField:
{
- int ch;
- char buf[8] = "";
+ Tcl_UniChar ch = 0;
+ char buf[5] = "";
- TclUtfToUCS4(errorString, &ch);
- buf[TclUCS4ToUtf(ch, buf)] = '\0';
+ TclUtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
@@ -1852,7 +2062,7 @@ CopyNumber(
*
* FormatNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to format a number into a
+ * This routine is called by BinaryFormatCmd to format a number into a
* location pointed at by cursor.
*
* Results:
@@ -1872,7 +2082,6 @@ FormatNumber(
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
- long value;
double dvalue;
Tcl_WideInt wvalue;
float fvalue;
@@ -1888,10 +2097,11 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
@@ -1907,10 +2117,12 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- if (src->typePtr != &tclDoubleType) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
+
+ if (irPtr == NULL) {
return TCL_ERROR;
}
- dvalue = src->internalRep.doubleValue;
+ dvalue = irPtr->doubleValue;
}
/*
@@ -1920,7 +2132,11 @@ FormatNumber(
*/
if (fabs(dvalue) > (double) FLT_MAX) {
+ if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) {
+ fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99
+ } else {
fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ }
} else {
fvalue = (float) dvalue;
}
@@ -1934,7 +2150,7 @@ FormatNumber(
case 'w':
case 'W':
case 'm':
- if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -1964,19 +2180,19 @@ FormatNumber(
case 'i':
case 'I':
case 'n':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 24);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -1986,15 +2202,15 @@ FormatNumber(
case 's':
case 'S':
case 't':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2002,10 +2218,10 @@ FormatNumber(
* 8-bit integer values.
*/
case 'c':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue);
return TCL_OK;
default:
@@ -2019,7 +2235,7 @@ FormatNumber(
*
* ScanNumber --
*
- * This routine is called by Tcl_BinaryObjCmd to scan a number out of a
+ * This routine is called by BinaryScanCmd to scan a number out of a
* buffer.
*
* Results:
@@ -2131,7 +2347,7 @@ ScanNumber(
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
@@ -2142,8 +2358,9 @@ ScanNumber(
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
- Tcl_Obj *objPtr = Tcl_NewLongObj(value);
+ Tcl_Obj *objPtr;
+ TclNewIntObj(objPtr, value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
@@ -2160,7 +2377,7 @@ ScanNumber(
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
- return Tcl_NewLongObj(value);
+ return Tcl_NewWideIntObj(value);
}
/*
@@ -2194,8 +2411,9 @@ ScanNumber(
Tcl_Obj *bigObj = NULL;
mp_int big;
- TclBNInitBignumFromWideUInt(&big, uwvalue);
- bigObj = Tcl_NewBignumObj(&big);
+ if (mp_init_u64(&big, uwvalue) == MP_OKAY) {
+ bigObj = Tcl_NewBignumObj(&big);
+ }
return bigObj;
}
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
@@ -2307,7 +2525,7 @@ DeleteScanNumberCache(
static int
BinaryEncodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2351,7 +2569,7 @@ BinaryEncodeHex(
static int
BinaryDecodeHex(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2359,8 +2577,8 @@ BinaryDecodeHex(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
- int i, index, value, size, pure, count = 0, cut = 0, strict = 0;
- Tcl_UniChar ch = 0;
+ int i, index, value, size, pure = 1, count = 0, cut = 0, strict = 0;
+ int ucs4;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2381,9 +2599,12 @@ BinaryDecodeHex(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -2396,7 +2617,7 @@ BinaryDecodeHex(
}
c = *data++;
- if (!isxdigit((int) c)) {
+ if (!isxdigit(UCHAR(c))) {
if (strict || !TclIsSpaceProc(c)) {
goto badChar;
}
@@ -2429,15 +2650,15 @@ BinaryDecodeHex(
badChar:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid hexadecimal digit \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
- Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
+ "invalid hexadecimal digit \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL);
return TCL_ERROR;
}
@@ -2472,14 +2693,14 @@ BinaryDecodeHex(
static int
BinaryEncode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *limit;
- int maxlen = 0;
+ Tcl_WideInt maxlen = 0;
const char *wrapchar = "\n";
int wrapcharlen = 1;
int offset, i, index, size, outindex = 0, count = 0, purewrap = 1;
@@ -2498,24 +2719,23 @@ BinaryEncode64(
}
switch (index) {
case OPT_MAXLEN:
- if (Tcl_GetIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) {
return TCL_ERROR;
}
if (maxlen < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
- "LINE_LENGTH", NULL);
+ "LINE_LENGTH", (void *)NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
- purewrap = TclIsPureByteArray(objv[i + 1]);
- if (purewrap) {
- wrapchar = (const char *) Tcl_GetByteArrayFromObj(
- objv[i + 1], &wrapcharlen);
- } else {
- wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen);
+ wrapchar = (const char *)Tcl_GetBytesFromObj(NULL,
+ objv[i + 1], &wrapcharlen);
+ if (wrapchar == NULL) {
+ purewrap = 0;
+ wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
@@ -2595,7 +2815,7 @@ BinaryEncode64(
static int
BinaryEncodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2631,7 +2851,7 @@ BinaryEncodeUu(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
- "LINE_LENGTH", NULL);
+ "LINE_LENGTH", (void *)NULL);
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
@@ -2660,7 +2880,7 @@ BinaryEncodeUu(
"invalid wrapchar; will defeat decoding",
-1));
Tcl_SetErrorCode(interp, "TCL", "BINARY",
- "ENCODE", "WRAPCHAR", NULL);
+ "ENCODE", "WRAPCHAR", (void *)NULL);
return TCL_ERROR;
}
}
@@ -2744,7 +2964,7 @@ BinaryEncodeUu(
static int
BinaryDecodeUu(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2752,9 +2972,9 @@ BinaryDecodeUu(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
- int i, index, size, pure, count = 0, strict = 0, lineLen;
+ int i, index, size, pure = 1, count = 0, strict = 0, lineLen;
unsigned char c;
- Tcl_UniChar ch = 0;
+ int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2775,9 +2995,12 @@ BinaryDecodeUu(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -2878,20 +3101,20 @@ BinaryDecodeUu(
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
- Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (void *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid uuencode character \"%c\" at position %d",
- ch, (int) (data - datastart - 1)));
- Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
+ "invalid uuencode character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
@@ -2914,7 +3137,7 @@ BinaryDecodeUu(
static int
BinaryDecode64(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2923,9 +3146,9 @@ BinaryDecode64(
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
- int pure, strict = 0;
+ int pure = 1, strict = 0;
int i, index, size, cut = 0, count = 0;
- Tcl_UniChar ch = 0;
+ int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
@@ -2946,9 +3169,12 @@ BinaryDecode64(
}
TclNewObj(resultObj);
- pure = TclIsPureByteArray(objv[objc - 1]);
- datastart = data = pure ? Tcl_GetByteArrayFromObj(objv[objc - 1], &count)
- : (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
+ if (data == NULL) {
+ pure = 0;
+ data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ }
+ datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -3050,20 +3276,20 @@ BinaryDecode64(
bad64:
if (pure) {
- ch = c;
+ ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
- TclUtfToUniChar((const char *)(data - 1), &ch);
+ Tcl_UtfToUniChar((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid base64 character \"%c\" at position %d", ch,
- (int) (data - datastart - 1)));
- Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
+ "invalid base64 character \"%c\" (U+%06X) at position %d",
+ ucs4, ucs4, (int) (data - datastart - 1)));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 6e7e7e4..f0c625f 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -5,9 +5,9 @@
* problems involving overwritten, double freeing memory and loss of
* memory.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -33,15 +33,15 @@
* "memory tag" command is invoked, to hold the current tag.
*/
-typedef struct MemTag {
- int refCount; /* Number of mem_headers referencing this
+typedef struct {
+ size_t refCount; /* Number of mem_headers referencing this
* tag. */
- char string[1]; /* Actual size of string will be as large as
+ char string[TCLFLEXARRAY]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
-#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1U) + (bytesInString)))
+#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1U) + (bytesInString))
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,26 +52,26 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* to help detect chunk under-runs.
*/
-#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
+#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8)
struct mem_header {
struct mem_header *flink;
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
const char *file;
- long length;
+ size_t length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
/* Aligns body on 8-byte boundary, plus
* provides at least 8 additional guard bytes
* to detect underruns. */
- char body[1]; /* First byte of client's space. Actual size
+ char body[TCLFLEXARRAY]; /* First byte of client's space. Actual size
* of this field will be larger than one. */
};
static struct mem_header *allocHead = NULL; /* List of allocated structures */
-#define GUARD_VALUE 0141
+#define GUARD_VALUE 0x61
/*
* The following macro determines the amount of guard space *above* each chunk
@@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */
#define BODY_OFFSET \
((size_t) (&((struct mem_header *) 0)->body))
-static int total_mallocs = 0;
-static int total_frees = 0;
+static size_t total_mallocs = 0;
+static size_t total_frees = 0;
static size_t current_bytes_malloced = 0;
static size_t maximum_bytes_malloced = 0;
-static int current_malloc_packets = 0;
-static int maximum_malloc_packets = 0;
-static int break_on_malloc = 0;
-static int trace_on_at_malloc = 0;
+static size_t current_malloc_packets = 0;
+static size_t maximum_malloc_packets = 0;
+static size_t break_on_malloc = 0;
+static size_t trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
@@ -128,24 +128,13 @@ static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
- * Prototypes for procedures defined in this file:
- */
-
-static int CheckmemCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
-static int MemoryCmd(ClientData clientData, Tcl_Interp *interp,
- int argc, const char *argv[]);
-static void ValidateMemory(struct mem_header *memHeaderP,
- const char *file, int line, int nukeGuards);
-
-/*
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
*
* Initialize the locks used by the allocator. This is only appropriate
* to call in a single threaded environment, such as during
- * TclInitSubsystems.
+ * Tcl_InitSubsystems.
*
*----------------------------------------------------------------------
*/
@@ -156,7 +145,7 @@ TclInitDbCkalloc(void)
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/* Silence compiler warning */
(void)ckallocMutexPtr;
#endif
@@ -175,7 +164,7 @@ TclInitDbCkalloc(void)
int
TclDumpMemoryInfo(
- ClientData clientData,
+ void *clientData,
int flags)
{
char buf[1024];
@@ -184,18 +173,18 @@ TclDumpMemoryInfo(
return 0;
}
snprintf(buf, sizeof(buf),
- "total mallocs %10d\n"
- "total frees %10d\n"
- "current packets allocated %10d\n"
- "current bytes allocated %10lu\n"
- "maximum packets allocated %10d\n"
- "maximum bytes allocated %10lu\n",
+ "total mallocs %10" TCL_Z_MODIFIER "u\n"
+ "total frees %10" TCL_Z_MODIFIER "u\n"
+ "current packets allocated %10" TCL_Z_MODIFIER "u\n"
+ "current bytes allocated %10" TCL_Z_MODIFIER "u\n"
+ "maximum packets allocated %10" TCL_Z_MODIFIER "u\n"
+ "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n",
total_mallocs,
total_frees,
current_malloc_packets,
- (unsigned long)current_bytes_malloced,
+ current_bytes_malloced,
maximum_malloc_packets,
- (unsigned long)maximum_bytes_malloced);
+ maximum_bytes_malloced);
if (flags == 0) {
fprintf((FILE *)clientData, "%s", buf);
} else {
@@ -245,16 +234,16 @@ ValidateMemory(
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
- fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte,
+ fprintf(stderr, "low guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
- TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "low guard failed at %lx, %s %d\n",
- (unsigned long)(size_t)memHeaderP->body, file, line);
+ TclDumpMemoryInfo(stderr, 0);
+ fprintf(stderr, "low guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -266,17 +255,17 @@ ValidateMemory(
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
- fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", (int)idx, byte,
+ fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
- TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "high guard failed at %lx, %s %d\n",
- (unsigned long)(size_t)memHeaderP->body, file, line);
+ TclDumpMemoryInfo(stderr, 0);
+ fprintf(stderr, "high guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
@@ -359,9 +348,8 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
- fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
- (unsigned long)(size_t)address,
- (unsigned long)(size_t)address + memScanP->length - 1,
+ fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s",
+ address, address + memScanP->length - 1,
memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
@@ -405,13 +393,13 @@ Tcl_DbCkalloc(
}
/* Don't let size argument to TclpAlloc overflow */
- if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
+ if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) {
result = (struct mem_header *) TclpAlloc(size +
- sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
- TclDumpMemoryInfo((ClientData) stderr, 0);
+ TclDumpMemoryInfo(stderr, 0);
Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
@@ -423,7 +411,7 @@ Tcl_DbCkalloc(
if (init_malloced_bodies) {
memset(result, GUARD_VALUE,
- size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size);
} else {
memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
@@ -450,7 +438,7 @@ Tcl_DbCkalloc(
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
- fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -458,14 +446,14 @@ Tcl_DbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (unsigned long)(size_t)result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
+ Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
}
current_malloc_packets++;
@@ -495,13 +483,13 @@ Tcl_AttemptDbCkalloc(
}
/* Don't let size argument to TclpAlloc overflow */
- if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
+ if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) {
result = (struct mem_header *) TclpAlloc(size +
- sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
- TclDumpMemoryInfo((ClientData) stderr, 0);
+ TclDumpMemoryInfo(stderr, 0);
return NULL;
}
@@ -512,7 +500,7 @@ Tcl_AttemptDbCkalloc(
*/
if (init_malloced_bodies) {
memset(result, GUARD_VALUE,
- size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size);
} else {
memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
@@ -539,7 +527,7 @@ Tcl_AttemptDbCkalloc(
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
- fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -547,14 +535,14 @@ Tcl_AttemptDbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (unsigned long)(size_t)result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
+ Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
}
current_malloc_packets++;
@@ -612,8 +600,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %lx %ld %s %d\n",
- (unsigned long)(size_t)memp->body, memp->length, file, line);
+ fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n",
+ memp->body, memp->length, file, line);
}
if (validate_memory) {
@@ -631,9 +619,8 @@ Tcl_DbCkfree(
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
- memp->tagPtr->refCount--;
- if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
- TclpFree((char *) memp->tagPtr);
+ if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
+ TclpFree(memp->tagPtr);
}
}
@@ -650,7 +637,7 @@ Tcl_DbCkfree(
if (allocHead == memp) {
allocHead = memp->flink;
}
- TclpFree((char *) memp);
+ TclpFree(memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
@@ -675,7 +662,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,10 +676,10 @@ Tcl_DbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
- newPtr = Tcl_DbCkalloc(size, file, line);
+ newPtr = (char *)Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
@@ -706,7 +693,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,10 +707,10 @@ Tcl_AttemptDbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
- newPtr = Tcl_AttemptDbCkalloc(size, file, line);
+ newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line);
if (newPtr == NULL) {
return NULL;
}
@@ -808,13 +795,12 @@ Tcl_AttemptRealloc(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
MemoryCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int argc,
- const char *argv[])
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
@@ -822,20 +808,17 @@ MemoryCmd(
int result;
size_t len;
- if (argc < 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s option [args..]\"", argv[0]));
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option [args..]");
return TCL_ERROR;
}
- if (strcmp(argv[1], "active") == 0 || strcmp(argv[1], "display") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s file\"",
- argv[0], argv[1]));
+ if (strcmp(TclGetString(objv[1]), "active") == 0 || strcmp(TclGetString(objv[1]), "display") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -843,44 +826,45 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
- argv[2], Tcl_PosixError(interp)));
+ TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
- if (strcmp(argv[1],"break_on_malloc") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
+ Tcl_WideInt value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ break_on_malloc = value;
return TCL_OK;
}
- if (strcmp(argv[1],"info") == 0) {
+ if (strcmp(TclGetString(objv[1]),"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
+ "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
- "current bytes allocated", (unsigned long)current_bytes_malloced,
+ "current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
- "maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
+ "maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
- if (strcmp(argv[1], "init") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]), "init") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- init_malloced_bodies = (strcmp(argv[2],"on") == 0);
+ init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1], "objs") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s objs file\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]), "objs") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -896,13 +880,12 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
return TCL_OK;
}
- if (strcmp(argv[1],"onexit") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s onexit file\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]),"onexit") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
- fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
@@ -911,60 +894,59 @@ MemoryCmd(
Tcl_DStringFree(&buffer);
return TCL_OK;
}
- if (strcmp(argv[1],"tag") == 0) {
- if (argc != 3) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s tag string\"", argv[0]));
+ if (strcmp(TclGetString(objv[1]),"tag") == 0) {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
- TclpFree((char *) curTagPtr);
+ TclpFree(curTagPtr);
}
- len = strlen(argv[2]);
+ len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
- memcpy(curTagPtr->string, argv[2], len + 1);
+ memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
- if (strcmp(argv[1],"trace") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"trace") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- alloc_tracing = (strcmp(argv[2],"on") == 0);
+ alloc_tracing = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
- if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) {
+ Tcl_WideInt value;
+ if (objc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ trace_on_at_malloc = value;
return TCL_OK;
}
- if (strcmp(argv[1],"validate") == 0) {
- if (argc != 3) {
+ if (strcmp(TclGetString(objv[1]),"validate") == 0) {
+ if (objc != 3) {
goto bad_suboption;
}
- validate_memory = (strcmp(argv[2],"on") == 0);
+ validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
- argv[1]));
+ TclGetString(objv[1])));
return TCL_ERROR;
argError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s count\"", argv[0], argv[1]));
+ Tcl_WrongNumArgs(interp, 2, objv, "count");
return TCL_ERROR;
bad_suboption:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s %s on|off\"", argv[0], argv[1]));
+ Tcl_WrongNumArgs(interp, 2, objv, "on|off");
return TCL_ERROR;
}
@@ -985,21 +967,19 @@ MemoryCmd(
*
*----------------------------------------------------------------------
*/
-
static int
CheckmemCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for evaluation. */
- int argc, /* Number of arguments. */
- const char *argv[]) /* String values of arguments. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
- if (argc != 2) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "wrong # args: should be \"%s fileName\"", argv[0]));
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
- strcpy(tclMemDumpFileName, argv[1]);
+ strcpy(tclMemDumpFileName, TclGetString(objv[1]));
return TCL_OK;
}
@@ -1025,8 +1005,8 @@ Tcl_InitMemory(
* added */
{
TclInitDbCkalloc();
- Tcl_CreateCommand(interp, "memory", MemoryCmd, NULL, NULL);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
@@ -1054,9 +1034,7 @@ char *
Tcl_Alloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
+ char *result = (char *)TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so that NULL
@@ -1080,9 +1058,7 @@ Tcl_DbCkalloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpAlloc(size);
+ char *result = (char *)TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1106,24 +1082,16 @@ char *
Tcl_AttemptAlloc(
unsigned int size)
{
- char *result;
-
- result = TclpAlloc(size);
- return result;
+ return (char *)TclpAlloc(size);
}
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- char *result;
- (void)file;
- (void)line;
-
- result = (char *) TclpAlloc(size);
- return result;
+ return (char *)TclpAlloc(size);
}
/*
@@ -1142,9 +1110,7 @@ Tcl_Realloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
+ char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %u bytes", size);
@@ -1159,9 +1125,7 @@ Tcl_DbCkrealloc(
const char *file,
int line)
{
- char *result;
-
- result = (char *) TclpRealloc(ptr, size);
+ char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
@@ -1186,25 +1150,17 @@ Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
- char *result;
-
- result = TclpRealloc(ptr, size);
- return result;
+ return (char *)TclpRealloc(ptr, size);
}
char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- char *result;
- (void)file;
- (void)line;
-
- result = (char *) TclpRealloc(ptr, size);
- return result;
+ return (char *)TclpRealloc(ptr, size);
}
/*
@@ -1229,11 +1185,9 @@ Tcl_Free(
void
Tcl_DbCkfree(
char *ptr,
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- (void)file;
- (void)line;
TclpFree(ptr);
}
@@ -1247,38 +1201,31 @@ Tcl_DbCkfree(
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
void
Tcl_InitMemory(
- Tcl_Interp *interp)
+ TCL_UNUSED(Tcl_Interp *) /*interp*/)
{
- (void)interp;
}
int
Tcl_DumpActiveMemory(
- const char *fileName)
+ TCL_UNUSED(const char *) /*fileName*/)
{
- (void)fileName;
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
- const char *file,
- int line)
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- (void)file;
- (void)line;
}
int
TclDumpMemoryInfo(
- ClientData clientData,
- int flags)
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*flags*/)
{
- (void)clientData;
- (void)flags;
return 1;
}
@@ -1316,7 +1263,7 @@ TclFinalizeMemorySubsystem(void)
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
- TclpFree((char *) curTagPtr);
+ TclpFree(curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 7d54edd..228937e 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -5,15 +5,16 @@
* the time and date facilities of TclX, by Mark Diekhans and Karl
* Lehenbauer.
*
- * Copyright (c) 1991-1995 Karl Lehenbauer & Mark Diekhans.
- * Copyright (c) 1995 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans.
+ * Copyright © 1995 Sun Microsystems, Inc.
+ * Copyright © 2004 Kevin B. Kenny. 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 "tclTomMath.h"
/*
* Windows has mktime. The configurators do not check.
@@ -109,7 +110,7 @@ typedef struct TclDateFields {
* Greenwich */
Tcl_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
- enum {BCE=1, CE=0} era; /* Era */
+ int isBce; /* 1 if BCE */
int gregorian; /* Flag == 1 if the date is Gregorian */
int year; /* Year of the era */
int dayOfYear; /* Day of the year (1 January == 1) */
@@ -160,39 +161,19 @@ static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int);
static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int);
static int IsGregorianLeapYear(TclDateFields *);
static int WeekdayOnOrBefore(int, int);
-static int ClockClicksObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockConvertlocaltoutcObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetdatefieldsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetjuliandayfromerayearmonthdayObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetjuliandayfromerayearweekdayObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockGetenvObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockMicrosecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockMillisecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockParseformatargsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int ClockSecondsObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ClockClicksObjCmd;
+static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd;
+static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd;
+static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd;
+static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd;
+static Tcl_ObjCmdProc ClockGetenvObjCmd;
+static Tcl_ObjCmdProc ClockMicrosecondsObjCmd;
+static Tcl_ObjCmdProc ClockMillisecondsObjCmd;
+static Tcl_ObjCmdProc ClockParseformatargsObjCmd;
+static Tcl_ObjCmdProc ClockSecondsObjCmd;
static struct tm * ThreadSafeLocalTime(const time_t *);
static void TzsetIfNecessary(void);
-static void ClockDeleteCmdProc(ClientData);
+static void ClockDeleteCmdProc(void *);
/*
* Structure containing description of "native" clock commands to create.
@@ -331,7 +312,7 @@ TclClockInit(
static int
ClockConvertlocaltoutcObjCmd(
- ClientData clientData, /* Client data */
+ void *clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -423,7 +404,7 @@ ClockConvertlocaltoutcObjCmd(
int
ClockGetdatefieldsObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -452,7 +433,7 @@ ClockGetdatefieldsObjCmd(
* that it isn't.
*/
- if (objv[1]->typePtr == &tclBignumType) {
+ if (TclHasInternalRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
@@ -490,27 +471,27 @@ ClockGetdatefieldsObjCmd(
Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET],
- Tcl_NewIntObj(fields.tzOffset));
+ Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN],
- Tcl_NewIntObj(fields.gregorian));
+ Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, lit[LIT_ERA],
- lit[fields.era ? LIT_BCE : LIT_CE]);
+ lit[fields.isBce ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR],
- Tcl_NewIntObj(fields.year));
+ Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR],
- Tcl_NewIntObj(fields.dayOfYear));
+ Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH],
- Tcl_NewIntObj(fields.month));
+ Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH],
- Tcl_NewIntObj(fields.dayOfMonth));
+ Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR],
- Tcl_NewIntObj(fields.iso8601Year));
+ Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
- Tcl_NewIntObj(fields.iso8601Week));
+ Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
- Tcl_NewIntObj(fields.dayOfWeek));
+ Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
@@ -579,7 +560,7 @@ FetchIntField(
static int
ClockGetjuliandayfromerayearmonthdayObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -591,7 +572,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -602,7 +583,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
return TCL_ERROR;
}
dict = objv[1];
- if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK
+ if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month)
@@ -612,7 +593,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -630,7 +611,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
@@ -663,7 +644,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd(
static int
ClockGetjuliandayfromerayearweekdayObjCmd(
- ClientData clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
@@ -675,7 +656,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
int changeover;
int copied = 0;
int status;
- int era = 0;
+ int isBce = 0;
/*
* Check params.
@@ -686,7 +667,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
return TCL_ERROR;
}
dict = objv[1];
- if (FetchEraField(interp, dict, lit[LIT_ERA], &era) != TCL_OK
+ if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601YEAR],
&fields.iso8601Year) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601WEEK],
@@ -696,7 +677,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
- fields.era = era;
+ fields.isBce = isBce;
/*
* Get Julian day.
@@ -714,7 +695,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd(
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
- Tcl_NewIntObj(fields.julianDay));
+ Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
@@ -756,7 +737,7 @@ ConvertLocalToUTC(
* Unpack the tz data.
*/
- if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -821,7 +802,7 @@ ConvertLocalToUTCUsingTable(
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
- || TclListObjGetElements(interp, row, &cellc,
+ || TclListObjGetElementsM(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
&fields->tzOffset) != TCL_OK) {
@@ -959,7 +940,7 @@ ConvertUTCToLocal(
* Unpack the tz data.
*/
- if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1011,7 +992,7 @@ ConvertUTCToLocalUsingTable(
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
- TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
+ TclListObjGetElementsM(interp, row, &cellc, &cellv) != TCL_OK ||
TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
@@ -1064,7 +1045,7 @@ ConvertUTCToLocalUsingC(
if ((Tcl_WideInt) tock != fields->seconds) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number too large to represent as a Posix time", -1));
- Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", NULL);
+ Tcl_SetErrorCode(interp, "CLOCK", "argTooLarge", (void *)NULL);
return TCL_ERROR;
}
TzsetIfNecessary();
@@ -1073,7 +1054,7 @@ ConvertUTCToLocalUsingC(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"localtime failed (clock value may be too "
"large/small to represent)", -1));
- Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", NULL);
+ Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (void *)NULL);
return TCL_ERROR;
}
@@ -1081,7 +1062,7 @@ ConvertUTCToLocalUsingC(
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
- fields->era = CE;
+ fields->isBce = 0;
fields->year = timeVal->tm_year + 1900;
fields->month = timeVal->tm_mon + 1;
fields->dayOfMonth = timeVal->tm_mday;
@@ -1219,7 +1200,7 @@ GetYearWeekDay(
temp.julianDay = fields->julianDay - 3;
GetGregorianEraYearDay(&temp, changeover);
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year = temp.year - 1;
} else {
temp.iso8601Year = temp.year + 1;
@@ -1235,7 +1216,7 @@ GetYearWeekDay(
*/
if (fields->julianDay < temp.julianDay) {
- if (temp.era == BCE) {
+ if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
@@ -1361,10 +1342,10 @@ GetGregorianEraYearDay(
*/
if (year <= 0) {
- fields->era = BCE;
+ fields->isBce = 1;
fields->year = 1 - year;
} else {
- fields->era = CE;
+ fields->isBce = 0;
fields->year = year;
}
fields->dayOfYear = day + 1;
@@ -1432,7 +1413,7 @@ GetJulianDayFromEraYearWeekDay(
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
- firstWeek.era = fields->era;
+ firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
firstWeek.dayOfMonth = 4;
@@ -1476,7 +1457,7 @@ GetJulianDayFromEraYearMonthDay(
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
@@ -1504,10 +1485,10 @@ GetJulianDayFromEraYearMonthDay(
fields->gregorian = 1;
if (year < 1) {
- fields->era = BCE;
+ fields->isBce = 1;
fields->year = 1-year;
} else {
- fields->era = CE;
+ fields->isBce = 0;
fields->year = year;
}
@@ -1582,7 +1563,7 @@ IsGregorianLeapYear(
{
int year = fields->year;
- if (fields->era == BCE) {
+ if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
@@ -1647,7 +1628,7 @@ WeekdayOnOrBefore(
int
ClockGetenvObjCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1660,28 +1641,28 @@ ClockGetenvObjCmd(
const char *varName;
const char *varValue;
#endif
- (void)clientData;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
#ifdef _WIN32
- varName = (const WCHAR *)Tcl_WinUtfToTChar(TclGetString(objv[1]), -1, &ds);
+ Tcl_DStringInit(&ds);
+ varName = Tcl_UtfToWCharDString(TclGetString(objv[1]), -1, &ds);
varValue = _wgetenv(varName);
- Tcl_DStringFree(&ds);
if (varValue == NULL) {
- varValue = L"";
+ Tcl_DStringFree(&ds);
+ } else {
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_WCharToUtfDString(varValue, -1, &ds);
+ Tcl_DStringResult(interp, &ds);
}
- Tcl_WinTCharToUtf((TCHAR *)varValue, -1, &ds);
- Tcl_DStringResult(interp, &ds);
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
- if (varValue == NULL) {
- varValue = "";
+ if (varValue != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
#endif
return TCL_OK;
}
@@ -1750,7 +1731,7 @@ ThreadSafeLocalTime(
int
ClockClicksObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
@@ -1764,7 +1745,6 @@ ClockClicksObjCmd(
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
- (void)clientData;
switch (objc) {
case 1:
@@ -1821,21 +1801,22 @@ ClockClicksObjCmd(
int
ClockMillisecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
+ Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
- now.sec * 1000 + now.usec / 1000));
+ TclNewUIntObj(timeObj, (Tcl_WideUInt)
+ now.sec * 1000 + now.usec / 1000);
+ Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
@@ -1859,12 +1840,11 @@ ClockMillisecondsObjCmd(
int
ClockMicrosecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
- (void)clientData;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
@@ -1893,7 +1873,7 @@ ClockMicrosecondsObjCmd(
static int
ClockParseformatargsObjCmd(
- ClientData clientData, /* Client data containing literal pool */
+ void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -1925,7 +1905,7 @@ ClockParseformatargsObjCmd(
Tcl_WrongNumArgs(interp, 0, objv,
"clock format clockval ?-format string? "
"?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
- Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", NULL);
+ Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (void *)NULL);
return TCL_ERROR;
}
@@ -1940,7 +1920,7 @@ ClockParseformatargsObjCmd(
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
- Tcl_GetString(objv[i]), NULL);
+ TclGetString(objv[i]), (void *)NULL);
return TCL_ERROR;
}
switch (optionIndex) {
@@ -1972,7 +1952,7 @@ ClockParseformatargsObjCmd(
if ((saw & (1 << CLOCK_FORMAT_GMT))
&& (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]);
- Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", NULL);
+ Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", (void *)NULL);
return TCL_ERROR;
}
if (gmtFlag) {
@@ -2011,20 +1991,22 @@ ClockParseformatargsObjCmd(
int
ClockSecondsObjCmd(
- ClientData clientData, /* Client data is unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
- (void)clientData;
+ Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec));
+ TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec);
+
+ Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
@@ -2112,7 +2094,7 @@ TzsetIfNecessary(void)
static void
ClockDeleteCmdProc(
- ClientData clientData) /* Opaque pointer to the client data */
+ void *clientData) /* Opaque pointer to the client data */
{
ClockClientData *data = (ClockClientData *)clientData;
int i;
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 0bf5b8e..e7e929f 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -4,18 +4,18 @@
* This file contains the top-level command routines for most of the Tcl
* built-in commands whose names begin with the letters A to H.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-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.
*/
#include "tclInt.h"
+#include "tclIO.h"
#ifdef _WIN32
# include "tclWinInt.h"
#endif
-#include <locale.h>
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -25,14 +25,14 @@
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. */
- int *index; /* Array of value list indices. */
- int *varcList; /* # loop variables per list. */
+ Tcl_Size bodyIdx; /* The argument index of the body. */
+ Tcl_Size j, maxj; /* Number of loop iterations. */
+ Tcl_Size numLists; /* Count of value lists. */
+ Tcl_Size *index; /* Array of value list indices. */
+ Tcl_Size *varcList; /* # loop variables per list. */
Tcl_Obj ***varvList; /* Array of var name lists. */
Tcl_Obj **vCopyList; /* Copies of var name list arguments. */
- int *argcList; /* Array of value list sizes. */
+ Tcl_Size *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,
@@ -46,11 +46,11 @@ struct ForeachState {
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
-static Tcl_ObjCmdProc BadEncodingSubcommand;
static Tcl_ObjCmdProc EncodingConvertfromObjCmd;
static Tcl_ObjCmdProc EncodingConverttoObjCmd;
static Tcl_ObjCmdProc EncodingDirsObjCmd;
static Tcl_ObjCmdProc EncodingNamesObjCmd;
+static Tcl_ObjCmdProc EncodingProfilesObjCmd;
static Tcl_ObjCmdProc EncodingSystemObjCmd;
static inline int ForeachAssignments(Tcl_Interp *interp,
struct ForeachState *statePtr);
@@ -61,7 +61,7 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr,
static const char * GetTypeFromMode(int mode);
static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName,
Tcl_StatBuf *statPtr);
-static inline int EachloopCmd(Tcl_Interp *interp, int collect,
+static int EachloopCmd(Tcl_Interp *interp, int collect,
int objc, Tcl_Obj *const objv[]);
static Tcl_NRPostProc CatchObjCmdCallback;
static Tcl_NRPostProc ExprCallback;
@@ -72,7 +72,6 @@ static Tcl_NRPostProc ForPostNextCallback;
static Tcl_NRPostProc ForeachLoopStep;
static Tcl_NRPostProc EvalCmdErrMsg;
-static Tcl_ObjCmdProc BadFileSubcommand;
static Tcl_ObjCmdProc FileAttrAccessTimeCmd;
static Tcl_ObjCmdProc FileAttrIsDirectoryCmd;
static Tcl_ObjCmdProc FileAttrIsExecutableCmd;
@@ -122,7 +121,7 @@ static Tcl_ObjCmdProc PathTypeCmd;
int
Tcl_BreakObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -151,9 +150,10 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
int
Tcl_CaseObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -190,7 +190,7 @@ Tcl_CaseObjCmd(
if (caseObjc == 1) {
Tcl_Obj **newObjv;
- TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
+ TclListObjGetElementsM(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
@@ -267,6 +267,7 @@ Tcl_CaseObjCmd(
return TCL_OK;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -287,17 +288,17 @@ Tcl_CaseObjCmd(
int
Tcl_CatchObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -331,7 +332,7 @@ TclNRCatchObjCmd(
static int
CatchObjCmdCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -369,7 +370,7 @@ CatchObjCmdCallback(
}
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
}
@@ -392,7 +393,7 @@ CatchObjCmdCallback(
int
Tcl_CdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -447,7 +448,7 @@ Tcl_CdObjCmd(
int
Tcl_ConcatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -481,7 +482,7 @@ Tcl_ConcatObjCmd(
int
Tcl_ContinueObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -514,11 +515,12 @@ TclInitEncodingCmd(
Tcl_Interp* interp) /* Tcl interpreter */
{
static const EnsembleImplMap encodingImplMap[] = {
- {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"profiles", EncodingProfilesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -526,112 +528,111 @@ TclInitEncodingCmd(
}
/*
- *-----------------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * TclMakeEncodingCommandSafe --
+ * EncodingConvertParseOptions --
*
- * This function hides the unsafe 'dirs' and 'system' subcommands of
- * the "encoding" Tcl command ensemble. It must be called only from
- * TclHideUnsafeCommands.
+ * Common routine for parsing arguments passed to encoding convertfrom
+ * and encoding convertto.
*
* Results:
- * A standard Tcl result
+ * TCL_OK or TCL_ERROR.
*
* Side effects:
- * Adds commands to the table of hidden commands.
- *
- *-----------------------------------------------------------------------------
+ * On success,
+ * - *encPtr is set to the encoding. Must be freed with Tcl_FreeEncoding
+ * if non-NULL
+ * - *dataObjPtr is set to the Tcl_Obj containing the data to encode or
+ * decode
+ * - *profilePtr is set to encoding error handling profile
+ * - *failVarPtr is set to -failindex option value or NULL
+ * On error, all of the above are uninitialized.
+ *
+ *------------------------------------------------------------------------
*/
+static int
+EncodingConvertParseOptions (
+ Tcl_Interp *interp, /* For error messages. May be NULL */
+ int objc, /* Number of arguments */
+ Tcl_Obj *const objv[], /* Argument objects as passed to command. */
+ Tcl_Encoding *encPtr, /* Where to store the encoding */
+ Tcl_Obj **dataObjPtr, /* Where to store ptr to Tcl_Obj containing data */
+ int *profilePtr, /* Bit mask of encoding option profile */
+ Tcl_Obj **failVarPtr /* Where to store -failindex option value */
+)
+{
+ static const char *const options[] = {"-profile", "-failindex", NULL};
+ enum convertfromOptions { PROFILE, FAILINDEX } optIndex;
+ Tcl_Encoding encoding;
+ Tcl_Obj *dataObj;
+ Tcl_Obj *failVarObj;
+ int profile = TCL_ENCODING_PROFILE_TCL8;
-int
-TclMakeEncodingCommandSafe(
- Tcl_Interp* interp) /* Tcl interpreter */
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"convertfrom", 0},
- {"convertto", 0},
- {"dirs", 1},
- {"names", 0},
- {"system", 0},
- {NULL, 0}
- };
+ /*
+ * Possible combinations:
+ * 1) data -> objc = 2
+ * 2) ?options? encoding data -> objc >= 3
+ * It is intentional that specifying option forces encoding to be
+ * specified. Less prone to user error. This should have always been
+ * the case even in 8.6 imho where there were no options (ie (1)
+ * should never have been allowed)
+ */
- int i;
- Tcl_DString oldBuf, newBuf;
-
- Tcl_DStringInit(&oldBuf);
- TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:encoding:");
- for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
- if (unsafeInfo[i].unsafe) {
- const char *oldName, *newName;
-
- Tcl_DStringSetLength(&oldBuf, 17);
- oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
- Tcl_DStringSetLength(&newBuf, 13);
- newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
- if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
- || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
- Tcl_Panic("problem making 'encoding %s' safe: %s",
- unsafeInfo[i].cmdName,
- Tcl_GetString(Tcl_GetObjResult(interp)));
+ if (objc == 1) {
+numArgsError: /* ONLY jump here if nothing needs to be freed!!! */
+ Tcl_WrongNumArgs(interp,
+ 1,
+ objv,
+ "?-profile profile? ?-failindex var? encoding data");
+ ((Interp *)interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS;
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ failVarObj = NULL;
+ if (objc == 2) {
+ encoding = Tcl_GetEncoding(interp, NULL);
+ dataObj = objv[1];
+ } else {
+ int argIndex;
+ for (argIndex = 1; argIndex < (objc-2); ++argIndex) {
+ if (Tcl_GetIndexFromObj(
+ interp, objv[argIndex], options, "option", 0, &optIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (++argIndex == (objc - 2)) {
+ goto numArgsError;
+ }
+ switch (optIndex) {
+ case PROFILE:
+ if (TclEncodingProfileNameToId(interp,
+ TclGetString(objv[argIndex]),
+ &profile) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case FAILINDEX:
+ failVarObj = objv[argIndex];
+ break;
}
- Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
}
+ /* Get encoding after opts so no need to free it on option error */
+ if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ dataObj = objv[objc - 1];
}
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
- /*
- * Ugh. The [encoding] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies.
- */
+ *encPtr = encoding;
+ *dataObjPtr = dataObj;
+ *profilePtr = profile;
+ *failVarPtr = failVarObj;
- if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) {
- Tcl_Panic("problem making 'encoding' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * BadEncodingSubcommand --
- *
- * Command used to act as a backstop implementation when subcommands of
- * "encoding" are unsafe (the real implementations of the subcommands are
- * hidden). The clientData is always the full official subcommand name.
- *
- * Results:
- * A standard Tcl result (always a TCL_ERROR).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-static int
-BadEncodingSubcommand(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- const char *subcommandName = (const char *) clientData;
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "not allowed to invoke subcommand %s of encoding", subcommandName));
- Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
- return TCL_ERROR;
-}
-
/*
*----------------------------------------------------------------------
*
@@ -648,7 +649,7 @@ BadEncodingSubcommand(
int
EncodingConvertfromObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -656,38 +657,82 @@ EncodingConvertfromObjCmd(
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
- int length; /* Length of the byte array being converted */
+ Tcl_Size length; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
+ int flags;
+ int result;
+ Tcl_Obj *failVarObj;
+ Tcl_Size errorLocation;
- if (objc == 2) {
- encoding = Tcl_GetEncoding(interp, NULL);
- data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
- }
- data = objv[2];
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ if (EncodingConvertParseOptions(
+ interp, objc, objv, &encoding, &data, &flags, &failVarObj)
+ != TCL_OK) {
return TCL_ERROR;
}
/*
- * Convert the string into a byte array in 'ds'
+ * Convert the string into a byte array in 'ds'.
*/
- bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
- Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds);
+#if !defined(TCL_NO_DEPRECATED)
+ if (ENCODING_PROFILE_GET(flags) == TCL_ENCODING_PROFILE_TCL8) {
+ /* Permits high bits to be non-0 in byte array (Tcl 8 style) */
+ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ } else
+#endif
+ bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length);
+
+ if (bytesPtr == NULL) {
+ return TCL_ERROR;
+ }
+ result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags,
+ &ds, failVarObj ? &errorLocation : NULL);
+ /* NOTE: ds must be freed beyond this point even on error */
+ switch (result) {
+ case TCL_OK:
+ errorLocation = TCL_INDEX_NONE;
+ break;
+ case TCL_ERROR:
+ /* Error in parameters. Should not happen. interp will have error */
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ default:
+ /*
+ * One of the TCL_CONVERT_* errors. If we were not interested in the
+ * error location, interp result would already have been filled in
+ * and we can just return the error. Otherwise, we have to return
+ * what could be decoded and the returned error location.
+ */
+ if (failVarObj == NULL) {
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ break;
+ }
/*
+ * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
+ * data as was converted.
+ */
+ if (failVarObj) {
+ Tcl_Obj *failIndex;
+ TclNewIndexObj(failIndex, errorLocation);
+ if (Tcl_ObjSetVar2(interp,
+ failVarObj,
+ NULL,
+ failIndex,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ }
+ /*
* Note that we cannot use Tcl_DStringResult here because it will
* truncate the string at the first null byte.
*/
- Tcl_SetObjResult(interp, TclDStringToObj(&ds));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds));
- /*
- * We're done with the encoding
- */
+ /* We're done with the encoding */
Tcl_FreeEncoding(encoding);
return TCL_OK;
@@ -710,7 +755,7 @@ EncodingConvertfromObjCmd(
int
EncodingConverttoObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -718,19 +763,16 @@ EncodingConverttoObjCmd(
Tcl_Obj *data; /* String to convert */
Tcl_DString ds; /* Buffer to hold the byte array */
Tcl_Encoding encoding; /* Encoding to use */
- int length; /* Length of the string being converted */
+ Tcl_Size length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
+ int result;
+ int flags;
+ Tcl_Obj *failVarObj;
+ Tcl_Size errorLocation;
- if (objc == 2) {
- encoding = Tcl_GetEncoding(interp, NULL);
- data = objv[1];
- } else if (objc == 3) {
- if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
- return TCL_ERROR;
- }
- data = objv[2];
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ if (EncodingConvertParseOptions(
+ interp, objc, objv, &encoding, &data, &flags, &failVarObj)
+ != TCL_OK) {
return TCL_ERROR;
}
@@ -739,15 +781,54 @@ EncodingConverttoObjCmd(
*/
stringPtr = TclGetStringFromObj(data, &length);
- Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
+ result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags,
+ &ds, failVarObj ? &errorLocation : NULL);
+ /* NOTE: ds must be freed beyond this point even on error */
+
+ switch (result) {
+ case TCL_OK:
+ errorLocation = TCL_INDEX_NONE;
+ break;
+ case TCL_ERROR:
+ /* Error in parameters. Should not happen. interp will have error */
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ default:
+ /*
+ * One of the TCL_CONVERT_* errors. If we were not interested in the
+ * error location, interp result would already have been filled in
+ * and we can just return the error. Otherwise, we have to return
+ * what could be decoded and the returned error location.
+ */
+ if (failVarObj == NULL) {
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ /*
+ * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
+ * data as was converted.
+ */
+ if (failVarObj) {
+ Tcl_Obj *failIndex;
+ TclNewIndexObj(failIndex, errorLocation);
+ if (Tcl_ObjSetVar2(interp,
+ failVarObj,
+ NULL,
+ failIndex,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DStringFree(&ds);
+ return TCL_ERROR;
+ }
+ }
+
Tcl_SetObjResult(interp,
Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
- /*
- * We're done with the encoding
- */
+ /* We're done with the encoding */
Tcl_FreeEncoding(encoding);
return TCL_OK;
@@ -772,7 +853,7 @@ EncodingConverttoObjCmd(
int
EncodingDirsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -794,7 +875,7 @@ EncodingDirsObjCmd(
"expected directory list but got \"%s\"",
TclGetString(dirListObj)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, dirListObj);
@@ -816,7 +897,7 @@ EncodingDirsObjCmd(
int
EncodingNamesObjCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
@@ -832,6 +913,34 @@ EncodingNamesObjCmd(
/*
*-----------------------------------------------------------------------------
*
+ * EncodingProfilesObjCmd --
+ *
+ * This command returns a list of the available encoding profiles
+ *
+ * Results:
+ * Returns a standard Tcl result
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+EncodingProfilesObjCmd(
+ 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;
+ }
+ TclGetEncodingProfiles(interp);
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
* EncodingSystemObjCmd --
*
* This command retrieves or changes the system encoding
@@ -847,7 +956,7 @@ EncodingNamesObjCmd(
int
EncodingSystemObjCmd(
- ClientData dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
@@ -884,7 +993,7 @@ EncodingSystemObjCmd(
int
Tcl_ErrorObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -933,7 +1042,7 @@ Tcl_ErrorObjCmd(
static int
EvalCmdErrMsg(
- ClientData data[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -946,17 +1055,17 @@ EvalCmdErrMsg(
int
Tcl_EvalObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1015,12 +1124,12 @@ TclNREvalObjCmd(
int
Tcl_ExitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int value;
+ Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
@@ -1029,10 +1138,10 @@ Tcl_ExitObjCmd(
if (objc == 1) {
value = 0;
- } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
+ } else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_Exit(value);
+ Tcl_Exit((int)value);
return TCL_OK; /* Better not ever reach this! */
}
@@ -1062,17 +1171,17 @@ Tcl_ExitObjCmd(
int
Tcl_ExprObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1099,7 +1208,7 @@ TclNRExprObjCmd(
static int
ExprCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1149,40 +1258,43 @@ TclInitFileCmd(
*/
static const EnsembleImplMap initMap[] = {
- {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
+ {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1},
+ {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1},
{"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
- {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, 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, 0},
- {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
- {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
- {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
- {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, 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},
+ {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
- {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
+ {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1},
+ {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1},
{"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
- {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
- {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, 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);
@@ -1191,141 +1303,6 @@ TclInitFileCmd(
/*
*----------------------------------------------------------------------
*
- * TclMakeFileCommandSafe --
- *
- * This function hides the unsafe subcommands of the "file" Tcl command
- * ensemble. It must only be called from TclHideUnsafeCommands.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Adds commands to the table of hidden commands.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclMakeFileCommandSafe(
- Tcl_Interp *interp)
-{
- static const struct {
- const char *cmdName;
- int unsafe;
- } unsafeInfo[] = {
- {"atime", 1},
- {"attributes", 1},
- {"channels", 0},
- {"copy", 1},
- {"delete", 1},
- {"dirname", 1},
- {"executable", 1},
- {"exists", 1},
- {"extension", 1},
- {"isdirectory", 1},
- {"isfile", 1},
- {"join", 0},
- {"link", 1},
- {"lstat", 1},
- {"mtime", 1},
- {"mkdir", 1},
- {"nativename", 1},
- {"normalize", 1},
- {"owned", 1},
- {"pathtype", 0},
- {"readable", 1},
- {"readlink", 1},
- {"rename", 1},
- {"rootname", 1},
- {"separator", 0},
- {"size", 1},
- {"split", 0},
- {"stat", 1},
- {"system", 0},
- {"tail", 1},
- {"tempfile", 1},
- {"type", 1},
- {"volumes", 1},
- {"writable", 1},
- {NULL, 0}
- };
- int i;
- Tcl_DString oldBuf, newBuf;
-
- Tcl_DStringInit(&oldBuf);
- TclDStringAppendLiteral(&oldBuf, "::tcl::file::");
- Tcl_DStringInit(&newBuf);
- TclDStringAppendLiteral(&newBuf, "tcl:file:");
- for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
- if (unsafeInfo[i].unsafe) {
- const char *oldName, *newName;
-
- Tcl_DStringSetLength(&oldBuf, 13);
- oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
- Tcl_DStringSetLength(&newBuf, 9);
- newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
- if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
- || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
- Tcl_Panic("problem making 'file %s' safe: %s",
- unsafeInfo[i].cmdName,
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand,
- (ClientData) unsafeInfo[i].cmdName, NULL);
- }
- }
- Tcl_DStringFree(&oldBuf);
- Tcl_DStringFree(&newBuf);
-
- /*
- * Ugh. The [file] command is now actually safe, but it is assumed by
- * scripts that it is not, which messes up security policies. [Bug
- * 3211758]
- */
-
- if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) {
- Tcl_Panic("problem making 'file' safe: %s",
- Tcl_GetString(Tcl_GetObjResult(interp)));
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * BadFileSubcommand --
- *
- * Command used to act as a backstop implementation when subcommands of
- * "file" are unsafe (the real implementations of the subcommands are
- * hidden). The clientData is always the full official subcommand name.
- *
- * Results:
- * A standard Tcl result (always a TCL_ERROR).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-BadFileSubcommand(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- const char *subcommandName = (const char *) clientData;
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "not allowed to invoke subcommand %s of file", subcommandName));
- Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* FileAttrAccessTimeCmd --
*
* This function is invoked to process the "file atime" Tcl command. See
@@ -1342,7 +1319,7 @@ BadFileSubcommand(
static int
FileAttrAccessTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1360,17 +1337,22 @@ FileAttrAccessTimeCmd(
#if defined(_WIN32)
/* We use a value of 0 to indicate the access time not available */
if (Tcl_GetAccessTimeFromStat(&buf) == 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "could not get access time for file \"%s\"",
- TclGetString(objv[1])));
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not get access time for file \"%s\"",
+ TclGetString(objv[1])));
+ return TCL_ERROR;
}
#endif
if (objc == 3) {
+ /*
+ * Need separate variable for reading longs from an object on 64-bit
+ * platforms. [Bug 698146]
+ */
+
Tcl_WideInt newTime;
- if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1419,7 +1401,7 @@ FileAttrAccessTimeCmd(
static int
FileAttrModifyTimeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1437,10 +1419,10 @@ FileAttrModifyTimeCmd(
#if defined(_WIN32)
/* We use a value of 0 to indicate the modification time not available */
if (Tcl_GetModificationTimeFromStat(&buf) == 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "could not get modification time for file \"%s\"",
- TclGetString(objv[1])));
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "could not get modification time for file \"%s\"",
+ TclGetString(objv[1])));
+ return TCL_ERROR;
}
#endif
if (objc == 3) {
@@ -1451,7 +1433,7 @@ FileAttrModifyTimeCmd(
Tcl_WideInt newTime;
- if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1498,21 +1480,25 @@ FileAttrModifyTimeCmd(
static int
FileAttrLinkStatCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[2], &buf);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -1534,21 +1520,25 @@ FileAttrLinkStatCmd(
static int
FileAttrStatCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[2], &buf);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -1570,7 +1560,7 @@ FileAttrStatCmd(
static int
FileAttrTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1608,7 +1598,7 @@ FileAttrTypeCmd(
static int
FileAttrSizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1645,7 +1635,7 @@ FileAttrSizeCmd(
static int
FileAttrIsDirectoryCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1683,7 +1673,7 @@ FileAttrIsDirectoryCmd(
static int
FileAttrIsExecutableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1714,7 +1704,7 @@ FileAttrIsExecutableCmd(
static int
FileAttrIsExistingCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1745,7 +1735,7 @@ FileAttrIsExistingCmd(
static int
FileAttrIsFileCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1783,7 +1773,7 @@ FileAttrIsFileCmd(
static int
FileAttrIsOwnedCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1800,6 +1790,21 @@ FileAttrIsOwnedCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
+
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(interp, objv[1]);
+ /* Note normPathPtr owned by Tcl, no need to free it */
+ if (normPathPtr) {
+ if (TclIsZipfsPath(Tcl_GetString(normPathPtr))) {
+ return CheckAccess(interp, objv[1], F_OK);
+ }
+ /* Not zipfs, try native. */
+ }
+
+ /*
+ * Note use objv[1] below, NOT normPathPtr even if not NULL because
+ * for native paths we may not want links to be resolved.
+ */
+
#if defined(_WIN32)
value = TclWinFileOwned(objv[1]);
#else
@@ -1830,7 +1835,7 @@ FileAttrIsOwnedCmd(
static int
FileAttrIsReadableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1861,7 +1866,7 @@ FileAttrIsReadableCmd(
static int
FileAttrIsWritableCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1892,7 +1897,7 @@ FileAttrIsWritableCmd(
static int
PathDirNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1931,7 +1936,7 @@ PathDirNameCmd(
static int
PathExtensionCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1970,7 +1975,7 @@ PathExtensionCmd(
static int
PathRootNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2009,7 +2014,7 @@ PathRootNameCmd(
static int
PathTailCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2048,7 +2053,7 @@ PathTailCmd(
static int
PathFilesystemCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2063,7 +2068,7 @@ PathFilesystemCmd(
if (fsInfo == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
- Tcl_GetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fsInfo);
@@ -2089,7 +2094,7 @@ PathFilesystemCmd(
static int
PathJoinCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2121,7 +2126,7 @@ PathJoinCmd(
static int
PathNativeNameCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2135,7 +2140,7 @@ PathNativeNameCmd(
if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclDStringToObj(&ds));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds));
return TCL_OK;
}
@@ -2158,7 +2163,7 @@ PathNativeNameCmd(
static int
PathNormalizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2196,7 +2201,7 @@ PathNormalizeCmd(
static int
PathSplitCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2207,13 +2212,13 @@ PathSplitCmd(
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- res = Tcl_FSSplitPath(objv[1], NULL);
+ res = Tcl_FSSplitPath(objv[1], (Tcl_Size *)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);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, res);
@@ -2239,7 +2244,7 @@ PathSplitCmd(
static int
PathTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2287,7 +2292,7 @@ PathTypeCmd(
static int
FilesystemSeparatorCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2315,7 +2320,7 @@ FilesystemSeparatorCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
- Tcl_GetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, separatorObj);
@@ -2342,7 +2347,7 @@ FilesystemSeparatorCmd(
static int
FilesystemVolumesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2448,7 +2453,7 @@ GetStatBuf(
*
* This is a utility procedure that breaks out the fields of a "stat"
* structure and stores them in textual form into the elements of an
- * associative array.
+ * associative array (if given) or returns a dictionary.
*
* Results:
* Returns a standard Tcl return value. If an error occurs then a message
@@ -2468,9 +2473,40 @@ StoreStatData(
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
- Tcl_Obj *field, *value;
+ Tcl_Obj *field, *value, *result;
unsigned short mode;
+ if (varName == NULL) {
+ TclNewObj(result);
+ Tcl_IncrRefCount(result);
+#define DOBJPUT(key, objValue) \
+ Tcl_DictObjPut(NULL, result, \
+ Tcl_NewStringObj((key), -1), \
+ (objValue));
+ DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
+ DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
+ DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
+ DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
+ DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
+#endif
+ DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
+ DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
+ DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
+ mode = (unsigned short) statPtr->st_mode;
+ DOBJPUT("mode", Tcl_NewWideIntObj(mode));
+ DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
+#undef DOBJPUT
+ Tcl_SetObjResult(interp, result);
+ Tcl_DecrRefCount(result);
+ return TCL_OK;
+ }
+
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
@@ -2494,23 +2530,29 @@ StoreStatData(
* cast might fail when there isn't a real arithmetic 'long long' type...
*/
- STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
- STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
- STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
- STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
- STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
- STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+ 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((Tcl_WideInt)statPtr->st_blocks));
+ STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize));
+ STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_RDEV
+ if (S_ISCHR(statPtr->st_mode) || S_ISBLK(statPtr->st_mode)) {
+ STORE_ARY("rdev", Tcl_NewWideIntObj((long) statPtr->st_rdev));
+ }
#endif
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
- STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
+ STORE_ARY("mtime", Tcl_NewWideIntObj(
+ Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
- STORE_ARY("mode", Tcl_NewIntObj(mode));
+ STORE_ARY("mode", Tcl_NewWideIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
@@ -2602,17 +2644,17 @@ GetTypeFromMode(
int
Tcl_ForObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRForObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2643,7 +2685,7 @@ TclNRForObjCmd(
static int
ForSetupCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2662,7 +2704,7 @@ ForSetupCallback(
int
TclNRForIterCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2697,7 +2739,7 @@ TclNRForIterCallback(
static int
ForCondCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2735,7 +2777,7 @@ ForCondCallback(
static int
ForNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2760,7 +2802,7 @@ ForNextCallback(
static int
ForPostNextCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2796,17 +2838,17 @@ ForPostNextCallback(
int
Tcl_ForeachObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRForeachCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2816,17 +2858,17 @@ TclNRForeachCmd(
int
Tcl_LmapObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2834,7 +2876,7 @@ TclNRLmapCmd(
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
-static inline int
+static int
EachloopCmd(
Tcl_Interp *interp, /* Our context for variables and script
* evaluation. */
@@ -2845,7 +2887,8 @@ EachloopCmd(
{
int numLists = (objc-2) / 2;
struct ForeachState *statePtr;
- int i, j, result;
+ int i, result;
+ Tcl_Size j;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2869,16 +2912,16 @@ EachloopCmd(
*/
statePtr = (struct ForeachState *)TclStackAlloc(interp,
- sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(Tcl_Size)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
memset(statePtr, 0,
- sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ sizeof(struct ForeachState) + 3 * numLists * sizeof(Tcl_Size)
+ 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 = (int *) (statePtr->aCopyList + numLists);
+ statePtr->index = (Tcl_Size *) (statePtr->aCopyList + numLists);
statePtr->varcList = statePtr->index + numLists;
statePtr->argcList = statePtr->varcList + numLists;
@@ -2897,32 +2940,58 @@ EachloopCmd(
*/
for (i=0 ; i<numLists ; i++) {
- statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
+ /* List */
+ /* Variables */
+
+ /* Do not use TclListObjCopy here - shimmers arithseries to list */
+ statePtr->vCopyList[i] = Tcl_DuplicateObj(objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(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 = TclListObjLengthM(interp, statePtr->vCopyList[i],
+ &statePtr->varcList[i]);
+ if (result != TCL_OK) {
result = TCL_ERROR;
goto done;
}
-
- statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (statePtr->aCopyList[i] == NULL) {
+ 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", (void *)NULL);
result = TCL_ERROR;
goto done;
}
- TclListObjGetElements(NULL, statePtr->aCopyList[i],
+ TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
+ &statePtr->varcList[i], &statePtr->varvList[i]);
+
+ /* Values */
+ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) {
+ /* Special case for Arith Series */
+ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ /* Don't compute values here, wait until the last moment */
+ statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]);
+ } else {
+ /* List values */
+ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ result = TclListObjGetElementsM(interp, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
-
+ if (result != TCL_OK) {
+ goto done;
+ }
+ }
+ /* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
@@ -2965,7 +3034,7 @@ EachloopCmd(
static int
ForeachLoopStep(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3040,14 +3109,27 @@ ForeachAssignments(
Tcl_Interp *interp,
struct ForeachState *statePtr)
{
- int i, v, k;
+ int i;
+ Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
+ int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType);
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
- valuePtr = statePtr->argvList[i][k];
+ if (isarithseries) {
+ valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k);
+ if (valuePtr == NULL) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (setting %s loop variable \"%s\")",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
+ TclGetString(statePtr->varvList[i][v])));
+ return TCL_ERROR;
+ }
+ } else {
+ valuePtr = statePtr->argvList[i][k];
+ }
} else {
TclNewObj(valuePtr); /* Empty string */
}
@@ -3112,7 +3194,7 @@ ForeachCleanup(
int
Tcl_FormatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index eba385d..8f7cbe6 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -6,12 +6,12 @@
* contains only commands in the generic core (i.e., those that don't
* depend much upon UNIX facilities).
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1993-1997 Lucent Technologies.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2005 Donal K. Fellows.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1993-1997 Lucent Technologies.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,6 +19,9 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tclTomMath.h"
+#include <math.h>
+#include <assert.h>
/*
* During execution of the "lsort" command, structures of the following type
@@ -35,7 +38,7 @@ typedef struct SortElement {
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
- int index;
+ Tcl_Size index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
@@ -47,7 +50,6 @@ typedef struct SortElement {
*/
typedef int (*SortStrCmpFn_t) (const char *, const char *);
-typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
/*
* The "lsort" command needs to pass certain information down to the function
@@ -56,7 +58,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
* The following structure is used to pass this information.
*/
-typedef struct SortInfo {
+typedef struct {
int isIncreasing; /* Nonzero means sort in increasing order. */
int sortMode; /* The sort mode. One of SORTMODE_* values
* defined below. */
@@ -70,7 +72,7 @@ typedef struct SortInfo {
* NULL if no indexes supplied, and points to
* singleIndex field when only one
* supplied. */
- int indexc; /* Number of indexes in indexv array. */
+ Tcl_Size indexc; /* Number of indexes in indexv array. */
int singleIndex; /* Static space for common index case. */
int unique;
int numElements;
@@ -94,52 +96,50 @@ typedef struct SortInfo {
#define SORTMODE_ASCII_NC 8
/*
+ * Definitions for [lseq] command
+ */
+static const char *const seq_operations[] = {
+ "..", "to", "count", "by", NULL
+};
+typedef enum Sequence_Operators {
+ LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
+} SequenceOperators;
+static const char *const seq_step_keywords[] = {"by", NULL};
+typedef enum Step_Operators {
+ STEP_BY = 4
+} SequenceByMode;
+typedef enum Sequence_Decoded {
+ NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg
+} SequenceDecoded;
+
+/*
* Forward declarations for procedures defined in this file:
*/
static int DictionaryCompare(const char *left, const char *right);
static Tcl_NRPostProc IfConditionCallback;
-static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoArgsCmd;
+static Tcl_ObjCmdProc InfoBodyCmd;
+static Tcl_ObjCmdProc InfoCmdCountCmd;
+static Tcl_ObjCmdProc InfoCommandsCmd;
+static Tcl_ObjCmdProc InfoCompleteCmd;
+static Tcl_ObjCmdProc InfoDefaultCmd;
/* TIP #348 - New 'info' subcommand 'errorstack' */
-static int InfoErrorStackCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoErrorStackCmd;
/* TIP #280 - New 'info' subcommand 'frame' */
-static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoNameOfExecutableCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int InfoPatchLevelCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoProcsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc InfoFrameCmd;
+static Tcl_ObjCmdProc InfoFunctionsCmd;
+static Tcl_ObjCmdProc InfoHostnameCmd;
+static Tcl_ObjCmdProc InfoLevelCmd;
+static Tcl_ObjCmdProc InfoLibraryCmd;
+static Tcl_ObjCmdProc InfoLoadedCmd;
+static Tcl_ObjCmdProc InfoNameOfExecutableCmd;
+static Tcl_ObjCmdProc InfoPatchLevelCmd;
+static Tcl_ObjCmdProc InfoProcsCmd;
+static Tcl_ObjCmdProc InfoScriptCmd;
+static Tcl_ObjCmdProc InfoSharedlibCmd;
+static Tcl_ObjCmdProc InfoCmdTypeCmd;
+static Tcl_ObjCmdProc InfoTclVersionCmd;
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
SortInfo *infoPtr);
static int SortCompare(SortElement *firstPtr, SortElement *second,
@@ -156,6 +156,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
@@ -170,7 +171,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
{"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
@@ -203,17 +204,17 @@ static const EnsembleImplMap defaultInfoMap[] = {
int
Tcl_IfObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -224,7 +225,7 @@ TclNRIfObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
return TCL_ERROR;
}
@@ -236,13 +237,13 @@ TclNRIfObjCmd(
TclNewObj(boolObj);
Tcl_NRAddCallback(interp, IfConditionCallback, INT2PTR(objc),
- (ClientData) objv, INT2PTR(1), boolObj);
+ (void *) objv, INT2PTR(1), boolObj);
return Tcl_NRExprObj(interp, objv[1], boolObj);
}
static int
IfConditionCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -315,7 +316,7 @@ IfConditionCallback(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no expression after \"%s\" argument",
clause));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
return TCL_ERROR;
}
if (!thenScriptIndex) {
@@ -342,7 +343,7 @@ IfConditionCallback(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong # args: extra words after \"else\" clause in \"if\" command",
-1));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
@@ -359,7 +360,7 @@ IfConditionCallback(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"wrong # args: no script following \"%s\" argument",
TclGetString(objv[i-1])));
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
return TCL_ERROR;
}
@@ -386,7 +387,7 @@ IfConditionCallback(
int
Tcl_IncrObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -467,7 +468,7 @@ TclInitInfoCmd(
static int
InfoArgsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -488,7 +489,7 @@ InfoArgsCmd(
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL);
return TCL_ERROR;
}
@@ -530,15 +531,15 @@ InfoArgsCmd(
static int
InfoBodyCmd(
- ClientData dummy, /* Not used. */
+ 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;
+ const char *name, *bytes;
Proc *procPtr;
- Tcl_Obj *bodyPtr, *resultPtr;
+ Tcl_Size numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
@@ -550,7 +551,7 @@ InfoBodyCmd(
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", name, (void *)NULL);
return TCL_ERROR;
}
@@ -563,18 +564,8 @@ InfoBodyCmd(
* the object do not invalidate the internal rep.
*/
- bodyPtr = procPtr->bodyPtr;
- if (bodyPtr->bytes == NULL) {
- /*
- * The string rep might not be valid if the procedure has never been
- * run before. [Bug #545644]
- */
-
- TclGetString(bodyPtr);
- }
- resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
-
- Tcl_SetObjResult(interp, resultPtr);
+ bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
@@ -601,7 +592,7 @@ InfoBodyCmd(
static int
InfoCmdCountCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -613,7 +604,7 @@ InfoCmdCountCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount));
return TCL_OK;
}
@@ -643,7 +634,7 @@ InfoCmdCountCmd(
static int
InfoCommandsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -658,7 +649,7 @@ InfoCommandsCmd(
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
Tcl_Command cmd;
- int i;
+ Tcl_Size i;
/*
* Get the pattern and find the "effective namespace" in which to list
@@ -920,7 +911,7 @@ InfoCommandsCmd(
static int
InfoCompleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -957,7 +948,7 @@ InfoCompleteCmd(
static int
InfoDefaultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -981,7 +972,7 @@ InfoDefaultCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName,
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -995,7 +986,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
} else {
Tcl_Obj *nullObjPtr;
@@ -1005,7 +996,7 @@ InfoDefaultCmd(
if (valueObjPtr == NULL) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -1014,7 +1005,7 @@ InfoDefaultCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\" doesn't have an argument \"%s\"",
procName, argName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, (void *)NULL);
return TCL_ERROR;
}
@@ -1040,7 +1031,7 @@ InfoDefaultCmd(
static int
InfoErrorStackCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1055,7 +1046,7 @@ InfoErrorStackCmd(
target = interp;
if (objc == 2) {
- target = Tcl_GetChild(interp, Tcl_GetString(objv[1]));
+ target = Tcl_GetChild(interp, TclGetString(objv[1]));
if (target == NULL) {
return TCL_ERROR;
}
@@ -1089,7 +1080,7 @@ InfoErrorStackCmd(
int
TclInfoExistsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1134,7 +1125,7 @@ TclInfoExistsCmd(
static int
InfoFrameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1179,7 +1170,7 @@ InfoFrameCmd(
* Just "info frame".
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel));
goto done;
}
@@ -1197,7 +1188,7 @@ InfoFrameCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
- TclGetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
code = TCL_ERROR;
goto done;
}
@@ -1301,9 +1292,9 @@ TclInfoFrame(
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
if (framePtr->line) {
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
} else {
- ADD_PAIR("line", Tcl_NewIntObj(1));
+ ADD_PAIR("line", Tcl_NewWideIntObj(1));
}
ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
@@ -1340,7 +1331,7 @@ TclInfoFrame(
ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1));
if (fPtr->line) {
- ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0]));
}
if (fPtr->type == TCL_LOCATION_SOURCE) {
@@ -1367,7 +1358,7 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0]));
ADD_PAIR("file", framePtr->data.eval.path);
/*
@@ -1404,7 +1395,7 @@ TclInfoFrame(
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
- int i;
+ Tcl_Size i;
/*
* This is a non-standard command. Luckily, it's told us how to
@@ -1438,7 +1429,7 @@ TclInfoFrame(
int c = framePtr->framePtr->level;
int t = iPtr->varFramePtr->level;
- ADD_PAIR("level", Tcl_NewIntObj(t - c));
+ ADD_PAIR("level", Tcl_NewWideIntObj(t - c));
break;
}
}
@@ -1474,7 +1465,7 @@ TclInfoFrame(
static int
InfoFunctionsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1539,7 +1530,7 @@ InfoFunctionsCmd(
static int
InfoHostnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1559,7 +1550,7 @@ InfoHostnameCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unable to determine name of host", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", (void *)NULL);
return TCL_ERROR;
}
@@ -1585,7 +1576,7 @@ InfoHostnameCmd(
static int
InfoLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1593,7 +1584,7 @@ InfoLevelCmd(
Interp *iPtr = (Interp *) interp;
if (objc == 1) { /* Just "info level" */
- Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level));
return TCL_OK;
}
@@ -1632,7 +1623,7 @@ InfoLevelCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
- TclGetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
@@ -1659,7 +1650,7 @@ InfoLevelCmd(
static int
InfoLibraryCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1671,7 +1662,7 @@ InfoLibraryCmd(
return TCL_ERROR;
}
- libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
if (libDirName != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1));
return TCL_OK;
@@ -1679,7 +1670,7 @@ InfoLibraryCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no library has been specified for Tcl", -1));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library", (void *)NULL);
return TCL_ERROR;
}
@@ -1706,24 +1697,29 @@ InfoLibraryCmd(
static int
InfoLoadedCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *interpName;
+ const char *interpName, *packageName;
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
return TCL_ERROR;
}
- if (objc == 1) { /* Get loaded pkgs in all interpreters. */
+ if (objc < 2) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
- return TclGetLoadedPackages(interp, interpName);
+ if (objc < 3) { /* Get loaded files in all packages. */
+ packageName = NULL;
+ } else { /* Get pkgs just in specified interp. */
+ packageName = TclGetString(objv[2]);
+ }
+ return TclGetLoadedLibraries(interp, interpName, packageName);
}
/*
@@ -1749,7 +1745,7 @@ InfoLoadedCmd(
static int
InfoNameOfExecutableCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1785,7 +1781,7 @@ InfoNameOfExecutableCmd(
static int
InfoPatchLevelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1797,7 +1793,7 @@ InfoPatchLevelCmd(
return TCL_ERROR;
}
- patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
+ patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL,
(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
if (patchlevel != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1));
@@ -1832,7 +1828,7 @@ InfoPatchLevelCmd(
static int
InfoProcsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1930,7 +1926,7 @@ InfoProcsCmd(
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
- TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ TclGetOriginalCommand((Tcl_Command)cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
@@ -1938,7 +1934,7 @@ InfoProcsCmd(
procOK:
if (specificNsInPattern) {
TclNewObj(elemObjPtr);
- Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
+ Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
@@ -1969,11 +1965,11 @@ InfoProcsCmd(
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
- cmdPtr = Tcl_GetHashValue(entryPtr);
+ cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
@@ -2019,12 +2015,13 @@ InfoProcsCmd(
static int
InfoScriptCmd(
- ClientData dummy, /* Not used. */
+ 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)) {
Tcl_WrongNumArgs(interp, 1, objv, "?filename?");
return TCL_ERROR;
@@ -2066,7 +2063,7 @@ InfoScriptCmd(
static int
InfoSharedlibCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2104,7 +2101,7 @@ InfoSharedlibCmd(
static int
InfoTclVersionCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2128,6 +2125,60 @@ InfoTclVersionCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoCmdTypeCmd --
+ *
+ * Called to implement the "info cmdtype" command that returns the type
+ * of a given command. Handles the following syntax:
+ *
+ * info cmdtype cmdName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a type name. If there is an error, the result is an error
+ * 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) {
+ Tcl_WrongNumArgs(interp, 1, objv, "commandName");
+ return TCL_ERROR;
+ }
+ command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (command == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * There's one special case: safe interpreters can't see aliases as
+ * aliases as they're part of the security mechanisms.
+ */
+
+ if (Tcl_IsSafe(interp)
+ && (((Command *) command)->objProc == TclAliasObjCmd)) {
+ Tcl_AppendResult(interp, "native", (void *)NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
@@ -2144,13 +2195,14 @@ InfoTclVersionCmd(
int
Tcl_JoinObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int listLen, i;
- Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
+ Tcl_Size length, listLen;
+ int isArithSeries = 0;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2162,32 +2214,88 @@ Tcl_JoinObjCmd(
* pointer to its array of element pointers.
*/
- if (TclListObjGetElements(interp, objv[1], &listLen,
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ isArithSeries = 1;
+ listLen = TclArithSeriesObjLength(objv[1]);
+ } else {
+ if (TclListObjGetElementsM(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
+ }
+ }
+
+ if (listLen == 0) {
+ /* No elements to join; default empty result is correct. */
+ return TCL_OK;
+ }
+ if (listLen == 1) {
+ /* One element; return it */
+ if (isArithSeries) {
+ Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0);
+ if (valueObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, valueObj);
+ } else {
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ }
+ return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- TclNewObj(resObjPtr);
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ (void) TclGetStringFromObj(joinObjPtr, &length);
+ if (length == 0) {
+ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
+ } else {
+ Tcl_Size i;
+
+ TclNewObj(resObjPtr);
+ if (isArithSeries) {
+ Tcl_Obj *valueObj;
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
+
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ valueObj = TclArithSeriesObjIndex(interp, objv[1], i);
+ if (valueObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendObjToObj(resObjPtr, valueObj);
+ Tcl_DecrRefCount(valueObj);
+ }
+ } else {
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
- /*
- * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
- * to shimmer joinObjPtr. If it did, then the case where
- * objv[1] and objv[2] are the same value would not be safe.
- * Accessing elemPtrs would crash.
- */
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
+ }
}
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_DecrRefCount(joinObjPtr);
- Tcl_SetObjResult(interp, resObjPtr);
- return TCL_OK;
+ if (resObjPtr) {
+ Tcl_SetObjResult(interp, resObjPtr);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
}
/*
@@ -2209,14 +2317,15 @@ Tcl_JoinObjCmd(
int
Tcl_LassignObjCmd(
- ClientData dummy, /* Not used. */
+ 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. */
- int listObjc; /* The length of the list. */
+ Tcl_Size listObjc; /* The length of the list. */
+ Tcl_Size origListObjc; /* Original length */
int code = TCL_OK;
if (objc < 2) {
@@ -2228,8 +2337,10 @@ Tcl_LassignObjCmd(
if (listCopyPtr == NULL) {
return TCL_ERROR;
}
+ Tcl_IncrRefCount(listCopyPtr); /* Important! fs */
- TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv);
+ TclListObjGetElementsM(NULL, listCopyPtr, &listObjc, &listObjv);
+ origListObjc = listObjc;
objc -= 2;
objv += 2;
@@ -2257,7 +2368,13 @@ Tcl_LassignObjCmd(
}
if (code == TCL_OK && listObjc > 0) {
- Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc, listObjv));
+ Tcl_Obj *resultObjPtr = TclListObjRange(
+ interp, listCopyPtr, origListObjc - listObjc, origListObjc - 1);
+ if (resultObjPtr == NULL) {
+ code = TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, resultObjPtr);
+ }
}
Tcl_DecrRefCount(listCopyPtr);
@@ -2283,12 +2400,11 @@ Tcl_LassignObjCmd(
int
Tcl_LindexObjCmd(
- ClientData dummy, /* Not used. */
+ 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) {
@@ -2342,20 +2458,21 @@ Tcl_LindexObjCmd(
int
Tcl_LinsertObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
- int index, len, result;
+ Tcl_Size len, index;
+ int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &len);
+ result = TclListObjLengthM(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
@@ -2424,7 +2541,7 @@ Tcl_LinsertObjCmd(
int
Tcl_ListObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
@@ -2460,20 +2577,22 @@ Tcl_ListObjCmd(
int
Tcl_LlengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
- int listLen, result;
+ Tcl_Size listLen;
+ int result;
+ Tcl_Obj *objPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2483,7 +2602,110 @@ Tcl_LlengthObjCmd(
* length.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen));
+ TclNewUIntObj(objPtr, listLen);
+ Tcl_SetObjResult(interp, objPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LpopObjCmd --
+ *
+ * This procedure is invoked to process the "lpop" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * 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. */
+{
+ Tcl_Size 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.
+ */
+
+ if (objc == 2) {
+ if (!listLen) {
+ /* empty list, throw the same error as with index "end" */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "index \"end\" out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
+ "OUTOFRANGE", (void *)NULL);
+ return TCL_ERROR;
+ }
+ elemPtr = elemPtrs[listLen - 1];
+ Tcl_IncrRefCount(elemPtr);
+ } else {
+ elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
+
+ if (elemPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount(elemPtr);
+
+ /*
+ * Second, remove the element.
+ * TclLsetFlat adds a ref count which is handled.
+ */
+
+ if (objc == 2) {
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ }
+ result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_IncrRefCount(listPtr);
+ } else {
+ listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
+
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(listPtr);
+ if (stored == NULL) {
+ return TCL_ERROR;
+ }
+
return TCL_OK;
}
@@ -2506,21 +2728,20 @@ Tcl_LlengthObjCmd(
int
Tcl_LrangeObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
- Tcl_Obj **elemPtrs;
- int listLen, first, last, result;
-
+ int result;
+ Tcl_Size listLen, first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2530,56 +2751,175 @@ Tcl_LrangeObjCmd(
if (result != TCL_OK) {
return result;
}
- if (first < 0) {
- first = 0;
- }
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result != TCL_OK) {
return result;
}
- if (last >= listLen) {
- last = listLen - 1;
+
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_Obj *rangeObj;
+ rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last);
+ if (rangeObj) {
+ Tcl_SetObjResult(interp, rangeObj);
+ } else {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_Obj *resultObj = TclListObjRange(interp, objv[1], first, last);
+ if (resultObj == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultObj);
}
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LremoveObjCmd --
+ *
+ * This procedure is invoked to process the "lremove" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- if (first > last) {
- /*
- * Returning an empty list is easy.
- */
+static int
+LremoveIndexCompare(
+ const void *el1Ptr,
+ const void *el2Ptr)
+{
+ Tcl_Size idx1 = *((const Tcl_Size *) el1Ptr);
+ Tcl_Size idx2 = *((const Tcl_Size *) el2Ptr);
+
+ /*
+ * This will put the larger element first.
+ */
+
+ 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. */
+{
+ Tcl_Size i, idxc, prevIdx, first, num;
+ Tcl_Size *idxv, listLen;
+ Tcl_Obj *listObj;
+ int copied = 0, status = TCL_OK;
+
+ /*
+ * 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;
}
+ idxv = (Tcl_Size *)ckalloc((objc - 2) * sizeof(*idxv));
+ for (i = 2; i < objc; i++) {
+ status = (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
+ &idxv[i - 2]) != TCL_OK);
+ if (status != TCL_OK) {
+ goto done;
+ }
+ }
- result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
+ /*
+ * Sort the indices, large to small so that when we remove an index we
+ * don't change the indices still to be processed.
+ */
+
+ if (idxc > 1) {
+ qsort(idxv, idxc, sizeof(*idxv), LremoveIndexCompare);
}
- if (Tcl_IsShared(objv[1]) ||
- ((ListRepPtr(objv[1])->refCount > 1))) {
- Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
- &elemPtrs[first]));
- } else {
+ /*
+ * Make our working copy, then do the actual removes piecemeal.
+ */
+
+ if (Tcl_IsShared(listObj)) {
+ listObj = TclListObjCopy(NULL, listObj);
+ copied = 1;
+ }
+ num = 0;
+ first = listLen;
+ for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
+ Tcl_Size idx = idxv[i];
+
/*
- * In-place is possible.
+ * Repeated index and sanity check.
*/
- if (last < (listLen - 1)) {
- Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last,
- 0, NULL);
+ if (idx == prevIdx) {
+ continue;
+ }
+ prevIdx = idx;
+ if (idx < 0 || idx >= listLen) {
+ continue;
}
/*
- * This one is not conditioned on (first > 0) in order to preserve the
- * string-canonizing effect of [lrange 0 end].
+ * Coalesce adjacent removes to reduce the number of copies.
*/
- Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL);
- Tcl_SetObjResult(interp, objv[1]);
- }
+ if (num == 0) {
+ num = 1;
+ first = idx;
+ } else if (idx + 1 == first) {
+ num++;
+ first = idx;
+ } else {
+ /*
+ * Note that this operation can't fail now; we know we have a list
+ * and we're only ever contracting that list.
+ */
- return TCL_OK;
+ status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ if (status != TCL_OK) {
+ goto done;
+ }
+ listLen -= num;
+ num = 1;
+ first = idx;
+ }
+ }
+ if (num != 0) {
+ status = Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
+ if (status != TCL_OK) {
+ if (copied) {
+ Tcl_DecrRefCount(listObj);
+ }
+ goto done;
+ }
+ }
+ Tcl_SetObjResult(interp, listObj);
+done:
+ ckfree(idxv);
+ return status;
}
/*
@@ -2601,13 +2941,14 @@ Tcl_LrangeObjCmd(
int
Tcl_LrepeatObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
- int elementCount, i, totalElems;
+ Tcl_WideInt elementCount, i;
+ Tcl_Size totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
/*
@@ -2619,14 +2960,14 @@ Tcl_LrepeatObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
- if (TCL_OK != TclGetIntFromObj(interp, objv[1], &elementCount)) {
+ if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad count \"%d\": must be integer >= 0", elementCount));
+ "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -2641,8 +2982,8 @@ Tcl_LrepeatObjCmd(
if (elementCount && objc > LIST_MAX/elementCount) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded", LIST_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ "max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
return TCL_ERROR;
}
totalElems = objc * elementCount;
@@ -2654,10 +2995,15 @@ Tcl_LrepeatObjCmd(
listPtr = Tcl_NewListObj(totalElems, NULL);
if (totalElems) {
- List *listRepPtr = ListRepPtr(listPtr);
-
- listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ 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;
+ }
}
/*
@@ -2676,7 +3022,7 @@ Tcl_LrepeatObjCmd(
dataArray[i] = tmpPtr;
}
} else {
- int j, k = 0;
+ Tcl_Size j, k = 0;
for (i=0 ; i<elementCount ; i++) {
for (j=0 ; j<objc ; j++) {
@@ -2710,13 +3056,14 @@ Tcl_LrepeatObjCmd(
int
Tcl_LreplaceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
- int first, last, listLen, numToDelete, result;
+ Tcl_Size numToDelete, listLen, first, last;
+ int result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2724,7 +3071,7 @@ Tcl_LreplaceObjCmd(
return TCL_ERROR;
}
- result = TclListObjLength(interp, objv[1], &listLen);
+ result = TclListObjLengthM(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -2745,10 +3092,9 @@ Tcl_LreplaceObjCmd(
return result;
}
- if (first < 0) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
- }
- if (first > listLen) {
+ } else if (first > listLen) {
first = listLen;
}
@@ -2756,7 +3102,7 @@ Tcl_LreplaceObjCmd(
last = listLen - 1;
}
if (first <= last) {
- numToDelete = last - first + 1;
+ numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */
} else {
numToDelete = 0;
}
@@ -2811,19 +3157,35 @@ Tcl_LreplaceObjCmd(
int
Tcl_LreverseObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj **elemv;
- int elemc, i, j;
+ Tcl_Size elemc, i, j;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+
+ /*
+ * Handle ArithSeries special case - don't shimmer a series into a list
+ * just to reverse it.
+ */
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]);
+ if (resObj) {
+ Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+ } /* end ArithSeries */
+
+ /* True List */
+ if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
@@ -2835,16 +3197,26 @@ Tcl_LreverseObjCmd(
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
+ if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) {
+ return TCL_ERROR;
+ }
if (Tcl_IsShared(objv[1])
- || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */
+ || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
- List *listRepPtr;
+ ListRep listRep;
resultObj = Tcl_NewListObj(elemc, NULL);
- listRepPtr = ListRepPtr(resultObj);
- listRepPtr->elemCount = elemc;
- dataArray = &listRepPtr->elements;
+
+ /* 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];
@@ -2890,34 +3262,37 @@ Tcl_LreverseObjCmd(
int
Tcl_LsearchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
- int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
- int dataType, isIncreasing, lower, upper, offset;
- Tcl_WideInt patWide, objWide;
+ int match, result=TCL_OK, bisect;
+ Tcl_Size i, length, listc, elemLen, start, index;
+ Tcl_Size groupSize, groupOffset, lower, upper;
+ int allocatedIndexVector = 0;
+ int dataType, isIncreasing;
+ Tcl_WideInt patWide, objWide, wide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
- SortStrCmpFn_t strCmpFn = strcmp;
+ SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
- "-real", "-regexp", "-sorted", "-start",
+ "-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
- enum options {
+ enum lsearchoptions {
LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING,
LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
- LSEARCH_START, LSEARCH_SUBINDICES
+ LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2937,7 +3312,9 @@ Tcl_LsearchObjCmd(
bisect = 0;
listPtr = NULL;
startPtr = NULL;
- offset = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ start = 0;
noCase = 0;
sortInfo.compareCmdPtr = NULL;
sortInfo.isIncreasing = 1;
@@ -2955,13 +3332,10 @@ Tcl_LsearchObjCmd(
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
- switch ((enum options) index) {
+ switch ((enum lsearchoptions) index) {
case LSEARCH_ALL: /* -all */
allMatches = 1;
break;
@@ -3022,11 +3396,12 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing starting index", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
result = TCL_ERROR;
goto done;
}
@@ -3042,25 +3417,48 @@ Tcl_LsearchObjCmd(
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
- Tcl_IncrRefCount(startPtr);
}
+ Tcl_IncrRefCount(startPtr);
+ break;
+ case LSEARCH_STRIDE: /* -stride */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if ((wide < 1) || (wide > LIST_MAX)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "stride length must be between 1 and %d", LIST_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADSTRIDE", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ groupSize = wide;
+ i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
- int j;
+ Tcl_Size j;
- if (sortInfo.indexc > 1) {
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
+ allocatedIndexVector = 0;
}
if (i > objc-4) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- return TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -3070,12 +3468,10 @@ Tcl_LsearchObjCmd(
*/
i++;
- if (TclListObjGetElements(interp, objv[i],
+ if (TclListObjGetElementsM(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch (sortInfo.indexc) {
case 0:
@@ -3087,6 +3483,8 @@ Tcl_LsearchObjCmd(
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
}
/*
@@ -3097,22 +3495,21 @@ Tcl_LsearchObjCmd(
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
- if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE,
- TCL_INDEX_AFTER, &encoded) != TCL_OK) {
+ if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
- if ((encoded == TCL_INDEX_BEFORE)
- || (encoded == TCL_INDEX_AFTER)) {
+ if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indices[j])));
+ "index \"%s\" out of range",
+ TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
- "OUTOFRANGE", NULL);
+ "OUTOFRANGE", (void *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (-index option item number %d)", j));
+ "\n (-index option item number %" TCL_SIZE_MODIFIER "d)", j));
goto done;
}
sortInfo.indexv[j] = encoded;
@@ -3127,22 +3524,21 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && sortInfo.indexc==0) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ "BAD_OPTION_MIX", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
}
if (bisect && (allMatches || negatedMatch)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
- "BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ "BAD_OPTION_MIX", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
}
if (mode == REGEXP) {
@@ -3168,9 +3564,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3181,26 +3574,66 @@ Tcl_LsearchObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
+ result = TclListObjGetElementsM(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
goto done;
}
/*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #351]
+ */
+
+ if (groupSize > 1) {
+ if (listc % groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
+ (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc > 0) {
+ /*
+ * Use the first value in the list supplied to -index as the
+ * offset of the element within each group by which to sort.
+ */
+
+ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
+ if (groupOffset < 0 || groupOffset >= groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADINDEX", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
+ /*
* Get the user-specified start offset.
*/
if (startPtr) {
- result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
- Tcl_DecrRefCount(startPtr);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
- if (offset < 0) {
- offset = 0;
+ if (start == TCL_INDEX_NONE) {
+ start = TCL_INDEX_START;
}
/*
@@ -3208,16 +3641,22 @@ Tcl_LsearchObjCmd(
* "did not match anything at all" result straight away. [Bug 1374778]
*/
- if (offset > listc-1) {
- if (sortInfo.indexc > 1) {
- TclStackFree(interp, sortInfo.indexv);
- }
+ if (start >= listc) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ TclNewIntObj(itemPtr, -1);
+ Tcl_SetObjResult(interp, itemPtr);
}
- return TCL_OK;
+ goto done;
+ }
+
+ /*
+ * If start points within a group, it points to the start of the group.
+ */
+
+ if (groupSize > 1) {
+ start -= (start % groupSize);
}
}
@@ -3240,7 +3679,7 @@ Tcl_LsearchObjCmd(
* 1844789]
*/
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+ TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
@@ -3253,7 +3692,7 @@ Tcl_LsearchObjCmd(
* 1844789]
*/
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
+ TclListObjGetElementsM(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
@@ -3276,18 +3715,23 @@ Tcl_LsearchObjCmd(
* sense in doing this when the match sense is inverted.
*/
- lower = offset - 1;
+ /*
+ * With -stride, lower, upper and i are kept as multiples of groupSize.
+ */
+
+ lower = start - groupSize;
upper = listc;
- while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
+ while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
+ i -= i % groupSize;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch ((enum datatypes) dataType) {
case ASCII:
@@ -3376,10 +3820,10 @@ Tcl_LsearchObjCmd(
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
- for (i = offset; i < listc; i++) {
+ for (i = start; i < listc; i += groupSize) {
match = 0;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
@@ -3388,7 +3832,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3406,8 +3850,7 @@ Tcl_LsearchObjCmd(
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
- match = (memcmp(bytes, patternBytes,
- (size_t) length) == 0);
+ match = (memcmp(bytes, patternBytes, length) == 0);
}
}
break;
@@ -3478,22 +3921,28 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo);
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else if (groupSize > 1) {
+ Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
+ groupSize, &listv[i]);
} else {
itemPtr = listv[i];
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
- Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (returnSubindices) {
- int j;
+ Tcl_Size j;
- TclNewIntObj(itemPtr, i);
+ TclNewIndexObj(itemPtr, i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
- TclIndexDecode(sortInfo.indexv[j], listc)));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
+ Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
- Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i));
+ Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
@@ -3506,16 +3955,19 @@ Tcl_LsearchObjCmd(
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
- int j;
+ Tcl_Size j;
- TclNewIntObj(itemPtr, index);
+ TclNewIndexObj(itemPtr, index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
- TclIndexDecode(sortInfo.indexv[j], listc)));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc));
+ Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_SetObjResult(interp, itemPtr);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, index);
+ Tcl_SetObjResult(interp, elObj);
}
} else if (index < 0) {
/*
@@ -3523,9 +3975,16 @@ Tcl_LsearchObjCmd(
* default...
*/
- Tcl_SetObjResult(interp, Tcl_NewObj());
+ Tcl_ResetResult(interp);
} else {
- Tcl_SetObjResult(interp, listv[index]);
+ if (returnSubindices) {
+ Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo));
+ } else if (groupSize > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
+ } else {
+ Tcl_SetObjResult(interp, listv[index]);
+ }
}
result = TCL_OK;
@@ -3534,7 +3993,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3543,6 +4005,406 @@ Tcl_LsearchObjCmd(
/*
*----------------------------------------------------------------------
*
+ * SequenceIdentifyArgument --
+ * (for [lseq] command)
+ *
+ * Given a Tcl_Obj, identify if it is a keyword or a number
+ *
+ * Return Value
+ * 0 - failure, unexpected value
+ * 1 - value is a number
+ * 2 - value is an operand keyword
+ * 3 - value is a by keyword
+ *
+ * The decoded value will be assigned to the appropriate
+ * pointer, if supplied.
+ */
+
+static SequenceDecoded
+SequenceIdentifyArgument(
+ Tcl_Interp *interp, /* for error reporting */
+ Tcl_Obj *argPtr, /* Argument to decode */
+ Tcl_Obj **numValuePtr, /* Return numeric value */
+ int *keywordIndexPtr) /* Return keyword enum */
+{
+ int status;
+ SequenceOperators opmode;
+ SequenceByMode bymode;
+ void *clientData;
+
+ status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr);
+ if (status == TCL_OK) {
+ if (numValuePtr) {
+ *numValuePtr = argPtr;
+ }
+ return NumericArg;
+ } else {
+ /* Check for an index expression */
+ long value;
+ double dvalue;
+ Tcl_Obj *exprValueObj;
+ int keyword;
+ Tcl_InterpState savedstate;
+ savedstate = Tcl_SaveInterpState(interp, status);
+ if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) {
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ exprValueObj = argPtr;
+ } else {
+ // Determine if expression is double or int
+ if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) {
+ keyword = TCL_NUMBER_INT;
+ exprValueObj = argPtr;
+ } else {
+ if (floor(dvalue) == dvalue) {
+ TclNewIntObj(exprValueObj, value);
+ keyword = TCL_NUMBER_INT;
+ } else {
+ TclNewDoubleObj(exprValueObj, dvalue);
+ keyword = TCL_NUMBER_DOUBLE;
+ }
+ }
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ if (numValuePtr) {
+ *numValuePtr = exprValueObj;
+ }
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = keyword ;// type of expression result
+ }
+ return NumericArg;
+ }
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
+ "range operation", 0, &opmode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = opmode;
+ }
+ return RangeKeywordArg;
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords,
+ "step keyword", 0, &bymode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = bymode;
+ }
+ return ByKeywordArg;
+ }
+ return NoneArg;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LseqObjCmd --
+ *
+ * This procedure is invoked to process the "lseq" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Enumerated possible argument patterns:
+ *
+ * 1:
+ * lseq n
+ * 2:
+ * lseq n n
+ * 3:
+ * lseq n n n
+ * lseq n 'to' n
+ * lseq n 'count' n
+ * lseq n 'by' n
+ * 4:
+ * lseq n 'to' n n
+ * lseq n n 'by' n
+ * lseq n 'count' n n
+ * 5:
+ * lseq n 'to' n 'by' n
+ * lseq n 'count' n 'by' n
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LseqObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_Obj *elementCount = NULL;
+ Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
+ Tcl_WideInt values[5];
+ Tcl_Obj *numValues[5];
+ Tcl_Obj *numberObj;
+ int status, keyword, useDoubles = 0;
+ Tcl_Obj *arithSeriesPtr;
+ SequenceOperators opmode;
+ SequenceDecoded decoded;
+ int i, arg_key = 0, value_i = 0;
+ // Default constants
+ Tcl_Obj *zero = Tcl_NewIntObj(0);
+ Tcl_Obj *one = Tcl_NewIntObj(1);
+
+ /*
+ * Create a decoding key by looping through the arguments and identify
+ * what kind of argument each one is. Encode each argument as a decimal
+ * digit.
+ */
+ if (objc > 6) {
+ /* Too many arguments */
+ arg_key=0;
+ } else for (i=1; i<objc; i++) {
+ arg_key = (arg_key * 10);
+ numValues[value_i] = NULL;
+ decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword);
+ switch (decoded) {
+
+ case NoneArg:
+ /*
+ * Unrecognizable argument
+ * Reproduce operation error message
+ */
+ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
+ "operation", 0, &opmode);
+ goto done;
+
+ case NumericArg:
+ arg_key += NumericArg;
+ numValues[value_i] = numberObj;
+ Tcl_IncrRefCount(numValues[value_i]);
+ values[value_i] = keyword; // This is the TCL_NUMBER_* value
+ useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE;
+ value_i++;
+ break;
+
+ case RangeKeywordArg:
+ arg_key += RangeKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ case ByKeywordArg:
+ arg_key += ByKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ default:
+ arg_key += 9; // Error state
+ value_i++;
+ break;
+ }
+ }
+
+ /*
+ * The key encoding defines a valid set of arguments, or indicates an
+ * error condition; process the values accordningly.
+ */
+ switch (arg_key) {
+
+/* No argument */
+ case 0:
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* lseq n */
+ case 1:
+ start = zero;
+ elementCount = numValues[0];
+ end = NULL;
+ step = one;
+ break;
+
+/* lseq n n */
+ case 11:
+ start = numValues[0];
+ end = numValues[1];
+ break;
+
+/* lseq n n n */
+ case 111:
+ start = numValues[0];
+ end = numValues[1];
+ step = numValues[2];
+ break;
+
+/* lseq n 'to' n */
+/* lseq n 'count' n */
+/* lseq n 'by' n */
+ case 121:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_BY:
+ start = zero;
+ elementCount = numValues[0];
+ step = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = one;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ }
+ break;
+
+/* lseq n 'to' n n */
+/* lseq n 'count' n n */
+ case 1211:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_BY:
+ /* Error case */
+ status = TCL_ERROR;
+ goto done;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* lseq n n 'by' n */
+ case 1121:
+ start = numValues[0];
+ end = numValues[1];
+ opmode = (SequenceOperators)values[2];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[3];
+ break;
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ case LSEQ_COUNT:
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* lseq n 'to' n 'by' n */
+/* lseq n 'count' n 'by' n */
+ case 12121:
+ start = numValues[0];
+ opmode = (SequenceOperators)values[3];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[4];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* Error cases: incomplete arguments */
+ case 12:
+ opmode = (SequenceOperators)values[1]; goto KeywordError; break;
+ case 112:
+ opmode = (SequenceOperators)values[2]; goto KeywordError; break;
+ case 1212:
+ opmode = (SequenceOperators)values[3]; goto KeywordError; break;
+ KeywordError:
+ status = TCL_ERROR;
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"to\" value."));
+ break;
+ case LSEQ_COUNT:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"count\" value."));
+ break;
+ case LSEQ_BY:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"by\" value."));
+ break;
+ }
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* All other argument errors */
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+
+ /*
+ * Success! Now lets create the series object.
+ */
+ status = TclNewArithSeriesObj(interp, &arithSeriesPtr,
+ useDoubles, start, end, step, elementCount);
+
+ if (status == TCL_OK) {
+ Tcl_SetObjResult(interp, arithSeriesPtr);
+ }
+
+ done:
+ // Free number arguments.
+ while (--value_i>=0) {
+ if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]);
+ }
+
+ // Free constants
+ Tcl_DecrRefCount(zero);
+ Tcl_DecrRefCount(one);
+
+ return status;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LsetObjCmd --
*
* This procedure is invoked to process the "lset" Tcl command. See the
@@ -3559,7 +4421,7 @@ Tcl_LsearchObjCmd(
int
Tcl_LsetObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -3644,7 +4506,7 @@ Tcl_LsetObjCmd(
int
Tcl_LsortObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -3654,6 +4516,7 @@ Tcl_LsortObjCmd(
int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
size_t elmArrSize;
+ Tcl_WideInt wide;
SortElement *elementArray = NULL, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
@@ -3712,7 +4575,7 @@ Tcl_LsortObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-command\" option must be followed "
"by comparison command", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -3730,18 +4593,18 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int sortindex;
+ Tcl_Size sortindex;
Tcl_Obj **indexv;
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- if (TclListObjGetElements(interp, objv[i+1], &sortindex,
+ if (TclListObjGetElementsM(interp, objv[i+1], &sortindex,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
@@ -3758,15 +4621,14 @@ Tcl_LsortObjCmd(
for (j=0 ; j<sortindex ; j++) {
int encoded = 0;
int result = TclIndexEncode(interp, indexv[j],
- TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded);
+ TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
- if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE)
- || (encoded == TCL_INDEX_AFTER))) {
+ if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%s\" cannot select an element "
- "from any list", Tcl_GetString(indexv[j])));
+ "index \"%s\" out of range",
+ TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
- "OUTOFRANGE", NULL);
+ "OUTOFRANGE", (void *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
@@ -3800,22 +4662,23 @@ Tcl_LsortObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- if (groupSize < 2) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "stride length must be at least 2", -1));
+ if ((wide < 2) || (wide > LIST_MAX)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "stride length must be between 2 and %d", LIST_MAX));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADSTRIDE", NULL);
+ "BADSTRIDE", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
+ groupSize = wide;
group = 1;
i++;
break;
@@ -3834,7 +4697,7 @@ Tcl_LsortObjCmd(
if (indexPtr) {
Tcl_Obj **indexv;
- TclListObjGetElements(interp, indexPtr, &sortInfo.indexc, &indexv);
+ TclListObjGetElementsM(interp, indexPtr, &sortInfo.indexc, &indexv);
switch (sortInfo.indexc) {
case 0:
sortInfo.indexv = NULL;
@@ -3850,7 +4713,8 @@ Tcl_LsortObjCmd(
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
- TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]);
+ TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &sortInfo.indexv[j]);
}
}
@@ -3889,12 +4753,18 @@ Tcl_LsortObjCmd(
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
+ TclNewObj(newObjPtr);
+ Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr);
sortInfo.compareCmdPtr = newCommandPtr;
}
- sortInfo.resultCode = TclListObjGetElements(interp, listObj,
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ sortInfo.resultCode = TclArithSeriesGetElements(interp,
+ listObj, &length, &listObjPtrs);
+ } else {
+ sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
+ }
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
@@ -3910,7 +4780,7 @@ Tcl_LsortObjCmd(
"list size must be a multiple of the stride length",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
- NULL);
+ (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -3927,7 +4797,7 @@ Tcl_LsortObjCmd(
"when used with \"-stride\", the leading \"-index\""
" value must be within the group", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
- "BADINDEX", NULL);
+ "BADINDEX", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -3989,12 +4859,12 @@ Tcl_LsortObjCmd(
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %d items", length));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
- for (i=0; i < length; i++){
+ for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
@@ -4077,18 +4947,18 @@ Tcl_LsortObjCmd(
*/
if (sortInfo.resultCode == TCL_OK) {
- List *listRepPtr;
+ ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
- listRepPtr = ListRepPtr(resultPtr);
- newArray = &listRepPtr->elements;
+ 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) {
- TclNewIntObj(objPtr, idx + j - groupOffset);
+ TclNewIndexObj(objPtr, idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
@@ -4100,7 +4970,7 @@ Tcl_LsortObjCmd(
}
} else if (indices) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
- TclNewIntObj(objPtr, elementPtr->payload.index);
+ TclNewIndexObj(objPtr, elementPtr->payload.index);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
}
@@ -4111,7 +4981,11 @@ Tcl_LsortObjCmd(
Tcl_IncrRefCount(objPtr);
}
}
- listRepPtr->elemCount = i;
+ listRep.storePtr->numUsed = i;
+ if (listRep.spanPtr) {
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
Tcl_SetObjResult(interp, resultPtr);
}
@@ -4137,6 +5011,123 @@ Tcl_LsortObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LeditObjCmd --
+ *
+ * This procedure is invoked to process the "ledit" 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_LeditObjCmd(
+ 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. */
+ int createdNewObj;
+ int result;
+ Tcl_Size first;
+ Tcl_Size last;
+ Tcl_Size listLen;
+ Tcl_Size numToDelete;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar first last ?element ...?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * TODO - refactor the index extraction into a common function shared
+ * by Tcl_{Lrange,Lreplace,Ledit}ObjCmd
+ */
+
+ result = TclListObjLengthM(interp, listPtr, &listLen);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[2], /*end*/ listLen-1, &first);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (first == TCL_INDEX_NONE) {
+ first = 0;
+ } else if (first > listLen) {
+ first = listLen;
+ }
+
+ if (last >= listLen) {
+ last = listLen - 1;
+ }
+ if (first <= last) {
+ numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */
+ } else {
+ numToDelete = 0;
+ }
+
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = TclListObjCopy(NULL, listPtr);
+ createdNewObj = 1;
+ } else {
+ createdNewObj = 0;
+ }
+
+ result =
+ Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4);
+ if (result != TCL_OK) {
+ if (createdNewObj) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ return result;
+ }
+
+ /*
+ * Tcl_ObjSetVar2 mau return a value different from listPtr in the
+ * presence of traces etc.. Note that finalValuePtr will always have a
+ * reference count of at least 1 corresponding to the reference from the
+ * var. If it is same as listPtr, then ref count will be at least 2
+ * since we are incr'ing the latter below (safer when calling
+ * Tcl_ObjSetVar2 which can release it in some cases). Note that we
+ * leave the incrref of listPtr this late because we want to pass it as
+ * unshared to Tcl_ListObjReplace above if possible.
+ */
+ Tcl_IncrRefCount(listPtr);
+ finalValuePtr =
+ Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */
+ if (finalValuePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, finalValuePtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* MergeLists -
*
* This procedure combines two sorted lists of SortElement structures
@@ -4264,7 +5255,7 @@ SortCompare(
int order = 0;
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
@@ -4286,7 +5277,7 @@ SortCompare(
order = ((a >= b) - (a <= b));
} else {
Tcl_Obj **objv, *paramObjv[2];
- int objc;
+ Tcl_Size objc;
Tcl_Obj *objPtr1, *objPtr2;
if (infoPtr->resultCode != TCL_OK) {
@@ -4310,10 +5301,10 @@ SortCompare(
* Replace them and evaluate the result.
*/
- TclListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+ TclListObjLengthM(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
2, 2, paramObjv);
- TclListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+ TclListObjGetElementsM(infoPtr->interp, infoPtr->compareCmdPtr,
&objc, &objv);
infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
@@ -4332,7 +5323,7 @@ SortCompare(
Tcl_SetObjResult(infoPtr->interp, Tcl_NewStringObj(
"-compare command returned non-integer result", -1));
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "COMPARISONFAILED", NULL);
+ "COMPARISONFAILED", (void *)NULL);
infoPtr->resultCode = TCL_ERROR;
return 0;
}
@@ -4440,8 +5431,8 @@ DictionaryCompare(
*/
if ((*left != '\0') && (*right != '\0')) {
- left += TclUtfToUCS4(left, &uniLeft);
- right += TclUtfToUCS4(right, &uniRight);
+ left += Tcl_UtfToUniChar(left, &uniLeft);
+ right += Tcl_UtfToUniChar(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
@@ -4450,8 +5441,8 @@ DictionaryCompare(
* other interesting punctuations occur).
*/
- uniLeftLower = TclUCS4ToLower(uniLeft);
- uniRightLower = TclUCS4ToLower(uniRight);
+ uniLeftLower = Tcl_UniCharToLower(uniLeft);
+ uniRightLower = Tcl_UniCharToLower(uniRight);
} else {
diff = UCHAR(*left) - UCHAR(*right);
break;
@@ -4504,7 +5495,7 @@ SelectObjFromSublist(
SortInfo *infoPtr) /* Information passed from the top-level
* "lsearch" or "lsort" command. */
{
- int i;
+ Tcl_Size i;
/*
* Quick check for case when no "-index" option is there.
@@ -4520,10 +5511,11 @@ SelectObjFromSublist(
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
- int listLen, index;
+ Tcl_Size listLen;
+ int index;
Tcl_Obj *currentObj;
- if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
@@ -4536,11 +5528,18 @@ SelectObjFromSublist(
return NULL;
}
if (currentObj == NULL) {
- Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
- "element %d missing from sublist \"%s\"",
- index, TclGetString(objPtr)));
+ if (index == TCL_INDEX_NONE) {
+ index = TCL_INDEX_END - infoPtr->indexv[i];
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element end-%d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ } else {
+ Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+ "element %d missing from sublist \"%s\"",
+ index, TclGetString(objPtr)));
+ }
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
- "INDEXFAILED", NULL);
+ "INDEXFAILED", (void *)NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d769da8..a2d7372 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -6,11 +6,11 @@
* contains only commands in the generic core (i.e. those that don't
* depend much upon UNIX facilities).
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2003-2009 Donal K. Fellows.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2003-2009 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -29,6 +29,9 @@ static Tcl_NRPostProc TryPostFinal;
static Tcl_NRPostProc TryPostHandler;
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
+static int StringCmpOpts(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int *nocase,
+ Tcl_Size *reqlength);
/*
* Default set of characters to trim in [string trim] and friends. This is a
@@ -82,7 +85,7 @@ const char tclDefaultTrimSet[] =
int
Tcl_PwdObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -122,13 +125,13 @@ Tcl_PwdObjCmd(
int
Tcl_RegexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i, indices, match, about, offset, all, doinline, numMatchesSaved;
- int cflags, eflags, stringLength, matchLength;
+ Tcl_Size offset, stringLength, matchLength, cflags, eflags;
+ int i, indices, match, about, all, doinline, numMatchesSaved;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
Tcl_RegExpInfo info;
@@ -191,11 +194,11 @@ Tcl_RegexpObjCmd(
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
- int temp;
+ Tcl_Size temp;
if (++i >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[i], TCL_SIZE_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -229,7 +232,7 @@ Tcl_RegexpObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"regexp match variables not allowed when using -inline", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
- "MIX_VAR_INLINE", NULL);
+ "MIX_VAR_INLINE", (void *)NULL);
goto optionError;
}
@@ -256,10 +259,10 @@ Tcl_RegexpObjCmd(
*/
objPtr = objv[1];
- stringLength = Tcl_GetCharLength(objPtr);
+ stringLength = TclGetCharLength(objPtr);
if (startIndex) {
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
@@ -310,7 +313,7 @@ Tcl_RegexpObjCmd(
eflags = 0;
} else if (offset > stringLength) {
eflags = TCL_REG_NOTBOL;
- } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
+ } else if (TclGetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
@@ -336,7 +339,7 @@ Tcl_RegexpObjCmd(
*/
if (!doinline) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
}
return TCL_OK;
}
@@ -364,7 +367,7 @@ Tcl_RegexpObjCmd(
Tcl_Obj *newPtr;
if (indices) {
- int start, end;
+ Tcl_Size start, end;
Tcl_Obj *objs[2];
/*
@@ -385,17 +388,17 @@ Tcl_RegexpObjCmd(
end--;
}
} else {
- start = -1;
- end = -1;
+ start = TCL_INDEX_NONE;
+ end = TCL_INDEX_NONE;
}
- objs[0] = Tcl_NewLongObj(start);
- objs[1] = Tcl_NewLongObj(end);
+ TclNewIndexObj(objs[0], start);
+ TclNewIndexObj(objs[1], end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if ((i <= info.nsubs) && (info.matches[i].end > 0)) {
- newPtr = Tcl_GetRange(objPtr,
+ newPtr = TclGetRange(objPtr,
offset + info.matches[i].start,
offset + info.matches[i].end - 1);
} else {
@@ -458,7 +461,7 @@ Tcl_RegexpObjCmd(
if (doinline) {
Tcl_SetObjResult(interp, resultPtr);
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1));
}
return TCL_OK;
}
@@ -482,32 +485,34 @@ Tcl_RegexpObjCmd(
int
Tcl_RegsubObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
- int start, end, subStart, subEnd, match;
+ int result, cflags, all, match, command;
+ Tcl_Size idx, wlen, wsublen, offset, numMatches, numParts;
+ Tcl_Size start, end, subStart, subEnd;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
- Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
+ Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
- "-all", "-nocase", "-expanded",
- "-line", "-linestop", "-lineanchor", "-start",
+ "-all", "-command", "-expanded", "-line",
+ "-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
- enum options {
- REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
- REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
+ enum regsubobjoptions {
+ REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
+ REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
+ command = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
@@ -522,13 +527,16 @@ Tcl_RegsubObjCmd(
TCL_EXACT, &index) != TCL_OK) {
goto optionError;
}
- switch ((enum options) index) {
+ switch ((enum regsubobjoptions) index) {
case REGSUB_ALL:
all = 1;
break;
case REGSUB_NOCASE:
cflags |= TCL_REG_NOCASE;
break;
+ case REGSUB_COMMAND:
+ command = 1;
+ break;
case REGSUB_EXPANDED:
cflags |= TCL_REG_EXPANDED;
break;
@@ -542,11 +550,11 @@ Tcl_RegsubObjCmd(
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
- int temp;
+ Tcl_Size temp;
if (++idx >= objc) {
goto endOfForLoop;
}
- if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[idx], TCL_SIZE_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
@@ -563,7 +571,7 @@ Tcl_RegsubObjCmd(
}
endOfForLoop:
- if (objc-idx < 3 || objc-idx > 4) {
+ if (objc < idx + 3 || objc > idx + 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option ...? exp string subSpec ?varName?");
optionError:
@@ -577,16 +585,16 @@ Tcl_RegsubObjCmd(
objv += idx;
if (startIndex) {
- int stringLength = Tcl_GetCharLength(objv[1]);
+ Tcl_Size stringLength = TclGetCharLength(objv[1]);
- TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
+ TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
}
}
- if (all && (offset == 0)
+ if (all && (offset == 0) && (command == 0)
&& (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
&& (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
@@ -594,17 +602,18 @@ Tcl_RegsubObjCmd(
* slightly modified version of the one pair STR_MAP code.
*/
- int slen, nocase;
+ Tcl_Size slen;
+ int nocase, wsrclc;
int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long);
- Tcl_UniChar *p, wsrclc;
+ Tcl_UniChar *p;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
- strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
+ strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp;
- wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
- wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
- wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
+ wsrc = TclGetUnicodeFromObj(objv[0], &slen);
+ wstring = TclGetUnicodeFromObj(objv[1], &wlen);
+ wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
@@ -615,11 +624,11 @@ Tcl_RegsubObjCmd(
*/
if (wstring < wend) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
for (; wstring < wend; wstring++) {
- Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
- Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
+ TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ TclAppendUnicodeToObj(resultPtr, wstring, 1);
numMatches++;
}
wlen = 0;
@@ -632,18 +641,18 @@ Tcl_RegsubObjCmd(
(slen==1 || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
- Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
+ TclAppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
} else {
p += slen;
}
wstring = p - 1;
- Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen);
numMatches++;
}
}
@@ -662,6 +671,28 @@ Tcl_RegsubObjCmd(
return TCL_ERROR;
}
+ if (command) {
+ /*
+ * 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",
+ "CMDEMPTY", (void *)NULL);
+ return TCL_ERROR;
+ }
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ }
+
/*
* Make sure to avoid problems where the objects are shared. This can
* cause RegExpObj <> UnicodeObj shimmering that causes data corruption.
@@ -673,13 +704,15 @@ Tcl_RegsubObjCmd(
} else {
objPtr = objv[1];
}
- wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
+ wstring = TclGetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
- wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+ if (!command) {
+ wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen);
+ }
result = TCL_OK;
@@ -714,7 +747,7 @@ Tcl_RegsubObjCmd(
break;
}
if (numMatches == 0) {
- resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ resultPtr = TclNewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
@@ -722,7 +755,7 @@ Tcl_RegsubObjCmd(
* specified.
*/
- Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
+ TclAppendUnicodeToObj(resultPtr, wstring, offset);
}
}
numMatches++;
@@ -735,7 +768,91 @@ Tcl_RegsubObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
start = info.matches[0].start;
end = info.matches[0].end;
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, start);
+
+ /*
+ * In command-prefix mode, the substitutions are added as quoted
+ * 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;
+ Tcl_Size numArgs;
+
+ TclListObjGetElementsM(interp, subPtr, &numParts, &parts);
+ numArgs = numParts + info.nsubs + 1;
+ args = (Tcl_Obj **)ckalloc(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;
+ if ((subStart >= 0) && (subEnd >= 0)) {
+ args[idx + numParts] = TclNewUnicodeObj(
+ wstring + offset + subStart, subEnd - subStart);
+ } else {
+ TclNewObj(args[idx + numParts]);
+ }
+ Tcl_IncrRefCount(args[idx + numParts]);
+ }
+
+ /*
+ * At this point, we're locally holding the references to the
+ * argument words we added for this time round the loop, and the
+ * subPtr is holding the references to the words that the user
+ * supplied directly. None are zero-refcount, which is important
+ * because Tcl_EvalObjv is "hairy monster" in terms of refcount
+ * handling, being able to optionally add references to any of its
+ * argument words. We'll drop the local refs immediately
+ * afterwards; subPtr is handled in the main exit stanza.
+ */
+
+ result = Tcl_EvalObjv(interp, numArgs, args, 0);
+ for (idx = 0 ; idx <= info.nsubs ; idx++) {
+ TclDecrRefCount(args[idx + numParts]);
+ }
+ ckfree(args);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (%s substitution computation script)",
+ options[REGSUB_COMMAND]));
+ }
+ goto done;
+ }
+
+ Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
+ Tcl_ResetResult(interp);
+
+ /*
+ * Refetch the unicode, in case the representation was smashed by
+ * the user code.
+ */
+
+ wstring = TclGetUnicodeFromObj(objPtr, &wlen);
+
+ offset += end;
+ if (end == 0 || start == end) {
+ /*
+ * Always consume at least one character of the input string
+ * in order to prevent infinite loops, even when we
+ * technically matched the empty string; we must not match
+ * again at the same spot.
+ */
+
+ if (offset < wlen) {
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ }
+ offset++;
+ }
+ if (all) {
+ continue;
+ } else {
+ break;
+ }
+ }
/*
* Append the subSpec argument to the variable, making appropriate
@@ -755,7 +872,7 @@ Tcl_RegsubObjCmd(
idx = ch - '0';
} else if ((ch == '\\') || (ch == '&')) {
*wsrc = ch;
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ TclAppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar + 1);
*wsrc = '\\';
wfirstChar = wsrc + 2;
@@ -769,7 +886,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ TclAppendUnicodeToObj(resultPtr, wfirstChar,
wsrc - wfirstChar);
}
@@ -777,7 +894,7 @@ Tcl_RegsubObjCmd(
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
- Tcl_AppendUnicodeToObj(resultPtr,
+ TclAppendUnicodeToObj(resultPtr,
wstring + offset + subStart, subEnd - subStart);
}
}
@@ -789,7 +906,7 @@ Tcl_RegsubObjCmd(
}
if (wfirstChar != wsrc) {
- Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
+ TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
@@ -799,7 +916,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
@@ -811,7 +928,7 @@ Tcl_RegsubObjCmd(
*/
if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
@@ -836,7 +953,7 @@ Tcl_RegsubObjCmd(
resultPtr = objv[1];
Tcl_IncrRefCount(resultPtr);
} else if (offset < wlen) {
- Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
+ TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
if (objc == 4) {
if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr,
@@ -848,7 +965,7 @@ Tcl_RegsubObjCmd(
* holding the number of matches.
*/
- Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches));
}
} else {
/*
@@ -890,7 +1007,7 @@ Tcl_RegsubObjCmd(
int
Tcl_RenameObjCmd(
- ClientData dummy, /* Arbitrary value passed to the command. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -926,7 +1043,7 @@ Tcl_RenameObjCmd(
int
Tcl_ReturnObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -940,7 +1057,7 @@ Tcl_ReturnObjCmd(
*/
int explicitResult = (0 == (objc % 2));
- int numOptionWords = objc - 1 - explicitResult;
+ Tcl_Size numOptionWords = objc - 1 - explicitResult;
if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1,
&returnOpts, &code, &level)) {
@@ -973,25 +1090,28 @@ Tcl_ReturnObjCmd(
int
Tcl_SourceObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
- ClientData dummy, /* Not used. */
+ 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;
+ void **pkgFiles = NULL;
+ void *names = NULL;
- if (objc != 2 && objc !=4) {
+ if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
return TCL_ERROR;
}
@@ -1009,9 +1129,30 @@ TclNRSourceObjCmd(
return TCL_ERROR;
}
encodingName = TclGetString(objv[2]);
- }
+ } else if (objc == 3) {
+ /* Handle undocumented -nopkg option. This should only be
+ * used by the internal ::tcl::Pkg::source utility function. */
+ static const char *const nopkgoptions[] = {
+ "-nopkg", NULL
+ };
+ int index;
- return TclNREvalFile(interp, fileName, encodingName);
+ if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
+ "option", TCL_EXACT, &index)) {
+ return TCL_ERROR;
+ }
+ pkgFiles = (void **)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ /* Make sure that during the following TclNREvalFile no filenames
+ * are recorded for inclusion in the "package files" command */
+ names = *pkgFiles;
+ *pkgFiles = NULL;
+ }
+ result = TclNREvalFile(interp, fileName, encodingName);
+ if (pkgFiles) {
+ /* restore "tclPkgFiles" assocdata to how it was. */
+ *pkgFiles = names;
+ }
+ return result;
}
/*
@@ -1033,17 +1174,17 @@ TclNRSourceObjCmd(
int
Tcl_SplitObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
+ int ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
- int splitCharLen, stringLen;
+ Tcl_Size splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
@@ -1081,10 +1222,8 @@ Tcl_SplitObjCmd(
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
- int ucs4;
-
- len = TclUtfToUCS4(stringPtr, &ucs4);
- hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ucs4), &isNew);
+ len = Tcl_UtfToUniChar(stringPtr, &ch);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1109,7 +1248,7 @@ Tcl_SplitObjCmd(
* byte in length.
*/
- while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
+ while (*stringPtr && (p=strchr(stringPtr,*splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
stringPtr = p + 1;
@@ -1118,8 +1257,8 @@ Tcl_SplitObjCmd(
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
const char *element, *p, *splitEnd;
- int splitLen;
- Tcl_UniChar splitChar = 0;
+ Tcl_Size splitLen;
+ int splitChar;
/*
* Normal case: split on any of a given set of characters. Discard
@@ -1129,9 +1268,9 @@ Tcl_SplitObjCmd(
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
- len = TclUtfToUniChar(stringPtr, &ch);
+ len = Tcl_UtfToUniChar(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
- splitLen = TclUtfToUniChar(p, &splitChar);
+ splitLen = Tcl_UtfToUniChar(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
@@ -1168,13 +1307,12 @@ Tcl_SplitObjCmd(
static int
StringFirstCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr;
- int match, start, needleLen, haystackLen;
+ Tcl_Size start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1182,82 +1320,14 @@ StringFirstCmd(
return TCL_ERROR;
}
- /*
- * We are searching haystackStr for the sequence needleStr.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to fast forward to that
- * point in the string before we think about a match.
- */
+ Tcl_Size end = TclGetCharLength(objv[2]) - 1;
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
return TCL_ERROR;
}
-
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start >= haystackLen) {
- goto str_first_done;
- } else if (start > 0) {
- haystackStr += start;
- haystackLen -= start;
- } else if (start < 0) {
- /*
- * Invalid start index mapped to string start; Bug #423581
- */
-
- start = 0;
- }
- }
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- Tcl_UniChar *p, *end;
-
- end = haystackStr + haystackLen - needleLen + 1;
- for (p = haystackStr; p < end; p++) {
- /*
- * Scan forward to find the first character.
- */
-
- if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p,
- (unsigned long) needleLen) == 0)) {
- match = p - haystackStr;
- break;
- }
- }
}
-
- /*
- * Compute the character index of the matching string by counting the
- * number of characters before the match.
- */
-
- if ((match != -1) && (objc == 4)) {
- match += start;
- }
-
- str_first_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
return TCL_OK;
}
@@ -1281,81 +1351,27 @@ StringFirstCmd(
static int
StringLastCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr, *p;
- int match, start, needleLen, haystackLen;
+ Tcl_Size last = TCL_SIZE_MAX;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "needleString haystackString ?startIndex?");
+ "needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
- /*
- * We are searching haystackString for the sequence needleString.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to restrict the string
- * range to that char index in the string
- */
+ Tcl_Size end = TclGetCharLength(objv[2]) - 1;
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) {
return TCL_ERROR;
}
-
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start < 0) {
- goto str_last_done;
- } else if (start < haystackLen) {
- p = haystackStr + start + 1 - needleLen;
- } else {
- p = haystackStr + haystackLen - needleLen;
- }
- } else {
- p = haystackStr + haystackLen - needleLen;
}
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- for (; p >= haystackStr; p--) {
- /*
- * Scan backwards to find the first character.
- */
-
- if ((*p == *needleStr) && !memcmp(needleStr, p,
- sizeof(Tcl_UniChar) * (size_t)needleLen)) {
- match = p - haystackStr;
- break;
- }
- }
- }
-
- str_last_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
return TCL_OK;
}
@@ -1379,12 +1395,12 @@ StringLastCmd(
static int
StringIndexCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length, index;
+ Tcl_Size index, end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
@@ -1395,13 +1411,17 @@ StringIndexCmd(
* Get the char length to calculate what 'end' means.
*/
- length = Tcl_GetCharLength(objv[1]);
- if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
+ end = TclGetCharLength(objv[1]) - 1;
+ if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) {
return TCL_ERROR;
}
- if ((index >= 0) && (index < length)) {
- int ch = TclGetUCS4(objv[1], index);
+ if ((index >= 0) && (index <= end)) {
+ int ch = TclGetUniChar(objv[1], index);
+
+ if (ch == -1) {
+ return TCL_OK;
+ }
/*
* If we have a ByteArray object, we're careful to generate a new
@@ -1413,10 +1433,13 @@ StringIndexCmd(
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
- char buf[8] = "";
+ char buf[4] = "";
- length = TclUCS4ToUtf(ch, buf);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
+ 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;
@@ -1425,6 +1448,63 @@ StringIndexCmd(
/*
*----------------------------------------------------------------------
*
+ * StringInsertCmd --
+ *
+ * This procedure is invoked to process the "string insert" Tcl command.
+ * See the user documentation for details on what it does. Note that this
+ * command only functions correctly on properly formed Tcl UTF strings.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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 */
+{
+ Tcl_Size length; /* String length */
+ Tcl_Size index; /* Insert index */
+ Tcl_Obj *outObj; /* Output object */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
+ return TCL_ERROR;
+ }
+
+ length = TclGetCharLength(objv[1]);
+ if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (index < 0) {
+ index = 0;
+ }
+ if (index > length) {
+ index = length;
+ }
+
+ outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
+ TCL_STRING_IN_PLACE);
+
+ if (outObj != NULL) {
+ Tcl_SetObjResult(interp, outObj);
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* StringIsCmd --
*
* This procedure is invoked to process the "string is" Tcl command. See
@@ -1442,7 +1522,7 @@ StringIndexCmd(
static int
StringIsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1455,24 +1535,24 @@ StringIsCmd(
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
- enum isClasses {
+ enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
- STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
- STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
+ STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
+ STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
static const char *const isOptions[] = {
"-strict", "-failindex", NULL
};
- enum isOptions {
+ enum isOptionsEnum {
OPT_STRICT, OPT_FAILIDX
};
@@ -1494,7 +1574,7 @@ StringIsCmd(
&idx2) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum isOptions) idx2) {
+ switch ((enum isOptionsEnum) idx2) {
case OPT_STRICT:
strict = 1;
break;
@@ -1523,7 +1603,7 @@ StringIsCmd(
* When entering here, result == 1 and failat == 0.
*/
- switch ((enum isClasses) index) {
+ switch ((enum isClassesEnum) index) {
case STR_IS_ALNUM:
chcomp = Tcl_UniCharIsAlnum;
break;
@@ -1536,7 +1616,7 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if ((objPtr->typePtr != &tclBooleanType)
+ if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
@@ -1544,26 +1624,72 @@ StringIsCmd(
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
- } else if (((index == STR_IS_TRUE) &&
- objPtr->internalRep.longValue == 0)
- || ((index == STR_IS_FALSE) &&
- objPtr->internalRep.longValue != 0)) {
- result = 0;
+ } else if (index != STR_IS_BOOL) {
+ TclGetBooleanFromObj(NULL, objPtr, &i);
+ if ((index == STR_IS_TRUE) ^ i) {
+ result = 0;
+ }
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
+ case STR_IS_DICT: {
+ int dresult;
+ Tcl_Size 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
+ * fairly expensive. This is adapted from the core of
+ * SetDictFromAny().
+ */
+
+ const char *elemStart, *nextElem;
+ Tcl_Size lenRemain, elemSize;
+ const char *p;
+
+ string1 = TclGetStringFromObj(objPtr, &length1);
+ end = string1 + length1;
+ failat = -1;
+ for (p=string1, lenRemain=length1; lenRemain > 0;
+ p=nextElem, lenRemain=end-nextElem) {
+ if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
+ &elemStart, &nextElem, &elemSize, NULL)) {
+ Tcl_Obj *tmpStr;
+
+ /*
+ * This is the simplest way of getting the number of
+ * characters parsed. Note that this is not the same as
+ * the number of bytes when parsing strings with non-ASCII
+ * characters in them.
+ *
+ * Skip leading spaces first. This is only really an issue
+ * if it is the first "element" that has the failure.
+ */
+
+ while (TclIsSpaceProc(*p)) {
+ p++;
+ }
+ TclNewStringObj(tmpStr, string1, p-string1);
+ failat = TclGetCharLength(tmpStr);
+ TclDecrRefCount(tmpStr);
+ break;
+ }
+ }
+ }
+ break;
+ }
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
- if ((objPtr->typePtr == &tclDoubleType) ||
- (objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
- (objPtr->typePtr == &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, &tclDoubleType) ||
+ TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1574,7 +1700,7 @@ StringIsCmd(
goto str_is_done;
}
end = string1 + length1;
- if (TclParseNumber(NULL, objPtr, NULL, NULL, -1,
+ if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE,
(const char **) &stop, 0) != TCL_OK) {
result = 0;
failat = 0;
@@ -1582,7 +1708,7 @@ StringIsCmd(
failat = stop - string1;
if (stop < end) {
result = 0;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
}
break;
@@ -1591,16 +1717,9 @@ StringIsCmd(
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) {
- break;
- }
- goto failedIntParse;
case STR_IS_ENTIER:
- if ((objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
- (objPtr->typePtr == &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1611,7 +1730,7 @@ StringIsCmd(
goto str_is_done;
}
end = string1 + length1;
- if (TclParseNumber(NULL, objPtr, NULL, NULL, -1,
+ if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE,
(const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) {
if (stop == end) {
/*
@@ -1629,7 +1748,7 @@ StringIsCmd(
result = 0;
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1645,7 +1764,6 @@ StringIsCmd(
break;
}
- failedIntParse:
string1 = TclGetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
@@ -1663,7 +1781,7 @@ StringIsCmd(
break;
}
end = string1 + length1;
- if (TclParseNumber(NULL, objPtr, NULL, NULL, -1,
+ if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE,
(const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) {
if (stop == end) {
/*
@@ -1683,7 +1801,7 @@ StringIsCmd(
*/
failat = stop - string1;
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
}
} else {
/*
@@ -1699,7 +1817,7 @@ StringIsCmd(
* well-formed lists.
*/
- if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) {
+ if (TCL_OK == TclListObjLengthM(NULL, objPtr, &length2)) {
break;
}
@@ -1711,7 +1829,7 @@ StringIsCmd(
*/
const char *elemStart, *nextElem;
- int lenRemain, elemSize;
+ Tcl_Size lenRemain, elemSize;
const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1737,7 +1855,7 @@ StringIsCmd(
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
- failat = Tcl_GetCharLength(tmpStr);
+ failat = TclGetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
@@ -1760,6 +1878,9 @@ StringIsCmd(
case STR_IS_UPPER:
chcomp = Tcl_UniCharIsUpper;
break;
+ case STR_IS_UNICODE:
+ chcomp = Tcl_UniCharIsUnicode;
+ break;
case STR_IS_WORD:
chcomp = Tcl_UniCharIsWordChar;
break;
@@ -1780,7 +1901,7 @@ StringIsCmd(
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
- length2 = TclUtfToUCS4(string1, &ucs4);
+ length2 = Tcl_UtfToUniChar(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
@@ -1794,10 +1915,11 @@ StringIsCmd(
*/
str_is_done:
- if ((result == 0) && (failVarObj != NULL) &&
- Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
- TCL_LEAVE_ERR_MSG) == NULL) {
- return TCL_ERROR;
+ if ((result == 0) && (failVarObj != NULL)) {
+ TclNewIndexObj(objPtr, failat);
+ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
@@ -1814,7 +1936,7 @@ static int
UniCharIsHexDigit(
int character)
{
- return (character >= 0) && (character < 0x80) && isxdigit(character);
+ return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character));
}
/*
@@ -1837,12 +1959,12 @@ UniCharIsHexDigit(
static int
StringMapCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length1, length2, mapElemc, index;
+ Tcl_Size length1, length2, mapElemc, index;
int nocase = 0, mapWithDict = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
@@ -1863,17 +1985,18 @@ StringMapCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string, NULL);
+ string, (void *)NULL);
return TCL_ERROR;
}
}
/*
* This test is tricky, but has to be that way or you get other strange
- * inconsistencies (see test string-10.20 for illustration why!)
+ * inconsistencies (see test string-10.20.1 for illustration why!)
*/
- if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){
+ if (!TclHasStringRep(objv[objc-2])
+ && TclHasInternalRep(objv[objc-2], &tclDictType)) {
int i, done;
Tcl_DictSearch search;
@@ -1908,7 +2031,7 @@ StringMapCmd(
}
Tcl_DictObjDone(&search);
} else {
- if (TclListObjGetElements(interp, objv[objc-2], &mapElemc,
+ if (TclListObjGetElementsM(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1927,7 +2050,7 @@ StringMapCmd(
Tcl_SetObjResult(interp,
Tcl_NewStringObj("char map list unbalanced", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
- "UNBALANCED", NULL);
+ "UNBALANCED", (void *)NULL);
return TCL_ERROR;
}
}
@@ -1943,7 +2066,7 @@ StringMapCmd(
} else {
sourceObj = objv[objc-1];
}
- ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
+ ustring1 = TclGetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now.
@@ -1953,13 +2076,13 @@ StringMapCmd(
}
end = ustring1 + length1;
- strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
+ strCmpFn = (nocase ? TclUniCharNcasecmp : TclUniCharNcmp);
/*
* Force result to be Unicode
*/
- resultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ resultPtr = TclNewUnicodeObj(ustring1, 0);
if (mapElemc == 2) {
/*
@@ -1969,10 +2092,11 @@ StringMapCmd(
* larger strings.
*/
- int mapLen;
- Tcl_UniChar *mapString, u2lc;
+ Tcl_Size mapLen;
+ int u2lc;
+ Tcl_UniChar *mapString;
- ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+ ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/*
@@ -1981,7 +2105,7 @@ StringMapCmd(
ustring1 = end;
} else {
- mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
+ mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
@@ -1989,20 +2113,21 @@ StringMapCmd(
(length2==1 || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
- Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
+ TclAppendUnicodeToObj(resultPtr, mapString, mapLen);
}
}
}
} else {
- Tcl_UniChar **mapStrings, *u2lc = NULL;
- int *mapLens;
+ Tcl_UniChar **mapStrings;
+ Tcl_Size *mapLens;
+ int *u2lc = NULL;
/*
* Precompute pointers to the Unicode string and length. This saves us
@@ -2011,13 +2136,13 @@ StringMapCmd(
* case.
*/
- mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
- mapLens = (int *)TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
+ mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2);
+ mapLens = (Tcl_Size *)TclStackAlloc(interp, mapElemc * sizeof(Tcl_Size) * 2);
if (nocase) {
- u2lc = (Tcl_UniChar *)TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar));
+ u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
}
for (index = 0; index < mapElemc; index++) {
- mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
+ mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index],
mapLens+index);
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
@@ -2041,7 +2166,7 @@ StringMapCmd(
* Put the skipped chars onto the result first.
*/
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
@@ -2057,7 +2182,7 @@ StringMapCmd(
* Append the map value to the Unicode string.
*/
- Tcl_AppendUnicodeToObj(resultPtr,
+ TclAppendUnicodeToObj(resultPtr,
mapStrings[index+1], mapLens[index+1]);
break;
}
@@ -2074,7 +2199,7 @@ StringMapCmd(
* Put the rest of the unmapped chars onto result.
*/
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
+ TclAppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
Tcl_SetObjResult(interp, resultPtr);
done:
@@ -2107,7 +2232,7 @@ StringMapCmd(
static int
StringMatchCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2120,7 +2245,7 @@ StringMatchCmd(
}
if (objc == 4) {
- int length;
+ Tcl_Size length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) &&
@@ -2130,7 +2255,7 @@ StringMatchCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase", string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string, NULL);
+ string, (void *)NULL);
return TCL_ERROR;
}
}
@@ -2159,12 +2284,12 @@ StringMatchCmd(
static int
StringRangeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length, first, last;
+ Tcl_Size first, last, end;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last");
@@ -2176,21 +2301,15 @@ StringRangeCmd(
* 'end' refers to the last character, not one past it.
*/
- length = Tcl_GetCharLength(objv[1]) - 1;
+ end = TclGetCharLength(objv[1]) - 1;
- if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
- TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) {
+ if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
+ TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
- if (first < 0) {
- first = 0;
- }
- if (last >= length) {
- last = length;
- }
- if (last >= first) {
- Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
+ if (last >= 0) {
+ Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last));
}
return TCL_OK;
}
@@ -2215,14 +2334,12 @@ StringRangeCmd(
static int
StringReptCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *string1;
- char *string2;
- int count, index, length1, length2;
+ int count;
Tcl_Obj *resultPtr;
if (objc != 3) {
@@ -2240,71 +2357,17 @@ StringReptCmd(
if (count == 1) {
Tcl_SetObjResult(interp, objv[1]);
- goto done;
+ return TCL_OK;
} else if (count < 1) {
- goto done;
- }
- string1 = TclGetStringFromObj(objv[1], &length1);
- if (length1 <= 0) {
- goto done;
- }
-
- /*
- * Only build up a string that has data. Instead of building it up with
- * repeated appends, we just allocate the necessary space once and copy
- * the string value in.
- *
- * We have to worry about overflow [Bugs 714106, 2561746].
- * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX.
- * We need to keep 2 <= length2 <= INT_MAX.
- */
-
- if (count > INT_MAX/length1) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "result exceeds max size for a Tcl value (%d bytes)",
- INT_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- return TCL_ERROR;
+ return TCL_OK;
}
- length2 = length1 * count;
-
- /*
- * Include space for the NUL.
- */
-
- string2 = (char *)attemptckalloc(length2 + 1);
- if (string2 == NULL) {
- /*
- * Alloc failed. Note that in this case we try to do an error message
- * since this is a case that's most likely when the alloc is large and
- * that's easy to do with this API. Note that if we fail allocating a
- * short string, this will likely keel over too (and fatally).
- */
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "string size overflow, out of memory allocating %u bytes",
- length2 + 1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- return TCL_ERROR;
- }
- for (index = 0; index < count; index++) {
- memcpy(string2 + (length1 * index), string1, length1);
+ resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE);
+ if (resultPtr) {
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
}
- string2[length2] = '\0';
-
- /*
- * We have to directly assign this instead of using Tcl_SetStringObj (and
- * indirectly TclInitStringRep) because that makes another copy of the
- * data.
- */
-
- TclNewObj(resultPtr);
- resultPtr->bytes = string2;
- resultPtr->length = length2;
- Tcl_SetObjResult(interp, resultPtr);
-
- done:
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -2327,64 +2390,57 @@ StringReptCmd(
static int
StringRplcCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring;
- int first, last, length, end;
+ Tcl_Size first, last, end;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
- end = length - 1;
+ end = TclGetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
- TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){
+ TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
/*
- * The following test screens out most empty substrings as
- * candidates for replacement. When they are detected, no
- * replacement is done, and the result is the original string,
+ * The following test screens out most empty substrings as candidates for
+ * replacement. When they are detected, no replacement is done, and the
+ * result is the original string.
*/
+
if ((last < 0) || /* Range ends before start of string */
(first > end) || /* Range begins after end of string */
(last < first)) { /* Range begins after it starts */
-
/*
* BUT!!! when (end < 0) -- an empty original string -- we can
* have (first <= end < 0 <= last) and an empty string is permitted
* to be replaced.
*/
+
Tcl_SetObjResult(interp, objv[1]);
} else {
Tcl_Obj *resultPtr;
- /*
- * We are re-fetching in case the string argument is same value as
- * an index argument, and shimmering cost us our ustring.
- */
-
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
- end = length-1;
-
if (first < 0) {
first = 0;
}
-
- resultPtr = Tcl_NewUnicodeObj(ustring, first);
- if (objc == 5) {
- Tcl_AppendObjToObj(resultPtr, objv[4]);
+ if (last > end) {
+ last = end;
}
- if (last < end) {
- Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1,
- end - last);
+
+ resultPtr = TclStringReplace(interp, objv[1], first,
+ last + 1 - first, (objc == 5) ? objv[4] : NULL,
+ TCL_STRING_IN_PLACE);
+
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
}
@@ -2411,7 +2467,7 @@ StringRplcCmd(
static int
StringRevCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2421,7 +2477,7 @@ StringRevCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclStringReverse(objv[1]));
+ Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE));
return TCL_OK;
}
@@ -2431,9 +2487,7 @@ StringRevCmd(
* StringStartCmd --
*
* This procedure is invoked to process the "string wordstart" Tcl
- * command. See the user documentation for details on what it does. Note
- * that this command only functions correctly on properly formed Tcl UTF
- * strings.
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -2446,46 +2500,46 @@ StringRevCmd(
static int
StringStartCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
- const char *p, *string;
- int cur, index, length, numChars;
+ int ch;
+ const Tcl_UniChar *p, *string;
+ Tcl_Size cur, index, length;
+ Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- numChars = Tcl_NumUtfChars(string, length);
- if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
+ string = TclGetUnicodeFromObj(objv[1], &length);
+ if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- if (index >= numChars) {
- index = numChars - 1;
+ if (index >= length) {
+ index = length - 1;
}
cur = 0;
if (index > 0) {
- p = Tcl_UtfAtIndex(string, index);
+ p = &string[index];
- TclUtfToUniChar(p, &ch);
- for (cur = index; cur >= 0; cur--) {
+ ch = *p;
+ for (cur = index; cur != TCL_INDEX_NONE; cur--) {
int delta = 0;
- const char *next;
+ const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
- next = TclUtfPrev(p, string);
+ next = (p > string) ? p - 1 : p;
do {
next += delta;
- delta = TclUtfToUniChar(next, &ch);
+ ch = *next;
+ delta = 1;
} while (next + delta < p);
p = next;
}
@@ -2493,7 +2547,8 @@ StringStartCmd(
cur += 1;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ TclNewIndexObj(obj, cur);
+ Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -2503,8 +2558,7 @@ StringStartCmd(
* StringEndCmd --
*
* This procedure is invoked to process the "string wordend" Tcl command.
- * See the user documentation for details on what it does. Note that this
- * command only functions correctly on properly formed Tcl UTF strings.
+ * See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -2517,34 +2571,33 @@ StringStartCmd(
static int
StringEndCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar ch = 0;
- const char *p, *end, *string;
- int cur, index, length, numChars;
+ int ch;
+ const Tcl_UniChar *p, *end, *string;
+ Tcl_Size cur, index, length;
+ Tcl_Obj *obj;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
- numChars = Tcl_NumUtfChars(string, length);
- if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
+ string = TclGetUnicodeFromObj(objv[1], &length);
+ if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
- string = TclGetStringFromObj(objv[1], &length);
if (index < 0) {
index = 0;
}
- if (index < numChars) {
- p = Tcl_UtfAtIndex(string, index);
+ if (index < length) {
+ p = &string[index];
end = string+length;
for (cur = index; p < end; cur++) {
- p += TclUtfToUniChar(p, &ch);
+ ch = *p++;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
@@ -2553,9 +2606,10 @@ StringEndCmd(
cur++;
}
} else {
- cur = numChars;
+ cur = length;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
+ TclNewIndexObj(obj, cur);
+ Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -2579,7 +2633,7 @@ StringEndCmd(
static int
StringEqualCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2591,7 +2645,9 @@ StringEqualCmd(
*/
const char *string2;
- int length2, i, match, nocase = 0, reqlength = -1;
+ int i, match, nocase = 0;
+ Tcl_Size length;
+ Tcl_WideInt reqlength = -1;
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2601,24 +2657,27 @@ StringEqualCmd(
}
for (i = 1; i < objc-2; i++) {
- string2 = TclGetStringFromObj(objv[i], &length2);
- if ((length2 > 1) && !strncmp(string2, "-nocase", length2)) {
+ string2 = TclGetStringFromObj(objv[i], &length);
+ if ((length > 1) && !strncmp(string2, "-nocase", length)) {
nocase = 1;
- } else if ((length2 > 1)
- && !strncmp(string2, "-length", length2)) {
+ } else if ((length > 1)
+ && !strncmp(string2, "-length", length)) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
i++;
- if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) {
return TCL_ERROR;
}
+ if ((Tcl_WideUInt)reqlength > TCL_SIZE_MAX) {
+ reqlength = -1;
+ }
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase or -length",
string2));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string2, NULL);
+ string2, (void *)NULL);
return TCL_ERROR;
}
}
@@ -2654,7 +2713,7 @@ StringEqualCmd(
static int
StringCmpCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2665,220 +2724,33 @@ StringCmpCmd(
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
- int match, nocase, reqlength, status;
+ int match, nocase, status;
+ Tcl_Size reqlength = -1;
- status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength);
+ status = StringCmpOpts(interp, objc, objv, &nocase, &reqlength);
if (status != TCL_OK) {
return status;
}
objv += objc-2;
match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match));
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * TclStringCmp --
- *
- * This is the core of Tcl's string comparison. It only handles byte
- * arrays, UNICODE strings and UTF-8 strings correctly.
- *
- * Results:
- * -1 if value1Ptr is less than value2Ptr, 0 if they are equal, or 1 if
- * value1Ptr is greater.
- *
- * Side effects:
- * May cause string representations of objects to be allocated.
- *
- *----------------------------------------------------------------------
- */
-
int
-TclStringCmp(
- Tcl_Obj *value1Ptr,
- Tcl_Obj *value2Ptr,
- int checkEq, /* comparison is only for equality */
- int nocase, /* comparison is not case sensitive */
- int reqlength) /* requested length in characters; -1 to
- * compare whole strings */
-{
- const char *s1, *s2;
- int empty, length, match, s1len, s2len;
- memCmpFn_t memCmpFn;
-
- if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
- /*
- * Always match at 0 chars or if it is the same obj.
- */
- return 0;
- }
-
- if (!nocase && TclIsPureByteArray(value1Ptr)
- && TclIsPureByteArray(value2Ptr)) {
- /*
- * Use binary versions of comparisons since that won't cause undue
- * type conversions and it is much faster. Only do this if we're
- * case-sensitive (which is all that really makes sense with byte
- * arrays anyway, and we have no memcasecmp() for some reason... :^)
- */
-
- s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
- s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
- memCmpFn = memcmp;
- } else if ((value1Ptr->typePtr == &tclStringType)
- && (value2Ptr->typePtr == &tclStringType)) {
- /*
- * Do a Unicode-specific comparison if both of the args are of String
- * type. If the char length == byte length, we can do a memcmp. In
- * benchmark testing this proved the most efficient check between the
- * Unicode and string comparison operations.
- */
-
- if (nocase) {
- s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len);
- s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
- memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp;
- } else {
- s1len = Tcl_GetCharLength(value1Ptr);
- s2len = Tcl_GetCharLength(value2Ptr);
- if ((s1len == value1Ptr->length)
- && (value1Ptr->bytes != NULL)
- && (s2len == value2Ptr->length)
- && (value2Ptr->bytes != NULL)) {
- /* each byte represents one character so s1l3n, s2l3n, and
- * reqlength are in both bytes and characters
- */
- s1 = value1Ptr->bytes;
- s2 = value2Ptr->bytes;
- memCmpFn = memcmp;
- } else {
- s1 = (char *) Tcl_GetUnicode(value1Ptr);
- s2 = (char *) Tcl_GetUnicode(value2Ptr);
- if (
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
- 1
-#else
- checkEq
-#endif /* WORDS_BIGENDIAN */
- ) {
- memCmpFn = memcmp;
- s1len *= sizeof(Tcl_UniChar);
- s2len *= sizeof(Tcl_UniChar);
- if (reqlength > 0) {
- reqlength *= sizeof(Tcl_UniChar);
- }
- } else {
- memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
- }
- }
- }
- } else {
- /*
- * Get the string representations, being careful in case we have
- * special empty string objects about.
- */
-
- empty = TclCheckEmptyString(value1Ptr);
- if (empty > 0) {
- switch (TclCheckEmptyString(value2Ptr)) {
- case -1:
- s1 = "";
- s1len = 0;
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- break;
- case 0:
- return -1;
- default: /* avoid warn: `s2` may be used uninitialized */
- return 0;
- }
- } else if (TclCheckEmptyString(value2Ptr) > 0) {
- switch (empty) {
- case -1:
- s2 = "";
- s2len = 0;
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- break;
- case 0:
- return 1;
- default: /* avoid warn: `s1` may be used uninitialized */
- return 0;
- }
- } else {
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- }
-
- if (!nocase && checkEq && reqlength < 0) {
- /*
- * When we have equal-length we can check only for (in)equality.
- * We can use memcmp() in all (n)eq cases because we don't need to
- * worry about lexical LE/BE variance.
- */
- memCmpFn = memcmp;
- } else {
- /*
- * As a catch-all we will work with UTF-8. We cannot use memcmp()
- * as that is unsafe with any string containing NUL (\xC0\x80 in
- * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if
- * we are case-sensitive and no specific length was requested.
- */
-
- if ((reqlength < 0) && !nocase) {
- memCmpFn = (memCmpFn_t) TclpUtfNcmp2;
- } else {
- s1len = Tcl_NumUtfChars(s1, s1len);
- s2len = Tcl_NumUtfChars(s2, s2len);
- memCmpFn = (memCmpFn_t)
- (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
- }
- }
- }
-
- /* At this point s1len, s2len, and reqlength should by now have been
- * adjusted so that they are all in the units expected by the selected
- * comparison function.
- */
-
- length = (s1len < s2len) ? s1len : s2len;
- if (reqlength > 0 && reqlength < length) {
- length = reqlength;
- } else if (reqlength < 0) {
- /*
- * The requested length is negative, so ignore it by setting it to
- * length + 1 to correct the match var.
- */
- reqlength = length + 1;
- }
-
- if (checkEq && reqlength < 0 && (s1len != s2len)) {
- match = 1; /* This will be reversed below. */
- } else {
- /*
- * The comparison function should compare up to the minimum byte
- * length only.
- */
- match = memCmpFn(s1, s2, length);
- }
- if ((match == 0) && (reqlength > length)) {
- match = s1len - s2len;
- }
- return (match > 0) ? 1 : (match < 0) ? -1 : 0;
-}
-
-int TclStringCmpOpts(
+StringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
int *nocase,
- int *reqlength)
+ Tcl_Size *reqlength)
{
- int i, length;
+ int i;
+ Tcl_Size length;
const char *string;
+ Tcl_WideInt wreqlength = -1;
- *reqlength = -1;
*nocase = 0;
if (objc < 3 || objc > 6) {
str_cmp_args:
@@ -2897,15 +2769,20 @@ int TclStringCmpOpts(
goto str_cmp_args;
}
i++;
- if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) {
return TCL_ERROR;
}
+ if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) {
+ *reqlength = -1;
+ } else {
+ *reqlength = wreqlength;
+ }
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": must be -nocase or -length",
string));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
- string, NULL);
+ string, (void *)NULL);
return TCL_ERROR;
}
}
@@ -2931,12 +2808,11 @@ int TclStringCmpOpts(
static int
StringCatCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i;
Tcl_Obj *objResultPtr;
if (objc < 2) {
@@ -2946,23 +2822,15 @@ StringCatCmd(
*/
return TCL_OK;
}
- if (objc == 2) {
- /*
- * Other trivial case, single arg, just return it.
- */
- Tcl_SetObjResult(interp, objv[1]);
+
+ objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE);
+
+ if (objResultPtr) {
+ Tcl_SetObjResult(interp, objResultPtr);
return TCL_OK;
}
- objResultPtr = objv[1];
- if (Tcl_IsShared(objResultPtr)) {
- objResultPtr = Tcl_DuplicateObj(objResultPtr);
- }
- for(i = 2;i < objc;i++) {
- Tcl_AppendObjToObj(objResultPtr, objv[i]);
- }
- Tcl_SetObjResult(interp, objResultPtr);
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -2983,10 +2851,10 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
-
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
static int
StringBytesCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2999,9 +2867,10 @@ StringBytesCmd(
}
(void) TclGetStringFromObj(objv[1], &length);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(length));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length));
return TCL_OK;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -3023,7 +2892,7 @@ StringBytesCmd(
static int
StringLenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3033,7 +2902,7 @@ StringLenCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1])));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[1])));
return TCL_OK;
}
@@ -3057,12 +2926,12 @@ StringLenCmd(
static int
StringLowerCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length1, length2;
+ Tcl_Size length1, length2;
const char *string1;
char *string2;
@@ -3080,11 +2949,11 @@ StringLowerCmd(
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
- int first, last;
+ Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
- length1 = Tcl_NumUtfChars(string1, length1) - 1;
+ length1 = TclNumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
@@ -3107,8 +2976,8 @@ StringLowerCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3142,12 +3011,12 @@ StringLowerCmd(
static int
StringUpperCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length1, length2;
+ Tcl_Size length1, length2;
const char *string1;
char *string2;
@@ -3165,11 +3034,11 @@ StringUpperCmd(
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
- int first, last;
+ Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
- length1 = Tcl_NumUtfChars(string1, length1) - 1;
+ length1 = TclNumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
@@ -3192,8 +3061,8 @@ StringUpperCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3227,12 +3096,12 @@ StringUpperCmd(
static int
StringTitleCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length1, length2;
+ Tcl_Size length1, length2;
const char *string1;
char *string2;
@@ -3250,11 +3119,11 @@ StringTitleCmd(
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
- int first, last;
+ Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
- length1 = Tcl_NumUtfChars(string1, length1) - 1;
+ length1 = TclNumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
@@ -3277,8 +3146,8 @@ StringTitleCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, last - first + 1);
+ start = TclUtfAtIndex(string1, first);
+ end = TclUtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
@@ -3312,7 +3181,7 @@ StringTitleCmd(
static int
StringTrimCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3359,13 +3228,14 @@ StringTrimCmd(
static int
StringTrimLCmd(
- ClientData dummy, /* Not used. */
+ 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, length1, length2;
+ int trim;
+ Tcl_Size length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
@@ -3405,13 +3275,14 @@ StringTrimLCmd(
static int
StringTrimRCmd(
- ClientData dummy, /* Not used. */
+ 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, length1, length2;
+ int trim;
+ Tcl_Size length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
@@ -3458,12 +3329,15 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
+#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED)
{"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+#endif
{"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
+ {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0},
{"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
@@ -3508,7 +3382,7 @@ TclInitStringCmd(
int
TclSubstOptions(
Tcl_Interp *interp,
- int numOpts,
+ Tcl_Size numOpts,
Tcl_Obj *const opts[],
int *flagPtr)
{
@@ -3547,17 +3421,17 @@ TclSubstOptions(
int
Tcl_SubstObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3595,22 +3469,23 @@ TclNRSubstObjCmd(
int
Tcl_SwitchObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
- int noCase, patternLength;
+ int i, index, mode, foundmode, splitObjs, numMatchesSaved;
+ int noCase;
+ Tcl_Size patternLength, j;
const char *pattern;
Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
Tcl_Obj *const *savedObjv = objv;
@@ -3631,12 +3506,12 @@ TclNRSwitchObjCmd(
"-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp",
"--", NULL
};
- enum options {
+ enum switchOptionsEnum {
OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP,
OPT_LAST
};
typedef int (*strCmpFn_t)(const char *, const char *);
- strCmpFn_t strCmpFn = strcmp;
+ strCmpFn_t strCmpFn = TclUtfCmp;
mode = OPT_EXACT;
foundmode = 0;
@@ -3652,7 +3527,7 @@ TclNRSwitchObjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum switchOptionsEnum) index) {
/*
* General options.
*/
@@ -3679,7 +3554,7 @@ TclNRSwitchObjCmd(
"bad option \"%s\": %s option already found",
TclGetString(objv[i]), options[mode]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "DOUBLEOPT", NULL);
+ "DOUBLEOPT", (void *)NULL);
return TCL_ERROR;
}
foundmode = 1;
@@ -3698,7 +3573,7 @@ TclNRSwitchObjCmd(
"missing variable name argument to %s option",
"-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "NOVAR", NULL);
+ "NOVAR", (void *)NULL);
return TCL_ERROR;
}
indexVarObj = objv[i];
@@ -3711,7 +3586,7 @@ TclNRSwitchObjCmd(
"missing variable name argument to %s option",
"-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "NOVAR", NULL);
+ "NOVAR", (void *)NULL);
return TCL_ERROR;
}
matchVarObj = objv[i];
@@ -3730,14 +3605,14 @@ TclNRSwitchObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-indexvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "MODERESTRICTION", NULL);
+ "MODERESTRICTION", (void *)NULL);
return TCL_ERROR;
}
if (matchVarObj != NULL && mode != OPT_REGEXP) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s option requires -regexp option", "-matchvar"));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "MODERESTRICTION", NULL);
+ "MODERESTRICTION", (void *)NULL);
return TCL_ERROR;
}
@@ -3760,7 +3635,7 @@ TclNRSwitchObjCmd(
Tcl_Obj **listv;
blist = objv[0];
- if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){
+ if (TclListObjLengthM(interp, objv[0], &objc) != TCL_OK) {
return TCL_ERROR;
}
@@ -3773,6 +3648,9 @@ TclNRSwitchObjCmd(
"?-option ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
+ if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
objv = listv;
splitObjs = 1;
}
@@ -3787,7 +3665,7 @@ TclNRSwitchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"extra switch pattern with no body", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
- NULL);
+ (void *)NULL);
/*
* Check if this can be due to a badly placed comment in the switch
@@ -3805,7 +3683,7 @@ TclNRSwitchObjCmd(
" placed outside of a switch body - see the"
" \"switch\" documentation", -1);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
- "BADARM", "COMMENT?", NULL);
+ "BADARM", "COMMENT?", (void *)NULL);
break;
}
}
@@ -3824,7 +3702,7 @@ TclNRSwitchObjCmd(
"no body specified for pattern \"%s\"",
TclGetString(objv[objc-2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
- "FALLTHROUGH", NULL);
+ "FALLTHROUGH", (void *)NULL);
return TCL_ERROR;
}
@@ -3922,8 +3800,8 @@ TclNRSwitchObjCmd(
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end > 0) {
- rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start);
- rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1);
+ TclNewIndexObj(rangeObjAry[0], info.matches[j].start);
+ TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1);
} else {
TclNewIntObj(rangeObjAry[1], -1);
rangeObjAry[0] = rangeObjAry[1];
@@ -3941,7 +3819,7 @@ TclNRSwitchObjCmd(
Tcl_Obj *substringObj;
if (info.matches[j].end > 0) {
- substringObj = Tcl_GetRange(stringObj,
+ substringObj = TclGetRange(stringObj,
info.matches[j].start, info.matches[j].end-1);
} else {
TclNewObj(substringObj);
@@ -4022,7 +3900,7 @@ TclNRSwitchObjCmd(
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
- ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
+ ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
@@ -4036,7 +3914,7 @@ TclNRSwitchObjCmd(
int k;
- ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
+ ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
@@ -4063,13 +3941,13 @@ TclNRSwitchObjCmd(
*/
Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr,
- INT2PTR(pc), (ClientData) pattern);
+ INT2PTR(pc), (void *)pattern);
return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j);
}
static int
SwitchPostProc(
- ClientData data[], /* Data passed from Tcl_NRAddCallback above */
+ void *data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
@@ -4079,7 +3957,7 @@ SwitchPostProc(
CmdFrame *ctxPtr = (CmdFrame *)data[1];
int pc = PTR2INT(data[2]);
const char *pattern = (const char *)data[3];
- int patternLength = strlen(pattern);
+ Tcl_Size patternLength = strlen(pattern);
/*
* Clean up TIP 280 context information
@@ -4130,16 +4008,15 @@ SwitchPostProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ThrowObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options;
- int len;
+ Tcl_Size len;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "type message");
@@ -4150,13 +4027,13 @@ Tcl_ThrowObjCmd(
* The type must be a list of at least length 1.
*/
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ 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);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -4195,7 +4072,7 @@ Tcl_ThrowObjCmd(
int
Tcl_TimeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4250,9 +4127,9 @@ Tcl_TimeObjCmd(
* Use int obj since we know time is not fractional. [Bug 1202178]
*/
- objs[0] = Tcl_NewWideIntObj((count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec);
+ TclNewIntObj(objs[0], (count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec);
} else {
- objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
+ TclNewDoubleObj(objs[0], totalMicroSec/count);
}
/*
@@ -4293,7 +4170,7 @@ Tcl_TimeObjCmd(
int
Tcl_TimeRateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4304,14 +4181,14 @@ Tcl_TimeRateObjCmd(
Tcl_Obj *objPtr;
int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
- TclWideMUInt count = 0; /* Holds repetition count */
+ Tcl_WideUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
- TclWideMUInt maxcnt = WIDE_MAX;
+ Tcl_WideUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
- TclWideMUInt threshold = 1; /* Current threshold for check time (faster
+ Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
- TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max
+ Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max
* threshold, additionally avoiding divide to
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
@@ -4323,7 +4200,7 @@ Tcl_TimeRateObjCmd(
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
- enum options {
+ enum timeRateOptionsEnum {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
@@ -4340,7 +4217,7 @@ Tcl_TimeRateObjCmd(
i++;
break;
}
- switch (index) {
+ switch ((enum timeRateOptionsEnum)index) {
case TMRT_EV_DIRECT:
direct = objv[i];
break;
@@ -4355,6 +4232,8 @@ Tcl_TimeRateObjCmd(
case TMRT_CALIBRATE:
calibrate = objv[i];
break;
+ case TMRT_LAST:
+ break;
}
}
@@ -4414,7 +4293,7 @@ Tcl_TimeRateObjCmd(
* calibration cycle.
*/
- TclNewLongObj(clobjv[i], 100);
+ TclNewIntObj(clobjv[i], 100);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
@@ -4439,7 +4318,7 @@ Tcl_TimeRateObjCmd(
maxms = -1000;
do {
lastMeasureOverhead = measureOverhead;
- TclNewLongObj(clobjv[i], (int) maxms);
+ TclNewIntObj(clobjv[i], (int) maxms);
Tcl_IncrRefCount(clobjv[i]);
result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv);
Tcl_DecrRefCount(clobjv[i]);
@@ -4469,7 +4348,7 @@ Tcl_TimeRateObjCmd(
*/
measureOverhead = 0;
- Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
@@ -4683,13 +4562,13 @@ Tcl_TimeRateObjCmd(
{
Tcl_Obj *objarr[8], **objs = objarr;
- TclWideMUInt usec, val;
+ Tcl_WideUInt usec, val;
int digits;
/*
* Absolute execution time in microseconds or in wide clicks.
*/
- usec = (TclWideMUInt)(middle - start);
+ usec = (Tcl_WideUInt)(middle - start);
#ifdef TCL_WIDE_CLICKS
/*
@@ -4700,7 +4579,8 @@ Tcl_TimeRateObjCmd(
#endif /* TCL_WIDE_CLICKS */
if (!count) { /* no iterations - avoid divide by zero */
- objs[0] = objs[2] = objs[4] = Tcl_NewWideIntObj(0);
+ TclNewIntObj(objs[4], 0);
+ objs[0] = objs[2] = objs[4];
goto retRes;
}
@@ -4718,7 +4598,7 @@ Tcl_TimeRateObjCmd(
* Estimate the time of overhead (microsecs).
*/
- TclWideMUInt curOverhead = overhead * count;
+ Tcl_WideUInt curOverhead = overhead * count;
if (usec > curOverhead) {
usec -= curOverhead;
@@ -4734,14 +4614,14 @@ Tcl_TimeRateObjCmd(
if (measureOverhead > ((double) usec) / count) {
measureOverhead = ((double) usec) / count;
}
- objs[0] = Tcl_NewDoubleObj(measureOverhead);
+ TclNewDoubleObj(objs[0], measureOverhead);
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
objs += 2;
}
val = usec / count; /* microsecs per iteration */
if (val >= 1000000) {
- objs[0] = Tcl_NewWideIntObj(val);
+ TclNewIntObj(objs[0], val);
} else {
if (val < 10) {
digits = 6;
@@ -4757,7 +4637,7 @@ Tcl_TimeRateObjCmd(
objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count);
}
- objs[2] = Tcl_NewWideIntObj(count); /* iterations */
+ TclNewIntObj(objs[2], count); /* iterations */
/*
* Calculate speed as rate (count) per sec
@@ -4779,7 +4659,7 @@ Tcl_TimeRateObjCmd(
objs[4] = Tcl_ObjPrintf("%.*f",
digits, ((double) (count * 1000000)) / usec);
} else {
- objs[4] = Tcl_NewWideIntObj(val);
+ TclNewIntObj(objs[4], val);
}
} else {
objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000);
@@ -4794,7 +4674,7 @@ Tcl_TimeRateObjCmd(
if (usec >= 1) {
objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000);
} else {
- objs[6] = Tcl_NewWideIntObj(0);
+ TclNewIntObj(objs[6], 0);
}
TclNewLiteralStringObj(objs[7], "net-ms");
}
@@ -4836,23 +4716,24 @@ Tcl_TimeRateObjCmd(
int
Tcl_TryObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
- ClientData clientData, /* Not used. */
+ 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, dummy, code;
+ int i, bodyShared, haveHandlers, code;
+ Tcl_Size dummy;
static const char *const handlerNames[] = {
"finally", "on", "trap", NULL
};
@@ -4891,7 +4772,7 @@ TclNRTryObjCmd(
"finally clause must be last", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
- "NONTERMINAL", NULL);
+ "NONTERMINAL", (void *)NULL);
return TCL_ERROR;
} else if (i == objc-1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -4899,7 +4780,7 @@ TclNRTryObjCmd(
" \"... finally script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
- "ARGUMENT", NULL);
+ "ARGUMENT", (void *)NULL);
return TCL_ERROR;
}
finallyObj = objv[++i];
@@ -4912,7 +4793,7 @@ TclNRTryObjCmd(
" variableList script\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
- "ARGUMENT", NULL);
+ "ARGUMENT", (void *)NULL);
return TCL_ERROR;
}
if (TclGetCompletionCodeFromObj(interp, objv[i+1],
@@ -4931,23 +4812,23 @@ TclNRTryObjCmd(
-1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
- "ARGUMENT", NULL);
+ "ARGUMENT", (void *)NULL);
return TCL_ERROR;
}
code = 1;
- if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+ if (TclListObjLengthM(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
- Tcl_GetString(objv[i+1])));
+ TclGetString(objv[i+1])));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
- "EXNFORMAT", NULL);
+ "EXNFORMAT", (void *)NULL);
return TCL_ERROR;
}
info[2] = objv[i+1];
commonHandler:
- if (TclListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[i+2], &dummy) != TCL_OK) {
Tcl_DecrRefCount(handlersObj);
return TCL_ERROR;
}
@@ -4973,7 +4854,7 @@ TclNRTryObjCmd(
"last non-finally clause must not have a body of \"-\"", -1));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
if (!haveHandlers) {
@@ -4986,7 +4867,7 @@ TclNRTryObjCmd(
*/
Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
- (ClientData)objv, INT2PTR(objc));
+ (void *)objv, INT2PTR(objc));
return TclNREvalObjEx(interp, bodyObj, 0,
((Interp *) interp)->cmdFramePtr, 1);
}
@@ -5044,13 +4925,13 @@ During(
static int
TryPostBody(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
- int i, dummy, code, objc;
- int numHandlers = 0;
+ int code, objc;
+ Tcl_Size i, numHandlers = 0;
handlersObj = (Tcl_Obj *)data[0];
finallyObj = (Tcl_Obj *)data[1];
@@ -5097,11 +4978,12 @@ TryPostBody(
int found = 0;
Tcl_Obj **handlers, **info;
- TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+ TclListObjGetElementsM(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
+ Tcl_Size numElems = 0;
- TclListObjGetElements(NULL, handlers[i], &dummy, &info);
+ TclListObjGetElementsM(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
@@ -5117,13 +4999,13 @@ TryPostBody(
if (code == TCL_ERROR) {
Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
- int len1, len2, j;
+ Tcl_Size len1, len2, j;
TclNewLiteralStringObj(errorCodeName, "-errorcode");
Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
Tcl_DecrRefCount(errorCodeName);
- TclListObjGetElements(NULL, info[2], &len1, &bits1);
- if (TclListObjGetElements(NULL, errcode, &len2,
+ TclListObjGetElementsM(NULL, info[2], &len1, &bits1);
+ if (TclListObjGetElementsM(NULL, errcode, &len2,
&bits2) != TCL_OK) {
continue;
}
@@ -5163,8 +5045,8 @@ TryPostBody(
Tcl_ResetResult(interp);
result = TCL_ERROR;
- TclListObjLength(NULL, info[3], &dummy);
- if (dummy > 0) {
+ TclListObjLengthM(NULL, info[3], &numElems);
+ if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
@@ -5174,7 +5056,7 @@ TryPostBody(
goto handlerFailed;
}
Tcl_DecrRefCount(resultObj);
- if (dummy > 1) {
+ if (numElems> 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
@@ -5259,7 +5141,7 @@ TryPostBody(
static int
TryPostHandler(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5345,7 +5227,7 @@ TryPostHandler(
static int
TryPostFinal(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5412,17 +5294,17 @@ TryPostFinal(
int
Tcl_WhileObjCmd(
- ClientData dummy, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -5471,18 +5353,18 @@ TclListLines(
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
* structure. Assumed to be valid. Assumed to
* contain n elements. */
- int line, /* Line the list as a whole starts on. */
- int n, /* #elements in lines */
- int *lines, /* Array of line numbers, to fill. */
+ Tcl_Size line, /* Line the list as a whole starts on. */
+ Tcl_Size n, /* #elements in lines */
+ Tcl_Size *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 = Tcl_GetString(listObj);
+ const char *listStr = TclGetString(listObj);
const char *listHead = listStr;
- int i, length = strlen(listStr);
+ Tcl_Size i, length = strlen(listStr);
const char *element = NULL, *next = NULL;
ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
- int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
+ Tcl_Size *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
for (i = 0; i < n; i++) {
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index bafcb13..0104285 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4,10 +4,10 @@
* This file contains compilation procedures that compile various Tcl
* commands into a sequence of instructions ("bytecodes").
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 Donal K. Fellows.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-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.
@@ -248,8 +248,7 @@ TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -302,7 +301,7 @@ TclCompileArraySetCmd(
TclNewObj(literalObj);
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
isDataValid = (isDataLiteral
- && TclListObjLength(NULL, literalObj, &len) == TCL_OK);
+ && TclListObjLengthM(NULL, literalObj, &len) == TCL_OK);
isDataEven = (isDataValid && (len & 1) == 0);
/*
@@ -391,9 +390,9 @@ TclCompileArraySetCmd(
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
- infoPtr = (ForeachInfo *)ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *));
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
- infoPtr->varLists[0] = (ForeachVarList *)ckalloc(TclOffset(ForeachVarList, varIndexes) + 2 * sizeof(int));
+ infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
@@ -510,11 +509,10 @@ TclCompileArrayUnsetCmd(
int
TclCompileBreakCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
@@ -571,8 +569,7 @@ TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -608,11 +605,13 @@ TclCompileCatchCmd(
cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
+ /* DGP */
resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
+ /* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
@@ -751,11 +750,10 @@ TclCompileCatchCmd(
int
TclCompileClockClicksCmd(
- Tcl_Interp* interp, /* Tcl interpreter */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token* tokenPtr;
@@ -815,7 +813,7 @@ TclCompileClockClicksCmd(
int
TclCompileClockReadingCmd(
- Tcl_Interp* interp, /* Tcl interpreter */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to definition of command being
@@ -854,8 +852,7 @@ TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -895,10 +892,10 @@ TclCompileConcatCmd(
const char *bytes;
int len;
- TclListObjGetElements(NULL, listObj, &len, &objs);
+ TclListObjGetElementsM(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
- bytes = Tcl_GetStringFromObj(objPtr, &len);
+ bytes = TclGetStringFromObj(objPtr, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
@@ -938,11 +935,10 @@ TclCompileConcatCmd(
int
TclCompileContinueCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
@@ -1004,13 +1000,13 @@ TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *varTokenPtr;
+ Tcl_Token *tokenPtr;
int i, dictVarIndex;
+ Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
@@ -1129,8 +1125,7 @@ TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1162,12 +1157,42 @@ TclCompileDictGetCmd(
}
int
+TclCompileDictGetWithDefaultCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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;
+ int i;
+
+ /*
+ * There must be at least three arguments after the command.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 4) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ for (i=1 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr);
+ TclAdjustStackDepth(-2, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1305,7 +1330,7 @@ TclCompileDictCreateCmd(
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
- bytes = Tcl_GetStringFromObj(dictObj, &len);
+ bytes = TclGetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
@@ -1764,7 +1789,7 @@ TclCompileDictUpdateCmd(
* that are to be used.
*/
- duiPtr = (DictUpdateInfo *)ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
+ duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
duiPtr->length = numVars;
keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
@@ -2238,15 +2263,15 @@ TclCompileDictWithCmd(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupDictUpdateInfo(
- ClientData clientData)
+ void *clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
- len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
+ len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
@@ -2254,17 +2279,17 @@ DupDictUpdateInfo(
static void
FreeDictUpdateInfo(
- ClientData clientData)
+ void *clientData)
{
ckfree(clientData);
}
static void
PrintDictUpdateInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
@@ -2279,10 +2304,10 @@ PrintDictUpdateInfo(
static void
DisassembleDictUpdateInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
@@ -2291,7 +2316,7 @@ DisassembleDictUpdateInfo(
TclNewObj(variables);
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
- Tcl_NewIntObj(duiPtr->varIndices[i]));
+ Tcl_NewWideIntObj(duiPtr->varIndices[i]));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
variables);
@@ -2320,8 +2345,7 @@ TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2394,8 +2418,7 @@ TclCompileExprCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
@@ -2439,8 +2462,7 @@ TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2650,8 +2672,7 @@ CompileEachloopCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
@@ -2701,7 +2722,7 @@ CompileEachloopCmd(
*/
numLists = (numWords - 2)/2;
- infoPtr = (ForeachInfo *)ckalloc(TclOffset(ForeachInfo, varLists)
+ infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
@@ -2729,13 +2750,13 @@ CompileEachloopCmd(
*/
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
- TCL_OK != TclListObjLength(NULL, varListObj, &numVars) ||
+ TCL_OK != TclListObjLengthM(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
- varListPtr = (ForeachVarList *)ckalloc(TclOffset(ForeachVarList, varIndexes)
+ varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
@@ -2747,7 +2768,7 @@ CompileEachloopCmd(
int numBytes, varIndex;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
- bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
+ bytes = TclGetStringFromObj(varNameObj, &numBytes);
varIndex = LocalScalar(bytes, numBytes, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
@@ -2861,9 +2882,9 @@ CompileEachloopCmd(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupForeachInfo(
- ClientData clientData) /* The foreach command's compilation auxiliary
+ void *clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
@@ -2871,7 +2892,7 @@ DupForeachInfo(
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
- dupPtr = (ForeachInfo *)ckalloc(TclOffset(ForeachInfo, varLists)
+ dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists)
+ numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
@@ -2880,7 +2901,7 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = (ForeachVarList *)ckalloc(TclOffset(ForeachVarList, varIndexes)
+ dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
@@ -2912,7 +2933,7 @@ DupForeachInfo(
static void
FreeForeachInfo(
- ClientData clientData) /* The foreach command's compilation auxiliary
+ void *clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
@@ -2946,10 +2967,10 @@ FreeForeachInfo(
static void
PrintForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
@@ -2986,10 +3007,10 @@ PrintForeachInfo(
static void
PrintNewForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
@@ -3016,10 +3037,10 @@ PrintNewForeachInfo(
static void
DisassembleForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
@@ -3033,7 +3054,7 @@ DisassembleForeachInfo(
TclNewObj(objPtr);
for (i=0 ; i<infoPtr->numLists ; i++) {
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(infoPtr->firstValueTemp + i));
+ Tcl_NewWideIntObj(infoPtr->firstValueTemp + i));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
@@ -3042,7 +3063,7 @@ DisassembleForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3054,7 +3075,7 @@ DisassembleForeachInfo(
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
- Tcl_NewIntObj(varsPtr->varIndexes[j]));
+ Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
@@ -3063,10 +3084,10 @@ DisassembleForeachInfo(
static void
DisassembleNewForeachInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
@@ -3078,7 +3099,7 @@ DisassembleNewForeachInfo(
*/
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
- Tcl_NewIntObj(infoPtr->loopCtTemp));
+ Tcl_NewWideIntObj(infoPtr->loopCtTemp));
/*
* Assignment targets.
@@ -3090,7 +3111,7 @@ DisassembleNewForeachInfo(
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
Tcl_ListObjAppendElement(NULL, innerPtr,
- Tcl_NewIntObj(varsPtr->varIndexes[j]));
+ Tcl_NewWideIntObj(varsPtr->varIndexes[j]));
}
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
@@ -3121,8 +3142,7 @@ TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3167,7 +3187,7 @@ TclCompileFormatCmd(
* the format is broken). Do the format now.
*/
- tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
+ tmpObj = Tcl_Format(interp, TclGetString(formatObj),
parsePtr->numWords-2, objv);
for (; --i>=0 ;) {
Tcl_DecrRefCount(objv[i]);
@@ -3184,7 +3204,7 @@ TclCompileFormatCmd(
* literal. Job done.
*/
- bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ bytes = TclGetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
@@ -3211,7 +3231,7 @@ TclCompileFormatCmd(
* Now scan through and check for non-%s and non-%% substitutions.
*/
- for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
+ for (bytes = TclGetString(formatObj) ; *bytes ; bytes++) {
if (*bytes == '%') {
bytes++;
if (*bytes == 's') {
@@ -3244,7 +3264,7 @@ TclCompileFormatCmd(
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
- start = Tcl_GetString(formatObj);
+ start = TclGetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
TclNewObj(tmpObj); /* The buffer used to accumulate the literal
@@ -3255,7 +3275,7 @@ TclCompileFormatCmd(
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
- const char *b = Tcl_GetStringFromObj(tmpObj, &len);
+ const char *b = TclGetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
@@ -3289,7 +3309,7 @@ TclCompileFormatCmd(
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
- bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ bytes = TclGetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
@@ -3327,12 +3347,13 @@ TclCompileFormatCmd(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclLocalScalarFromToken(
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
- int isScalar, index;
+ int isScalar;
+ Tcl_Size index;
TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar);
if (!isScalar) {
@@ -3341,10 +3362,10 @@ TclLocalScalarFromToken(
return index;
}
-int
+Tcl_Size
TclLocalScalar(
const char *bytes,
- int numBytes,
+ TCL_HASH_TYPE numBytes,
CompileEnv *envPtr)
{
Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 7efe6ae..ea1e42d 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -5,10 +5,10 @@
* commands (beginning with the letters 'g' through 'r') into a sequence
* of instructions ("bytecodes").
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2013 Donal K. Fellows.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-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.
@@ -49,8 +49,8 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp,
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
- int before,
- int after,
+ Tcl_Size before,
+ Tcl_Size after,
int *indexPtr)
{
Tcl_Obj *tmpObj;
@@ -87,8 +87,7 @@ TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -169,8 +168,7 @@ TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -416,7 +414,7 @@ TclCompileIfCmd(
for (j = jumpEndFixupArray.next; j > 0; j--) {
jumpIndex = (j - 1); /* i.e. process the closest jump first. */
if (TclFixupForwardJumpToHere(envPtr,
- jumpEndFixupArray.fixup+jumpIndex, 127)) {
+ jumpEndFixupArray.fixup + jumpIndex, 127)) {
/*
* Adjust the immediately preceding "ifFalse" jump. We moved it's
* target (just after this jump) down three bytes.
@@ -435,7 +433,7 @@ TclCompileIfCmd(
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode);
}
}
}
@@ -473,8 +471,7 @@ TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -608,7 +605,7 @@ TclCompileInfoCommandsCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
goto notCompilable;
}
- bytes = Tcl_GetString(objPtr);
+ bytes = TclGetString(objPtr);
/*
* We require that the argument start with "::" and not have any of "*\[?"
@@ -642,11 +639,10 @@ TclCompileInfoCommandsCmd(
int
TclCompileInfoCoroutineCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -670,8 +666,7 @@ TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -719,8 +714,7 @@ TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -754,8 +748,7 @@ TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -774,8 +767,7 @@ TclCompileInfoObjectIsACmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -810,8 +802,7 @@ TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -848,8 +839,7 @@ TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -964,8 +954,7 @@ TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1040,7 +1029,7 @@ TclCompileLassignCmd(
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1068,8 +1057,7 @@ TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1091,8 +1079,8 @@ TclCompileLindexCmd(
}
idxTokenPtr = TokenAfter(valTokenPtr);
- if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE,
- &idx) == TCL_OK) {
+ if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE,
+ TCL_INDEX_NONE, &idx) == TCL_OK) {
/*
* The idxTokenPtr parsed as a valid index value and was
* encoded as expected by INST_LIST_INDEX_IMM.
@@ -1159,8 +1147,7 @@ TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1245,7 +1232,7 @@ TclCompileListCmd(
if (concat && numWords == 2) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
+ TclEmitInt4( (int)TCL_INDEX_END, envPtr);
}
return TCL_OK;
}
@@ -1273,8 +1260,7 @@ TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1306,8 +1292,7 @@ TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1320,8 +1305,8 @@ TclCompileLrangeCmd(
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(listTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
- &idx1) != TCL_OK) {
+ if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
+ &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) {
return TCL_ERROR;
}
/*
@@ -1330,7 +1315,7 @@ TclCompileLrangeCmd(
*/
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&idx2) != TCL_OK) {
return TCL_ERROR;
}
@@ -1367,89 +1352,38 @@ TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *listTokenPtr;
- int idx, i;
+ Tcl_Token *tokenPtr;
+ int i;
if (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
- * end-relative indexing) or an end-based index greater than 'end' itself.
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
-
- /*
- * NOTE: This command treats all inserts at indices before the list
- * the same as inserts at the start of the list, and all inserts
- * after the list the same as inserts at the end of the list. We
- * make that transformation here so we can use the optimized bytecode
- * as much as possible.
- */
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * There are four main cases. If there are no values to insert, this is
- * just a confirm-listiness check. If the index is '0', this is a prepend.
- * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
- * this is a splice (== split, insert values as list, concat-3).
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- if (parsePtr->numWords == 3) {
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- return TCL_OK;
- }
+ /* Push list, insertion index onto the stack */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ /* Push new elements to be inserted */
for (i=3 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt4( INST_LIST, i-3, envPtr);
- if (idx == TCL_INDEX_START) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else if (idx == TCL_INDEX_END) {
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else {
- /*
- * Here we handle two ranges for idx. First when idx > 0, we
- * want the first half of the split to end at index idx-1 and
- * the second half to start at index idx.
- * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
- * we want the first half of the split to end at index end-N and
- * the second half to start at index end-N+1. We accomplish this
- * with a preadjustment of the end-N value.
- * The root of this is that the commands [lrange] and [linsert]
- * differ in their interpretation of the "end" index.
- */
-
- if (idx < TCL_INDEX_END) {
- idx++;
- }
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx-1, envPtr);
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
+ /* First operand is count of arguments */
+ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr);
+ /*
+ * Second operand is bitmask
+ * TCL_LREPLACE4_END_IS_LAST - end refers to last element
+ * TCL_LREPLACE4_SINGLE_INDEX - second index is not present
+ * indicating this is a pure insert
+ */
+ TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr);
return TCL_OK;
}
@@ -1470,121 +1404,38 @@ TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *listTokenPtr;
- int idx1, idx2, i;
- int emptyPrefix=1, suffixStart = 0;
+ Tcl_Token *tokenPtr;
+ int i;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
- &idx1) != TCL_OK) {
- return TCL_ERROR;
- }
+ /* Push list, first, last onto the stack */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
- &idx2) != TCL_OK) {
- return TCL_ERROR;
- }
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
- /*
- * General structure of the [lreplace] result is
- * prefix replacement suffix
- * In a few cases we can predict various parts will be empty and
- * take advantage.
- *
- * The proper suffix begins with the greater of indices idx1 or
- * idx2 + 1. If we cannot tell at compile time which is greater,
- * we must defer to direct evaluation.
- */
-
- if (idx1 == TCL_INDEX_AFTER) {
- suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_BEFORE) {
- suffixStart = idx1;
- } else if (idx2 == TCL_INDEX_END) {
- suffixStart = TCL_INDEX_AFTER;
- } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
- || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
- suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
- } else {
- return TCL_ERROR;
+ /* Push new elements to be inserted */
+ for (i=4 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
}
- /* All paths start with computing/pushing the original value. */
- CompileWord(envPtr, listTokenPtr, interp, 1);
-
+ /* First operand is count of arguments */
+ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr);
/*
- * Push all the replacement values next so any errors raised in
- * creating them get raised first.
+ * Second operand is bitmask
+ * TCL_LREPLACE4_END_IS_LAST - end refers to last element
*/
- if (parsePtr->numWords > 4) {
- /* Push the replacement arguments */
- tokenPtr = TokenAfter(tokenPtr);
- for (i=4 ; i<parsePtr->numWords ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i);
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- /* Make a list of them... */
- TclEmitInstInt4( INST_LIST, i - 4, envPtr);
-
- emptyPrefix = 0;
- }
-
- if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
- /*
- * This is a "no-op". Example: [lreplace {a b c} 2 0]
- * We still do a list operation to get list-verification
- * and canonicalization side effects.
- */
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- return TCL_OK;
- }
-
- if (idx1 != TCL_INDEX_START) {
- /* Prefix may not be empty; generate bytecode to push it */
- if (emptyPrefix) {
- TclEmitOpcode( INST_DUP, envPtr);
- } else {
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- }
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx1 - 1, envPtr);
- if (!emptyPrefix) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
- emptyPrefix = 0;
- }
-
- if (!emptyPrefix) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- }
-
- if (suffixStart == TCL_INDEX_AFTER) {
- TclEmitOpcode( INST_POP, envPtr);
- if (emptyPrefix) {
- PushStringLiteral(envPtr, "");
- }
- } else {
- /* Suffix may not be empty; generate bytecode to push it */
- TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr);
- TclEmitInt4( TCL_INDEX_END, envPtr);
- if (!emptyPrefix) {
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- }
- }
+ TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr);
return TCL_OK;
}
@@ -1634,8 +1485,7 @@ TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1778,11 +1628,10 @@ TclCompileLsetCmd(
int
TclCompileNamespaceCurrentCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
@@ -1806,8 +1655,7 @@ TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1856,8 +1704,7 @@ TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1878,8 +1725,7 @@ TclCompileNamespaceQualifiersCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1914,8 +1760,7 @@ TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1951,8 +1796,7 @@ TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2012,8 +1856,7 @@ TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2076,8 +1919,7 @@ TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2242,8 +2084,7 @@ TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
@@ -2272,7 +2113,7 @@ TclCompileRegsubCmd(
Tcl_DString pattern;
const char *bytes;
int exact, quantified, result = TCL_ERROR;
- int len;
+ Tcl_Size len;
if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
return TCL_ERROR;
@@ -2299,8 +2140,8 @@ TclCompileRegsubCmd(
if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
goto done;
}
- if (Tcl_GetString(patternObj)[0] == '-') {
- if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ if (TclGetString(patternObj)[0] == '-') {
+ if (strcmp(TclGetString(patternObj), "--") != 0
|| parsePtr->numWords == 5) {
goto done;
}
@@ -2331,7 +2172,7 @@ TclCompileRegsubCmd(
* replacement "simple"?
*/
- bytes = Tcl_GetStringFromObj(patternObj, &len);
+ bytes = TclGetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
@@ -2365,7 +2206,7 @@ TclCompileRegsubCmd(
bytes++;
}
isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
case '\\': case '&':
goto done;
@@ -2379,7 +2220,7 @@ TclCompileRegsubCmd(
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(replacementObj, &len);
+ bytes = TclGetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
@@ -2418,8 +2259,7 @@ TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2427,11 +2267,11 @@ TclCompileReturnCmd(
* 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;
- int size;
- int numWords = parsePtr->numWords;
- int explicitResult = (0 == (numWords % 2));
- int numOptionWords = numWords - 1 - explicitResult;
+ int level, code, status = TCL_OK;
+ Tcl_Size size;
+ Tcl_Size numWords = parsePtr->numWords;
+ Tcl_Size explicitResult = (0 == (numWords % 2));
+ Tcl_Size objc, numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -2538,7 +2378,7 @@ TclCompileReturnCmd(
ExceptionRange range = envPtr->exceptArrayPtr[index];
if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
+ && (range.catchOffset == TCL_INDEX_NONE)) {
enclosingCatch = 1;
break;
}
@@ -2638,11 +2478,11 @@ TclCompileSyntaxError(
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
- int numBytes;
+ Tcl_Size numBytes;
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
@@ -2671,8 +2511,7 @@ TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2778,8 +2617,7 @@ TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2860,14 +2698,14 @@ TclCompileVariableCmd(
static int
IndexTailVarIfKnown(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Obj *tailPtr;
const char *tailName, *p;
int n = varTokenPtr->numComponents;
- int len;
+ Tcl_Size len;
Tcl_Token *lastTokenPtr;
int full, localIndex;
@@ -2953,8 +2791,7 @@ TclCompileObjectNextCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2978,8 +2815,7 @@ TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3000,11 +2836,10 @@ TclCompileObjectNextToCmd(
int
TclCompileObjectSelfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index a7db705..5d190a1 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -6,10 +6,10 @@
* [upvar] and [variable]) into a sequence of instructions ("bytecodes").
* Also includes the operator command compilers.
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2010 Donal K. Fellows.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002 ActiveState Corporation.
+ * Copyright © 2004-2010 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -41,12 +41,12 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
CompileEnv *envPtr);
static void IssueSwitchChainedTests(Tcl_Interp *interp,
CompileEnv *envPtr, int mode, int noCase,
- int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyNext);
+ int numWords, Tcl_Token **bodyToken,
+ int *bodyLines, int **bodyNext);
static void IssueSwitchJumpTable(Tcl_Interp *interp,
CompileEnv *envPtr, int numWords,
- Tcl_Token **bodyToken, int *bodyLines,
- int **bodyContLines);
+ Tcl_Token **bodyToken, int *bodyLines,
+ int **bodyContLines);
static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
@@ -126,8 +126,7 @@ TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -220,8 +219,7 @@ TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -255,7 +253,7 @@ TclCompileStringCatCmd(
Tcl_DecrRefCount(obj);
if (folded) {
int len;
- const char *bytes = Tcl_GetStringFromObj(folded, &len);
+ const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -273,7 +271,7 @@ TclCompileStringCatCmd(
}
if (folded) {
int len;
- const char *bytes = Tcl_GetStringFromObj(folded, &len);
+ const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
@@ -292,8 +290,7 @@ TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -324,8 +321,7 @@ TclCompileStringEqualCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -356,8 +352,7 @@ TclCompileStringFirstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -388,8 +383,7 @@ TclCompileStringLastCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -420,8 +414,7 @@ TclCompileStringIndexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -444,6 +437,62 @@ TclCompileStringIndexCmd(
}
int
+TclCompileStringInsertCmd(
+ 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;
+ int idx;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ /* Compute and push the string in which to insert */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /* See what can be discovered about index at compile time */
+ tokenPtr = TokenAfter(tokenPtr);
+ if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START,
+ TCL_INDEX_END, &idx)) {
+
+ /* Nothing useful knowable - cease compile; let it direct eval */
+ return TCL_ERROR;
+ }
+
+ /* Compute and push the string to be inserted */
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+
+ if (idx == (int)TCL_INDEX_START) {
+ /* Prepend the insertion string */
+ OP4( REVERSE, 2);
+ OP1( STR_CONCAT1, 2);
+ } else if (idx == (int)TCL_INDEX_END) {
+ /* Append the insertion string */
+ OP1( STR_CONCAT1, 2);
+ } else {
+ /* Prefix + insertion + suffix */
+ if (idx < (int)TCL_INDEX_END) {
+ /* See comments in compiler for [linsert]. */
+ idx++;
+ }
+ OP4( OVER, 1);
+ OP44( STR_RANGE_IMM, 0, idx-1);
+ OP4( REVERSE, 3);
+ OP44( STR_RANGE_IMM, idx, TCL_INDEX_END);
+ OP1( STR_CONCAT1, 3);
+ }
+
+ return TCL_OK;
+}
+
+int
TclCompileStringIsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -456,19 +505,19 @@ TclCompileStringIsCmd(
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
- "boolean", "digit", "double", "entier",
- "false", "graph", "integer", "list",
- "lower", "print", "punct", "space",
- "true", "upper", "wideinteger", "wordchar",
- "xdigit", NULL
+ "boolean", "dict", "digit", "double",
+ "entier", "false", "graph", "integer",
+ "list", "lower", "print", "punct",
+ "space", "true", "upper", "unicode",
+ "wideinteger", "wordchar", "xdigit", NULL
};
enum isClassesEnum {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
- STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
- STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
- STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
- STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
- STR_IS_XDIGIT
+ STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE,
+ STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT,
+ STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT,
+ STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_UNICODE,
+ STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
@@ -560,6 +609,9 @@ TclCompileStringIsCmd(
case STR_IS_UPPER:
strClassType = STR_CLASS_UPPER;
goto compileStrClass;
+ case STR_IS_UNICODE:
+ strClassType = STR_CLASS_UNICODE;
+ goto compileStrClass;
case STR_IS_WORD:
strClassType = STR_CLASS_WORD;
goto compileStrClass;
@@ -692,9 +744,6 @@ TclCompileStringIsCmd(
OP( LE);
break;
case STR_IS_INT:
- PUSH( "1");
- OP( EQ);
- break;
case STR_IS_ENTIER:
PUSH( "3");
OP( LE);
@@ -702,7 +751,19 @@ TclCompileStringIsCmd(
}
FIXJUMP1( end);
return TCL_OK;
-
+ case STR_IS_DICT:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( DICT_VERIFY);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
case STR_IS_LIST:
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
@@ -808,8 +869,7 @@ TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -830,7 +890,7 @@ TclCompileStringLenCmd(
*/
char buf[TCL_INTEGER_SPACE];
- int len = Tcl_GetCharLength(objPtr);
+ int len = TclGetCharLength(objPtr);
len = snprintf(buf, sizeof(buf), "%d", len);
PushLiteral(envPtr, buf, len);
@@ -878,7 +938,7 @@ TclCompileStringMapCmd(
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- } else if (TclListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
+ } else if (TclListObjGetElementsM(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
@@ -892,12 +952,12 @@ TclCompileStringMapCmd(
* correct semantics for mapping.
*/
- bytes = Tcl_GetStringFromObj(objv[0], &len);
+ bytes = TclGetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(objv[1], &len);
+ bytes = TclGetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
@@ -911,8 +971,7 @@ TclCompileStringRangeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -933,7 +992,7 @@ TclCompileStringRangeCmd(
* Parse the two indices.
*/
- if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&idx1) != TCL_OK) {
goto nonConstantIndices;
}
@@ -942,14 +1001,14 @@ TclCompileStringRangeCmd(
* the string the same as the start of the string.
*/
- if (idx1 == TCL_INDEX_AFTER) {
+ if (idx1 == (int)TCL_INDEX_NONE) {
/* [string range $s end+1 $last] must be empty string */
OP( POP);
PUSH( "");
return TCL_OK;
}
- if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&idx2) != TCL_OK) {
goto nonConstantIndices;
}
@@ -957,7 +1016,7 @@ TclCompileStringRangeCmd(
* Token parsed as an index expression. We treat all indices after
* the string the same as the end of the string.
*/
- if (idx2 == TCL_INDEX_BEFORE) {
+ if (idx2 == (int)TCL_INDEX_NONE) {
/* [string range $s $first -1] must be empty string */
OP( POP);
PUSH( "");
@@ -987,8 +1046,7 @@ TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1007,7 +1065,7 @@ TclCompileStringReplaceCmd(
* Check for first index known and useful at compile time.
*/
tokenPtr = TokenAfter(valueTokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE,
&first) != TCL_OK) {
goto genericReplace;
}
@@ -1016,7 +1074,7 @@ TclCompileStringReplaceCmd(
* Check for last index known and useful at compile time.
*/
tokenPtr = TokenAfter(tokenPtr);
- if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END,
&last) != TCL_OK) {
goto genericReplace;
}
@@ -1035,8 +1093,8 @@ TclCompileStringReplaceCmd(
* compile direct to bytecode implementing the no-op.
*/
- if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */
- || (first == TCL_INDEX_AFTER) /* Know (first > end) */
+ if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */
+ || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */
/*
* Tricky to determine when runtime (last < first) can be
@@ -1044,24 +1102,21 @@ TclCompileStringReplaceCmd(
* cases...
*
* (first <= TCL_INDEX_END) &&
- * (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX END) && (last < first) => ACCEPT
* else => cannot tell REJECT
*/
- || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
+ || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END)
&& (last < first)) /* Know (last < first) */
/*
- * (first == TCL_INDEX_BEFORE) &&
- * (last == TCL_INDEX_AFTER) => (first < last) REJECT
+ * (first == TCL_INDEX_NONE) &&
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else => (first < last) REJECT
*
* else [[first >= TCL_INDEX_START]] &&
- * (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
*/
- || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
+ || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)
&& (last < first))) { /* Know (last < first) */
if (parsePtr->numWords == 5) {
tokenPtr = TokenAfter(tokenPtr);
@@ -1090,43 +1145,43 @@ TclCompileStringReplaceCmd(
* (first <= end)
*
* The encoded indices (first <= TCL_INDEX END) and
- * (first == TCL_INDEX_BEFORE) always meets this condition, but
+ * (first == TCL_INDEX_NONE) always meets this condition, but
* any other encoded first index has some list for which it fails.
*
* We also need, second:
*
* (last >= 0)
*
- * The encoded indices (last >= TCL_INDEX_START) and
- * (last == TCL_INDEX_AFTER) always meet this condition but any
- * other encoded last index has some list for which it fails.
+ * The encoded index (last >= TCL_INDEX_START) always meet this
+ * condition but any other encoded last index has some list for
+ * which it fails.
*
* Finally we need, third:
*
* (first <= last)
*
* Considered in combination with the constraints we already have,
- * we see that we can proceed when (first == TCL_INDEX_BEFORE)
- * or (last == TCL_INDEX_AFTER). These also permit simplification
- * of the prefix|replace|suffix construction. The other constraints,
- * though, interfere with getting a guarantee that first <= last.
+ * we see that we can proceed when (first == TCL_INDEX_NONE).
+ * These also permit simplification of the prefix|replace|suffix
+ * construction. The other constraints, though, interfere with
+ * getting a guarantee that first <= last.
*/
- if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
+ if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
/* empty prefix */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP4( REVERSE, 2);
- if (last == TCL_INDEX_AFTER) {
+ if (last == INT_MAX) {
OP( POP); /* Pop original */
} else {
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
}
return TCL_OK;
}
- if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
+ if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
OP44( STR_RANGE_IMM, 0, first-1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
@@ -1143,19 +1198,19 @@ TclCompileStringReplaceCmd(
* are harmless when they are replaced by another empty string.
*/
- if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
+ if (first == (int)TCL_INDEX_START) {
/* empty prefix - build suffix only */
- if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix too => empty result */
OP( POP); /* Pop original */
PUSH ( "");
return TCL_OK;
}
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
return TCL_OK;
} else {
- if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ if (last == (int)TCL_INDEX_END) {
/* empty suffix - build prefix only */
OP44( STR_RANGE_IMM, 0, first-1);
return TCL_OK;
@@ -1163,7 +1218,7 @@ TclCompileStringReplaceCmd(
OP( DUP);
OP44( STR_RANGE_IMM, 0, first-1);
OP4( REVERSE, 2);
- OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
@@ -1189,8 +1244,7 @@ TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1217,8 +1271,7 @@ TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1245,8 +1298,7 @@ TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1366,7 +1418,8 @@ StringClassDesc const tclStringClassTable[] = {
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
- {NULL, NULL}
+ {"unicode", Tcl_UniCharIsUnicode},
+ {"", NULL}
};
/*
@@ -1394,8 +1447,7 @@ TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1492,14 +1544,14 @@ TclSubstCompile(
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
int length, literal, catchRange, breakJump;
- char buf[TCL_UTF_MAX] = "";
+ char buf[4] = "";
JumpFixup startFixup, okFixup, returnFixup, breakFixup;
JumpFixup continueFixup, otherFixup, endFixup;
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
- literal = TclRegisterNewLiteral(envPtr,
- tokenPtr->start, tokenPtr->size);
+ literal = TclRegisterLiteral(envPtr,
+ tokenPtr->start, tokenPtr->size, 0);
TclEmitPush(literal, envPtr);
TclAdvanceLines(&bline, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
@@ -1508,7 +1560,7 @@ TclSubstCompile(
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
- literal = TclRegisterNewLiteral(envPtr, buf, length);
+ literal = TclRegisterLiteral(envPtr, buf, length, 0);
TclEmitPush(literal, envPtr);
count++;
continue;
@@ -1727,8 +1779,7 @@ TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -1944,10 +1995,10 @@ TclCompileSwitchCmd(
}
if (numWords % 2) {
abort:
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyContLines);
+ ckfree(bodyToken);
+ ckfree(bodyTokenArray);
+ ckfree(bodyLines);
+ ckfree(bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
@@ -2496,9 +2547,9 @@ IssueSwitchJumpTable(
*----------------------------------------------------------------------
*/
-static ClientData
+static void *
DupJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
@@ -2518,7 +2569,7 @@ DupJumptableInfo(
static void
FreeJumptableInfo(
- ClientData clientData)
+ void *clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
@@ -2528,9 +2579,9 @@ FreeJumptableInfo(
static void
PrintJumptableInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *appendObj,
- ByteCode *codePtr,
+ TCL_UNUSED(ByteCode *),
unsigned int pcOffset)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
@@ -2557,17 +2608,17 @@ PrintJumptableInfo(
static void
DisassembleJumptableInfo(
- ClientData clientData,
+ void *clientData,
Tcl_Obj *dictObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
+ TCL_UNUSED(ByteCode *),
+ TCL_UNUSED(unsigned int))
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_Obj *mapping;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
- int offset;
+ size_t offset;
TclNewObj(mapping);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
@@ -2575,7 +2626,7 @@ DisassembleJumptableInfo(
keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
- Tcl_NewIntObj(offset));
+ Tcl_NewWideIntObj(offset));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
@@ -2603,8 +2654,7 @@ TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2650,8 +2700,7 @@ TclCompileThrowCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -2682,7 +2731,7 @@ TclCompileThrowCmd(
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
- TclListObjLength(interp, objPtr, &len));
+ TclListObjLengthM(interp, objPtr, &len));
codeIsValid = codeIsList && (len != 0);
if (codeIsValid) {
@@ -2754,8 +2803,7 @@ TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
@@ -2816,7 +2864,7 @@ TclCompileTryCmd(
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
- || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK
+ || TclListObjLengthM(NULL, tmpObj, &objc) != TCL_OK
|| (objc == 0)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
@@ -2859,14 +2907,14 @@ TclCompileTryCmd(
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
+ if (TclListObjGetElementsM(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
int len;
- const char *varname = Tcl_GetStringFromObj(objv[0], &len);
+ const char *varname = TclGetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
@@ -2878,7 +2926,7 @@ TclCompileTryCmd(
}
if (objc == 2) {
int len;
- const char *varname = Tcl_GetStringFromObj(objv[1], &len);
+ const char *varname = TclGetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
@@ -3073,7 +3121,7 @@ IssueTryClausesInstructions(
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
- TclListObjLength(NULL, matchClauses[i], &len);
+ TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
@@ -3084,7 +3132,7 @@ IssueTryClausesInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
@@ -3284,7 +3332,7 @@ IssueTryClausesFinallyInstructions(
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
- TclListObjLength(NULL, matchClauses[i], &len);
+ TclListObjLengthM(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
@@ -3295,7 +3343,7 @@ IssueTryClausesFinallyInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
@@ -3567,8 +3615,7 @@ TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3624,7 +3671,7 @@ TclCompileUnsetCmd(
const char *bytes;
int len;
- bytes = Tcl_GetStringFromObj(leadingWord, &len);
+ bytes = TclGetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
@@ -3706,8 +3753,7 @@ TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -3884,8 +3930,7 @@ TclCompileYieldCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
@@ -3927,8 +3972,7 @@ TclCompileYieldToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
@@ -4177,8 +4221,7 @@ int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
@@ -4188,8 +4231,7 @@ int
TclCompileNotOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
@@ -4199,8 +4241,7 @@ int
TclCompileAddOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
@@ -4211,8 +4252,7 @@ int
TclCompileMulOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
@@ -4223,8 +4263,7 @@ int
TclCompileAndOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
@@ -4235,8 +4274,7 @@ int
TclCompileOrOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
@@ -4247,8 +4285,7 @@ int
TclCompileXorOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
@@ -4259,8 +4296,7 @@ int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4290,8 +4326,7 @@ int
TclCompileLshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
@@ -4301,8 +4336,7 @@ int
TclCompileRshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
@@ -4312,8 +4346,7 @@ int
TclCompileModOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
@@ -4323,8 +4356,7 @@ int
TclCompileNeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
@@ -4334,8 +4366,7 @@ int
TclCompileStrneqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
@@ -4345,8 +4376,7 @@ int
TclCompileInOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
@@ -4356,8 +4386,7 @@ int
TclCompileNiOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
@@ -4368,8 +4397,7 @@ int
TclCompileLessOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
@@ -4379,8 +4407,7 @@ int
TclCompileLeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
@@ -4390,8 +4417,7 @@ int
TclCompileGreaterOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
@@ -4401,8 +4427,7 @@ int
TclCompileGeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
@@ -4412,8 +4437,7 @@ int
TclCompileEqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
@@ -4423,19 +4447,57 @@ int
TclCompileStreqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
+
+int
+TclCompileStrLtOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr);
+}
+
+int
+TclCompileStrLeOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr);
+}
+
+int
+TclCompileStrGtOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr);
+}
+
+int
+TclCompileStrGeOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ TCL_UNUSED(Command *),
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr);
+}
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
@@ -4480,8 +4542,7 @@ int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 989ca79..e97c552 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -164,6 +164,8 @@ enum Marks {
* "=" is encountered. */
#define INVALID 5 /* A parse error. Used when any punctuation
* appears that's not a supported operator. */
+#define COMMENT 6 /* Comment. Lasts to end of line or end of
+ * expression, whichever comes first. */
/* Leaf lexemes */
@@ -281,7 +283,11 @@ enum Marks {
* parse tree. The sub-expression between
* parens becomes the single argument of the
* matching OPEN_PAREN unary operator. */
-#define END (BINARY | 28)
+#define STR_LT (BINARY | 28)
+#define STR_GT (BINARY | 29)
+#define STR_LEQ (BINARY | 30)
+#define STR_GEQ (BINARY | 31)
+#define END (BINARY | 32)
/* This lexeme represents the end of the
* string being parsed. Treating it as a
* binary operator follows the same logic as
@@ -360,12 +366,14 @@ static const unsigned char prec[] = {
PREC_EQUAL, /* IN_LIST */
PREC_EQUAL, /* NOT_IN_LIST */
PREC_CLOSE_PAREN, /* CLOSE_PAREN */
+ PREC_COMPARE, /* STR_LT */
+ PREC_COMPARE, /* STR_GT */
+ PREC_COMPARE, /* STR_LEQ */
+ PREC_COMPARE, /* STR_GEQ */
PREC_END, /* END */
/* Expansion room for more binary operators */
- 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,
/* Unary operator lexemes */
PREC_UNARY, /* UNARY_PLUS */
PREC_UNARY, /* UNARY_MINUS */
@@ -415,12 +423,14 @@ static const unsigned char instruction[] = {
INST_LIST_IN, /* IN_LIST */
INST_LIST_NOT_IN, /* NOT_IN_LIST */
0, /* CLOSE_PAREN */
+ INST_STR_LT, /* STR_LT */
+ INST_STR_GT, /* STR_GT */
+ INST_STR_LE, /* STR_LEQ */
+ INST_STR_GE, /* STR_GEQ */
0, /* END */
/* Expansion room for more binary operators */
- 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,
/* Unary operator lexemes */
INST_UPLUS, /* UNARY_PLUS */
INST_UMINUS, /* UNARY_MINUS */
@@ -454,7 +464,7 @@ static const unsigned char Lexeme[] = {
INVALID /* FS */, INVALID /* GS */,
INVALID /* RS */, INVALID /* US */,
INVALID /* SPACE */, 0 /* ! or != */,
- QUOTED /* " */, INVALID /* # */,
+ QUOTED /* " */, 0 /* # */,
VARIABLE /* $ */, MOD /* % */,
0 /* & or && */, INVALID /* ' */,
OPEN_PAREN /* ( */, CLOSE_PAREN /* ) */,
@@ -701,6 +711,10 @@ ParseExpr(
int b;
switch (lexeme) {
+ case COMMENT:
+ start += scanned;
+ numBytes -= scanned;
+ continue;
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
scanned, start);
@@ -735,6 +749,32 @@ ParseExpr(
} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
lexeme = BOOLEAN;
} else {
+ /*
+ * Tricky case: see test expr-62.10
+ */
+
+ int scanned2 = scanned;
+ do {
+ scanned2 += TclParseAllWhiteSpace(
+ start + scanned2, numBytes - scanned2);
+ scanned2 += ParseLexeme(
+ start + scanned2, numBytes - scanned2, &lexeme,
+ NULL);
+ } while (lexeme == COMMENT);
+ if (lexeme == OPEN_PAREN) {
+ /*
+ * Actually a function call, but with obscuring
+ * comments. Skip to the start of the parentheses.
+ * Note that we assume that open parentheses are one
+ * byte long.
+ */
+
+ lexeme = FUNCTION;
+ Tcl_ListObjAppendElement(NULL, funcList, literal);
+ scanned = scanned2 - 1;
+ break;
+ }
+
Tcl_DecrRefCount(literal);
msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
(scanned < limit) ? scanned : limit - 3, start,
@@ -1439,7 +1479,7 @@ ParseExpr(
parsePtr->string, (numBytes < limit) ? "" : "..."));
if (errCode) {
Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
- subErrCode, NULL);
+ subErrCode, (void *)NULL);
}
}
@@ -1887,8 +1927,8 @@ ParseLexeme(
storage, if non-NULL. */
{
const char *end;
- int scanned;
- Tcl_UniChar ch = 0;
+ int scanned, size;
+ int ch;
Tcl_Obj *literal = NULL;
unsigned char byte;
@@ -1902,6 +1942,16 @@ ParseLexeme(
return 1;
}
switch (byte) {
+ case '#':
+ /*
+ * Scan forward over the comment contents.
+ */
+ for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) {
+ byte = UCHAR(start[size]);
+ }
+ *lexemePtr = COMMENT;
+ return size - (byte == '\n');
+
case '*':
if ((numBytes > 1) && (start[1] == '*')) {
*lexemePtr = EXPON;
@@ -2004,6 +2054,35 @@ ParseLexeme(
return 2;
}
}
+ break;
+
+ case 'l':
+ if ((numBytes > 1)
+ && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) {
+ switch (start[1]) {
+ case 't':
+ *lexemePtr = STR_LT;
+ return 2;
+ case 'e':
+ *lexemePtr = STR_LEQ;
+ return 2;
+ }
+ }
+ break;
+
+ case 'g':
+ if ((numBytes > 1)
+ && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) {
+ switch (start[1]) {
+ case 't':
+ *lexemePtr = STR_GT;
+ return 2;
+ case 'e':
+ *lexemePtr = STR_GEQ;
+ return 2;
+ }
+ }
+ break;
}
TclNewObj(literal);
@@ -2012,9 +2091,9 @@ ParseLexeme(
if (end < start + numBytes && !TclIsBareword(*end)) {
number:
- TclInitStringRep(literal, start, end-start);
*lexemePtr = NUMBER;
if (literalPtr) {
+ TclInitStringRep(literal, start, end-start);
*literalPtr = literal;
} else {
Tcl_DecrRefCount(literal);
@@ -2030,7 +2109,7 @@ ParseLexeme(
* Example: Inf + luence + () becomes a valid function call.
* [Bug 3401704]
*/
- if (literal->typePtr == &tclDoubleType) {
+ if (TclHasInternalRep(literal, &tclDoubleType)) {
const char *p = start;
while (p < end) {
@@ -2067,13 +2146,13 @@ ParseLexeme(
if (!TclIsBareword(*start) || *start == '_') {
if (Tcl_UtfCharComplete(start, numBytes)) {
- scanned = TclUtfToUniChar(start, &ch);
+ scanned = Tcl_UtfToUniChar(start, &ch);
} else {
- char utfBytes[TCL_UTF_MAX];
+ char utfBytes[8];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
- scanned = TclUtfToUniChar(utfBytes, &ch);
+ scanned = Tcl_UtfToUniChar(utfBytes, &ch);
}
*lexemePtr = INVALID;
Tcl_DecrRefCount(literal);
@@ -2086,7 +2165,7 @@ ParseLexeme(
}
*lexemePtr = BAREWORD;
if (literalPtr) {
- Tcl_SetStringObj(literal, start, (int) (end-start));
+ Tcl_SetStringObj(literal, start, end-start);
*literalPtr = literal;
} else {
Tcl_DecrRefCount(literal);
@@ -2144,8 +2223,8 @@ TclCompileExpr(
TclAdvanceLines(&envPtr->line, script,
script + TclParseAllWhiteSpace(script, numBytes));
- TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
- TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
+ TclListObjGetElementsM(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
+ TclListObjGetElementsM(NULL, funcList, &objc, &funcObjv);
CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
parsePtr->tokenPtr, envPtr, optimize);
} else {
@@ -2187,10 +2266,8 @@ ExecConstantExprTree(
CompileEnv *envPtr;
ByteCode *byteCodePtr;
int code;
- Tcl_Obj *byteCodeObj;
NRE_callback *rootPtr = TOP_CB(interp);
- TclNewObj(byteCodeObj);
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
@@ -2202,14 +2279,12 @@ ExecConstantExprTree(
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
TclEmitOpcode(INST_DONE, envPtr);
- Tcl_IncrRefCount(byteCodeObj);
- TclInitByteCodeObj(byteCodeObj, envPtr);
+ byteCodePtr = TclInitByteCode(envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = (ByteCode *)byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
- Tcl_DecrRefCount(byteCodeObj);
+ TclReleaseByteCode(byteCodePtr);
return code;
}
@@ -2277,9 +2352,9 @@ CompileExprTree(
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
- TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
+ TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
- Tcl_DStringLength(&cmdName)), envPtr);
+ Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
/*
@@ -2386,8 +2461,8 @@ CompileExprTree(
pc1 = CurrentOffset(envPtr);
TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
: INST_JUMP_TRUE1, 0, envPtr);
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr);
pc2 = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
@@ -2396,8 +2471,8 @@ CompileExprTree(
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
pc2 += 3;
}
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr,
+ (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
envPtr->codeStart + pc2 + 1);
convert = 0;
@@ -2431,7 +2506,7 @@ CompileExprTree(
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
- int idx = TclRegisterNewLiteral(envPtr, bytes, length);
+ int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
@@ -2486,11 +2561,13 @@ CompileExprTree(
* already, then use it to share via the literal table.
*/
- if (objPtr->bytes) {
+ if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
+ int numBytes;
+ const char *bytes
+ = TclGetStringFromObj(objPtr, &numBytes);
- idx = TclRegisterNewLiteral(envPtr, objPtr->bytes,
- objPtr->length);
+ idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
@@ -2576,7 +2653,7 @@ TclSingleOpCmd(
*
* TclSortingOpCmd --
* Implements the commands:
- * <, <=, >, >=, ==, eq
+ * <, <=, >, >=, ==, eq, lt, le, gt, ge
* in the ::tcl::mathop namespace. These commands are defined for
* arbitrary number of arguments by computing the AND of the base
* operator applied to all neighbor argument pairs.
@@ -2682,7 +2759,7 @@ TclVariadicOpCmd(
int code;
if (objc < 2) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(occdPtr->i.identity));
return TCL_OK;
}
@@ -2710,7 +2787,7 @@ TclVariadicOpCmd(
nodes[1].p.parent = 0;
} else {
if (lexeme == DIVIDE) {
- litObjv[0] = Tcl_NewDoubleObj(1.0);
+ TclNewDoubleObj(litObjv[0], 1.0);
} else {
TclNewIntObj(litObjv[0], occdPtr->i.identity);
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 76e0efb..7ca9e77 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -5,8 +5,8 @@
* commands (like quoted strings or nested sub-commands) into a sequence
* of instructions ("bytecodes").
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -659,6 +659,30 @@ InstructionDesc const tclInstructionTable[] = {
* 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
* Stack: ... => ... time */
+ {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* The top word is the default, the next op4 words (min 1) are a key
+ * path into the dictionary just below the keys on the stack, and all
+ * those values are replaced by the value read out of that key-path
+ * (like [dict get]) except if there is no such key, when instead the
+ * default is pushed instead.
+ * Stack: ... dict key1 ... keyN default => ... value */
+
+ {"strlt", 1, -1, 0, {OPERAND_NONE}},
+ /* String Less: push (stknext < stktop) */
+ {"strgt", 1, -1, 0, {OPERAND_NONE}},
+ /* String Greater: push (stknext > stktop) */
+ {"strle", 1, -1, 0, {OPERAND_NONE}},
+ /* String Less or equal: push (stknext <= stktop) */
+ {"strge", 1, -1, 0, {OPERAND_NONE}},
+ /* String Greater or equal: push (stknext >= stktop) */
+ {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}},
+ /* Operands: number of arguments, flags
+ * flags: Combination of TCL_LREPLACE4_* flags
+ * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj
+ * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not
+ * set in flags.
+ */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -666,6 +690,7 @@ InstructionDesc const tclInstructionTable[] = {
* Prototypes for procedures defined later in this file:
*/
+static void CleanupByteCode(ByteCode *codePtr);
static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
@@ -679,8 +704,8 @@ static void EnterCmdStartData(CompileEnv *envPtr,
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
-static int IsCompactibleCompileEnv(Tcl_Interp *interp,
- 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 */
@@ -693,14 +718,14 @@ static void StartExpanding(CompileEnv *envPtr);
* commands.
*/
static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
- Tcl_Token *tokenPtr, const char *cmd, int len,
+ Tcl_Token *tokenPtr, const char *cmd,
int numWords, int line, int *clNext, int **lines,
CompileEnv *envPtr);
static void ReleaseCmdWordData(ExtCmdLoc *eclPtr);
/*
- * The structure below defines the bytecode Tcl object type by means of
- * procedures that can be invoked by generic object code.
+ * tclByteCodeType provides the standard type management procedures for the
+ * bytecode type.
*/
const Tcl_ObjType tclByteCodeType = {
@@ -712,8 +737,8 @@ const Tcl_ObjType tclByteCodeType = {
};
/*
- * The structure below defines a bytecode Tcl object type to hold the
- * compiled bytecode for the [subst]itution of Tcl values.
+ * subtCodeType provides the standard type managemnt procedures for the
+ * substcode type, which represents substiution within a Tcl value.
*/
static const Tcl_ObjType substCodeType = {
@@ -723,13 +748,14 @@ static const Tcl_ObjType substCodeType = {
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2
/*
* Helper macros.
*/
#define TclIncrUInt4AtPtr(ptr, delta) \
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr))
/*
*----------------------------------------------------------------------
@@ -737,16 +763,14 @@ static const Tcl_ObjType substCodeType = {
* TclSetByteCodeFromAny --
*
* Part of the bytecode Tcl object type implementation. Attempts to
- * generate an byte code internal form for the Tcl object "objPtr" by
- * compiling its string representation. This function also takes a hook
- * procedure that will be invoked to perform any needed post processing
- * on the compilation results before generating byte codes. interp is
+ * compile the string representation of the objPtr into bytecode. Accepts
+ * a hook routine that is invoked to perform any needed post-processing on
+ * the compilation results before generating byte codes. interp is the
* compilation context and may not be NULL.
*
* Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result.
+ * A standard Tcl object result. If an error occurs during compilation, an
+ * error message is left in the interpreter's result.
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
@@ -763,12 +787,13 @@ TclSetByteCodeFromAny(
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
- ClientData clientData) /* Hook procedure private data. */
+ void *clientData) /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- int length, result = TCL_OK;
+ int length;
+ int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -776,7 +801,7 @@ TclSetByteCodeFromAny(
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
- (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
@@ -786,7 +811,7 @@ TclSetByteCodeFromAny(
stringPtr = TclGetStringFromObj(objPtr, &length);
/*
- * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
+ * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
@@ -795,15 +820,14 @@ TclSetByteCodeFromAny(
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
/*
- * Now we check if we have data about invisible continuation lines for the
- * script, and make it available to the compile environment, if so.
+ * Make available to the compilation environment any data about invisible
+ * continuation lines for the script.
*
* It is not clear if the script Tcl_Obj* can be free'd while the compiler
* is using it, leading to the release of the associated ContLineLoc
- * structure as well. To ensure that the latter doesn't happen we set a
- * lock on it. We release this lock in the function TclFreeCompileEnv(),
- * found in this file. The "lineCLPtr" hashtable is managed in the file
- * "tclObj.c".
+ * structure as well. To ensure that the latter doesn't happen set a lock
+ * on it, which is released in TclFreeCompileEnv(). The "lineCLPtr"
+ * hashtable tclObj.c.
*/
clLocPtr = TclContinuationsGet(objPtr);
@@ -814,7 +838,7 @@ TclSetByteCodeFromAny(
TclCompileScript(interp, stringPtr, length, &compEnv);
/*
- * Successful compilation. Add a "done" instruction at the end.
+ * Compilation succeeded. Add a "done" instruction at the end.
*/
TclEmitOpcode(INST_DONE, &compEnv);
@@ -822,14 +846,14 @@ TclSetByteCodeFromAny(
/*
* Check for optimizations!
*
- * Test if the generated code is free of most hazards; if so, recompile
- * but with generation of INST_START_CMD disabled. This produces somewhat
- * faster code in some cases, and more compact code in more.
+ * If the generated code is free of most hazards, recompile with generation
+ * of INST_START_CMD disabled to produce code that more compact in many
+ * cases, and also sometimes more performant.
*/
if (Tcl_GetParent(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
- && IsCompactibleCompileEnv(interp, &compEnv)) {
+ && IsCompactibleCompileEnv(&compEnv)) {
TclFreeCompileEnv(&compEnv);
iPtr->compiledProcPtr = procPtr;
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
@@ -854,7 +878,7 @@ TclSetByteCodeFromAny(
}
/*
- * Invoke the compilation hook procedure if one exists.
+ * Invoke the compilation hook procedure if there is one.
*/
if (hookProc) {
@@ -863,7 +887,7 @@ TclSetByteCodeFromAny(
/*
* Change the object into a ByteCode object. Ownership of the literal
- * objects and aux data items is given to the ByteCode object.
+ * objects and aux data items passes to the ByteCode object.
*/
#ifdef TCL_COMPILE_DEBUG
@@ -871,7 +895,7 @@ TclSetByteCodeFromAny(
#endif /*TCL_COMPILE_DEBUG*/
if (result == TCL_OK) {
- TclInitByteCodeObj(objPtr, &compEnv);
+ (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
@@ -894,12 +918,12 @@ TclSetByteCodeFromAny(
* compiling its string representation.
*
* Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result unless "interp" is NULL.
+ * A standard Tcl object result. If an error occurs during compilation and
+ * "interp" is not null, an error message is left in the interpreter's
+ * result.
*
* Side effects:
- * Frees the old internal representation. If no error occurs, then the
+ * Frees the old internal representation. If no error occurs then the
* compiled code is stored as "objPtr"s bytecode representation. Also, if
* debugging, initializes the "tcl_traceCompile" Tcl variable used to
* trace compilations.
@@ -911,7 +935,7 @@ static int
SetByteCodeFromAny(
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. */
+ Tcl_Obj *objPtr) /* The object to compile to bytecode */
{
if (interp == NULL) {
return TCL_ERROR;
@@ -925,9 +949,9 @@ SetByteCodeFromAny(
* DupByteCodeInternalRep --
*
* Part of the bytecode Tcl object type implementation. However, it does
- * not copy the internal representation of a bytecode Tcl_Obj, but
- * instead leaves the new object untyped (with a NULL type pointer).
- * Code will be compiled for the new object only if necessary.
+ * not copy the internal representation of a bytecode Tcl_Obj, instead
+ * assigning NULL to the type pointer of the new object. Code is compiled
+ * for the new object only if necessary.
*
* Results:
* None.
@@ -940,8 +964,8 @@ SetByteCodeFromAny(
static void
DupByteCodeInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ TCL_UNUSED(Tcl_Obj *) /*srcPtr*/,
+ TCL_UNUSED(Tcl_Obj *) /*copyPtr*/)
{
return;
}
@@ -959,9 +983,9 @@ DupByteCodeInternalRep(
* None.
*
* Side effects:
- * The bytecode object's internal rep is marked invalid and its code gets
- * freed unless the code is actively being executed. In that case the
- * cleanup is delayed until the last execution of the code completes.
+ * The bytecode object's internal rep is invalidated and its code is freed
+ * unless the code is actively being executed, in which case cleanup is
+ * delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
@@ -970,35 +994,54 @@ static void
FreeByteCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
/*
*----------------------------------------------------------------------
*
- * TclCleanupByteCode --
+ * TclReleaseByteCode --
*
- * This procedure does all the real work of freeing up a bytecode
- * object's ByteCode structure. It's called only when the structure's
- * reference count becomes zero.
+ * Does all the real work of freeing up a bytecode object's ByteCode
+ * structure. Called only when the structure's reference count
+ * is zero.
*
* Results:
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets its type NULL
- * Also releases its literals and frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type to
+ * NULL. Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
-TclCleanupByteCode(
+TclPreserveByteCode(
+ ByteCode *codePtr)
+{
+ codePtr->refCount++;
+}
+
+void
+TclReleaseByteCode(
+ ByteCode *codePtr)
+{
+ if (codePtr->refCount-- > 1) {
+ return;
+ }
+
+ /* Just dropped to refcount==0. Clean up. */
+ CleanupByteCode(codePtr);
+}
+
+static void
+CleanupByteCode(
ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
@@ -1018,7 +1061,7 @@ TclCleanupByteCode(
statsPtr = &iPtr->stats;
statsPtr->numByteCodesFreed++;
- statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
+ statsPtr->currentSrcBytes -= (double)codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
@@ -1049,8 +1092,8 @@ TclCleanupByteCode(
/*
* A single heap object holds the ByteCode structure and its code, object,
* command location, and auxiliary data arrays. This means we only need to
- * 1) decrement the ref counts of the LiteralEntry's in its literal array,
- * 2) call the free procs for the auxiliary data items, 3) free the
+ * 1) decrement the ref counts of each LiteralEntry in the literal array,
+ * 2) call the free procedures for the auxiliary data items, 3) free the
* localCache if it is unused, and finally 4) free the ByteCode
* structure's heap object.
*
@@ -1059,11 +1102,11 @@ TclCleanupByteCode(
* the global literal table. They instead maintain private references to
* their literals which must be decremented.
*
- * In order to insure a proper and efficient cleanup of the literal array
- * when it contains non-shared literals [Bug 983660], we also distinguish
- * the case of an interpreter being deleted (signaled by interp == NULL).
+ * In order to ensure proper and efficient cleanup of the literal array
+ * when it contains non-shared literals [Bug 983660], distinguish the case
+ * of an interpreter being deleted, which is signaled by interp == NULL.
* Also, as the interp deletion will remove the global literal table
- * anyway, we avoid the extra cost of updating it for each literal being
+ * anyway, avoid the extra cost of updating it for each literal being
* released.
*/
@@ -1095,9 +1138,9 @@ TclCleanupByteCode(
}
/*
- * TIP #280. Release the location data associated with this byte code
- * structure, if any. NOTE: The interp we belong to may be gone already,
- * and the data with it.
+ * TIP #280. Release the location data associated with this bytecode
+ * structure, if any. The associated interp may be gone already, and the
+ * data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
@@ -1112,7 +1155,7 @@ TclCleanupByteCode(
}
}
- if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
+ if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
@@ -1125,15 +1168,14 @@ TclCleanupByteCode(
*
* IsCompactibleCompileEnv --
*
- * Checks to see if we may apply some basic compaction optimizations to a
- * piece of bytecode. Idempotent.
+ * Determines whether some basic compaction optimizations may be applied
+ * to a piece of bytecode. Idempotent.
*
* ---------------------------------------------------------------------
*/
static int
IsCompactibleCompileEnv(
- Tcl_Interp *interp,
CompileEnv *envPtr)
{
unsigned char *pc;
@@ -1141,7 +1183,7 @@ IsCompactibleCompileEnv(
/*
* Special: procedures in the '::tcl' namespace (or its children) are
- * considered to be well-behaved and so can have compaction applied even
+ * considered to be well-behaved, so compaction can be applied to them even
* if it would otherwise be invalid.
*/
@@ -1157,10 +1199,10 @@ IsCompactibleCompileEnv(
/*
* Go through and ensure that no operation involved can cause a desired
- * change of bytecode sequence during running. This comes down to ensuring
- * that there are no mapped variables (due to traces) or calls to external
- * commands (traces, [uplevel] trickery). This is actually a very
- * conservative check; it turns down a lot of code that is OK in practice.
+ * change of bytecode sequence during its execution. This comes down to
+ * ensuring that there are no mapped variables (due to traces) or calls to
+ * external commands (traces, [uplevel] trickery). This is actually a very
+ * conservative check. It turns down a lot of code that is OK in practice.
*/
for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
@@ -1196,8 +1238,8 @@ IsCompactibleCompileEnv(
*
* Tcl_SubstObj --
*
- * This function performs the substitutions specified on the given string
- * as described in the user documentation for the "subst" Tcl command.
+ * Performs substitutions on the given string as described in the user
+ * documentation for "subst".
*
* Results:
* A Tcl_Obj* containing the substituted string, or NULL to indicate that
@@ -1229,14 +1271,14 @@ Tcl_SubstObj(
*
* Tcl_NRSubstObj --
*
- * Request substitution of a Tcl value by the NR stack.
+ * Adds substitution within the value of objPtr to the NR execution stack.
*
* Results:
- * Returns TCL_OK.
+ * TCL_OK.
*
* Side effects:
* Compiles objPtr into bytecode that performs the substitutions as
- * governed by flags and places callbacks on the NR stack to execute
+ * governed by flags, adds a callback to the NR execution stack to execute
* the bytecode and store the result in the interp.
*
*----------------------------------------------------------------------
@@ -1260,13 +1302,11 @@ Tcl_NRSubstObj(
*
* CompileSubstObj --
*
- * Compile a Tcl value into ByteCode implementing its substitution, as
- * governed by flags.
+ * Compiles a value into bytecode that performs substitution within the
+ * value, as governed by flags.
*
* Results:
- * A (ByteCode *) is returned pointing to the resulting ByteCode.
- * The caller must manage its refCount and arrange for a call to
- * TclCleanupByteCode() when the last reference disappears.
+ * A (ByteCode *) is pointing to the resulting ByteCode.
*
* Side effects:
* The Tcl_ObjType of objPtr is changed to the "substcode" type, and the
@@ -1286,24 +1326,26 @@ CompileSubstObj(
Interp *iPtr = (Interp *) interp;
ByteCode *codePtr = NULL;
- if (objPtr->typePtr == &substCodeType) {
+ ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
- if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2)
+ if (flags != PTR2INT(SubstFlags(objPtr))
|| ((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
|| (codePtr->nsEpoch != nsPtr->resolverEpoch)
|| (codePtr->localCachePtr !=
iPtr->varFramePtr->localCachePtr)) {
- FreeSubstCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &substCodeType) {
+ if (codePtr == NULL) {
CompileEnv compEnv;
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+ const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
@@ -1311,13 +1353,10 @@ CompileSubstObj(
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &substCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
+ SubstFlags(objPtr) = INT2PTR(flags);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1337,9 +1376,9 @@ CompileSubstObj(
*
* FreeSubstCodeInternalRep --
*
- * Part of the substcode Tcl object type implementation. Frees the
- * storage associated with a substcode object's internal representation
- * unless its code is actively being executed.
+ * Part of the "substcode" Tcl object type implementation. Frees the
+ * storage associated with the substcode internal representation of a
+ * Tcl_Obj unless its code is actively being executed.
*
* Results:
* None.
@@ -1356,12 +1395,12 @@ static void
FreeSubstCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr);
+ assert(codePtr != NULL);
+
+ TclReleaseByteCode(codePtr);
}
static void
@@ -1374,14 +1413,14 @@ ReleaseCmdWordData(
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
- ckfree((char *) eclPtr->loc[i].line);
+ ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
- ckfree((char *) eclPtr->loc);
+ ckfree(eclPtr->loc);
}
- ckfree((char *) eclPtr);
+ ckfree(eclPtr);
}
/*
@@ -1408,7 +1447,7 @@ TclInitCompileEnv(
CompileEnv *envPtr,/* Points to the CompileEnv structure to
* initialize. */
const char *stringPtr, /* The source string to be compiled. */
- int numBytes, /* Number of bytes in source string. */
+ TCL_HASH_TYPE numBytes, /* Number of bytes in source string. */
const CmdFrame *invoker, /* Location context invoking the bcc */
int word) /* Index of the word in that context getting
* compiled */
@@ -1593,14 +1632,14 @@ TclInitCompileEnv(
*
* TclFreeCompileEnv --
*
- * Free the storage allocated in a CompileEnv compilation environment
+ * Frees the storage allocated in a CompileEnv compilation environment
* structure.
*
* Results:
* None.
*
* Side effects:
- * Allocated storage in the CompileEnv structure is freed. Note that its
+ * Allocated storage in the CompileEnv structure is freed, although its
* local literal table is not deleted and its literal objects are not
* released. In addition, storage referenced by its auxiliary data items
* is not freed. This is done so that, when compilation is successful,
@@ -1671,10 +1710,11 @@ TclFreeCompileEnv(
*
* TclWordKnownAtCompileTime --
*
- * Test whether the value of a token is completely known at compile time.
+ * Determines whether the value of a token is completely known at compile
+ * time.
*
* Results:
- * Returns true if the tokenPtr argument points to a word value that is
+ * True if the tokenPtr argument points to a word value that is
* completely known at compile time. Generally, values that are known at
* compile time can be compiled to their values, while values that cannot
* be known until substitution at runtime must be compiled to bytecode
@@ -1723,7 +1763,7 @@ TclWordKnownAtCompileTime(
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
- char utfBuf[TCL_UTF_MAX] = "";
+ char utfBuf[4] = "";
int length = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfBuf);
@@ -1751,12 +1791,12 @@ TclWordKnownAtCompileTime(
*
* TclCompileScript --
*
- * Compile a Tcl script in a string.
+ * Compiles a Tcl script in a string.
*
* Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
+ *
+ * A standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
*
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
@@ -1785,20 +1825,20 @@ CompileCmdLiteral(
Tcl_Obj *cmdObj,
CompileEnv *envPtr)
{
- int numBytes;
const char *bytes;
Command *cmdPtr;
int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
+ int numBytes;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
- cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags);
+ bytes = TclGetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
- if (cmdPtr) {
+ if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
@@ -1813,7 +1853,8 @@ TclCompileInvocation(
CompileEnv *envPtr)
{
DefineLineInformation;
- int wordIdx = 0, depth = TclGetStackDepth(envPtr);
+ int wordIdx = 0;
+ int depth = TclGetStackDepth(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
@@ -1831,8 +1872,8 @@ TclCompileInvocation(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1881,8 +1922,8 @@ CompileExpanded(
continue;
}
- objIdx = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ objIdx = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
tokenPtr[1].start - envPtr->source, envPtr->clNext);
@@ -1893,14 +1934,14 @@ CompileExpanded(
/*
* The stack depth during argument expansion can only be managed at
* runtime, as the number of elements in the expanded lists is not known
- * at compile time. We adjust here the stack depth estimate so that it is
+ * at compile time. Adjust the stack depth estimate here so that it is
* correct after the command with expanded arguments returns.
*
* The end effect of this command's invocation is that all the words of
- * the command are popped from the stack, and the result is pushed: the
+ * the command are popped from the stack and the result is pushed: The
* stack top changes by (1-wordIdx).
*
- * Note that the estimates are not correct while the command is being
+ * The estimates are not correct while the command is being
* prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
*/
@@ -1920,16 +1961,16 @@ CompileCmdCompileProc(
int depth = TclGetStackDepth(envPtr);
/*
- * Emit of the INST_START_CMD instruction is controlled by the value of
+ * Emission of the INST_START_CMD instruction is controlled by the value of
* envPtr->atCmdStart:
*
- * atCmdStart == 2 : We are not using the INST_START_CMD instruction.
- * atCmdStart == 1 : INST_START_CMD was the last instruction emitted.
- * : We do not need to emit another. Instead we
- * : increment the number of cmds started at it (except
- * : for the special case at the start of a script.)
- * atCmdStart == 0 : The last instruction was something else. We need
- * : to emit INST_START_CMD here.
+ * atCmdStart == 2 : Don't use the INST_START_CMD instruction.
+ * atCmdStart == 1 : INST_START_CMD was the last instruction emitted,
+ * : so no need to emit another. Instead
+ * : increment the number of cmds started at it, except
+ * : for the special case at the start of a script.
+ * atCmdStart == 0 : The last instruction was something else.
+ * : Emit INST_START_CMD here.
*/
switch (envPtr->atCmdStart) {
@@ -1952,7 +1993,7 @@ CompileCmdCompileProc(
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) {
if (incrOffset >= 0) {
/*
- * We successfully compiled a command. Increment the number of
+ * Command compiled succesfully. Increment the number of
* commands that start at the currently active INST_START_CMD.
*/
@@ -2010,11 +2051,11 @@ CompileCommandTokens(
int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
int depth = TclGetStackDepth(envPtr);
- TclNewObj(cmdObj);
assert (parsePtr->numWords > 0);
/* Precompile */
+ TclNewObj(cmdObj);
envPtr->numCommands++;
EnterCmdStartData(envPtr, cmdIdx,
parsePtr->commandStart - envPtr->source, startCodeOffset);
@@ -2028,7 +2069,7 @@ CompileCommandTokens(
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ parsePtr->numWords, cmdLine,
clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
@@ -2090,8 +2131,8 @@ CompileCommandTokens(
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
/*
- * TIP #280: Free full form of per-word line data and insert the reduced
- * form now
+ * TIP #280: Free the full form of per-word line data and insert the
+ * reduced form now.
*/
envPtr->line = cmdLine;
@@ -2137,7 +2178,7 @@ TclCompileScript(
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested compilations (infinite loop?)", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (void *)NULL);
TclCompileSyntaxError(interp, envPtr);
return;
}
@@ -2326,7 +2367,7 @@ TclCompileVarSubst(
* of local variables in a procedure frame.
*/
- localVar = -1;
+ localVar = TCL_INDEX_NONE;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
}
@@ -2372,8 +2413,9 @@ TclCompileTokens(
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
- char buffer[TCL_UTF_MAX] = "";
- int i, numObjsToConcat, length, adjust;
+ char buffer[4] = "";
+ int i, numObjsToConcat, adjust;
+ int length;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
@@ -2381,18 +2423,16 @@ TclCompileTokens(
int depth = TclGetStackDepth(envPtr);
/*
- * For the handling of continuation lines in literals, first check if
- * this is actually a literal. For if not we can forego the additional
- * processing. Otherwise preallocate a small table to store the
- * locations of all continuation lines found in this literal, if any.
- * The table is extended if needed.
+ * If this is actually a literal, handle continuation lines by
+ * preallocating a small table to store the locations of any continuation
+ * lines found in this literal. The table is extended if needed.
*
- * Note: Different to the equivalent code in function 'TclSubstTokens()'
- * (see file "tclParse.c") there seem to be no need the 'adjust' variable.
- * There also seems to be no need for code which merges continuation line
- * information of multiple words which concat'd at runtime. Either that or
- * I have not managed to find a test case for these two possibilities yet.
- * It might be a difference between compile- versus run-time processing.
+ * Note: In contrast with the analagous code in 'TclSubstTokens()' the
+ * 'adjust' variable seems unneeded here. The code which merges
+ * continuation line information of multiple words which concat'd at
+ * runtime also seems unneeded. Either that or I have not managed to find a
+ * test case for these two possibilities yet. It might be a difference
+ * between compile- versus run-time processing.
*/
numCL = 0;
@@ -2428,18 +2468,17 @@ TclCompileTokens(
Tcl_DStringAppend(&textBuffer, buffer, length);
/*
- * If the backslash sequence we found is in a literal, and
- * represented a continuation line, we compute and store its
+ * If the identified backslash sequence is in a literal and
+ * represented a continuation line, compute and store its
* location (as char offset to the beginning of the _result_
* script). We may have to extend the table of locations.
*
- * Note that the continuation line information is relevant even if
- * the word we are processing is not a literal, as it can affect
- * nested commands. See the branch for TCL_TOKEN_COMMAND below,
- * where the adjustment we are tracking here is taken into
- * account. The good thing is that we do not need a table of
- * everything, just the number of lines we have to add as
- * correction.
+ * The continuation line information is relevant even if the word
+ * being processed is not a literal, as it can affect nested
+ * commands. See the branch below for TCL_TOKEN_COMMAND, where the
+ * adjustment being tracked here is taken into account. The good
+ * thing is a table of everything is not needed, just the number of
+ * lines to to add as correction.
*/
if ((length == 1) && (buffer[0] == ' ') &&
@@ -2565,13 +2604,13 @@ TclCompileTokens(
* TclCompileCmdWord --
*
* Given an array of parse tokens for a word containing one or more Tcl
- * commands, emit inline instructions to execute them. This procedure
- * differs from TclCompileTokens in that a simple word such as a loop
- * body enclosed in braces is not just pushed as a string, but is itself
- * parsed into tokens and compiled.
+ * commands, emits inline instructions to execute them. In contrast with
+ * TclCompileTokens, a simple word such as a loop body enclosed in braces
+ * is not just pushed as a string, but is itself parsed into tokens and
+ * compiled.
*
* Results:
- * The return value is a standard Tcl result. If an error occurs, an
+ * A standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
@@ -2591,16 +2630,16 @@ TclCompileCmdWord(
{
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
/*
- * Handle the common case: if there is a single text token, compile it
+ * 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);
} else {
/*
- * Multiple tokens or the single token involves substitutions. Emit
- * instructions to invoke the eval command procedure at runtime on the
- * result of evaluating the tokens.
+ * Either there are multiple tokens, or the single token involves
+ * substitutions. Emit instructions to invoke the eval command
+ * procedure at runtime on the result of evaluating the tokens.
*/
TclCompileTokens(interp, tokenPtr, count, envPtr);
@@ -2614,13 +2653,12 @@ TclCompileCmdWord(
* TclCompileExprWords --
*
* Given an array of parse tokens representing one or more words that
- * contain a Tcl expression, emit inline instructions to execute the
- * expression. This procedure differs from TclCompileExpr in that it
- * supports Tcl's two-level substitution semantics for expressions that
- * appear as command words.
+ * contain a Tcl expression, emits inline instructions to execute the
+ * expression. In contrast with TclCompileExpr, supports Tcl's two-level
+ * substitution semantics for an expression that appears as command words.
*
* Results:
- * The return value is a standard Tcl result. If an error occurs, an
+ * A standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
* Side effects:
@@ -2682,10 +2720,10 @@ TclCompileExprWords(
*
* TclCompileNoOp --
*
- * Function called to compile no-op's
+ * Compiles no-op's
*
* Results:
- * The return value is TCL_OK, indicating successful compilation.
+ * TCL_OK if completion was successful.
*
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
@@ -2700,8 +2738,7 @@ TclCompileNoOp(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to definition of command being
- * compiled. */
+ TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
@@ -2745,11 +2782,40 @@ TclCompileNoOp(
*----------------------------------------------------------------------
*/
-void
-TclInitByteCodeObj(
- Tcl_Obj *objPtr, /* Points object that should be initialized,
- * and whose string rep contains the source
- * code. */
+static void
+PreventCycle(
+ Tcl_Obj *objPtr,
+ CompileEnv *envPtr)
+{
+ int 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
+ * reach zero, and memory may leak. Bugs 467523, 3357771
+ *
+ * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
+ * on the string value, and do not call Tcl_DuplicateObj() so we
+ * can be sure we do not have any lingering cycles hiding in
+ * the internalrep.
+ */
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
+ Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
+
+ Tcl_IncrRefCount(copyPtr);
+ TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);
+
+ envPtr->literalArrayPtr[i].objPtr = copyPtr;
+ }
+ }
+}
+
+ByteCode *
+TclInitByteCode(
CompileEnv *envPtr)/* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
@@ -2779,9 +2845,13 @@ TclInitByteCodeObj(
/*
* 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 = sizeof(ByteCode);
+ 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 */
@@ -2800,7 +2870,8 @@ TclInitByteCodeObj(
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
- codePtr->refCount = 1;
+ codePtr->refCount = 0;
+ TclPreserveByteCode(codePtr);
if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
} else {
@@ -2819,36 +2890,14 @@ TclInitByteCodeObj(
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
- p += sizeof(ByteCode);
+ 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++) {
- Tcl_Obj *fetched = TclFetchLiteral(envPtr, i);
-
- if (objPtr == fetched) {
- /*
- * 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
- * reach zero, and memory may leak. Bugs 467523, 3357771
- *
- * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
- * on the string value, and do not call Tcl_DuplicateObj() so we
- * can be sure we do not have any lingering cycles hiding in
- * the internalrep.
- */
- int numBytes;
- const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
-
- codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
- Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
- TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr);
- } else {
- codePtr->objArrayPtr[i] = fetched;
- }
+ codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i);
}
p += TCL_ALIGN(objArrayBytes); /* align exception range array */
@@ -2891,15 +2940,6 @@ TclInitByteCodeObj(
#endif /* TCL_COMPILE_STATS */
/*
- * Free the old internal rep then convert the object to a bytecode object
- * by making its internal rep point to the just compiled ByteCode.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
- objPtr->typePtr = &tclByteCodeType;
-
- /*
* TIP #280. Associate the extended per-word line information with the
* byte code object (internal rep), for use with the bc compiler.
*/
@@ -2912,6 +2952,31 @@ TclInitByteCodeObj(
envPtr->iPtr = NULL;
codePtr->localCachePtr = NULL;
+ return codePtr;
+}
+
+ByteCode *
+TclInitByteCodeObj(
+ Tcl_Obj *objPtr, /* Points object that should be initialized,
+ * and whose string rep contains the source
+ * code. */
+ const Tcl_ObjType *typePtr,
+ CompileEnv *envPtr)/* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
+{
+ ByteCode *codePtr;
+
+ PreventCycle(objPtr, envPtr);
+
+ codePtr = TclInitByteCode(envPtr);
+
+ /*
+ * Free the old internal rep then convert the object to a bytecode object
+ * by making its internal rep point to the just compiled ByteCode.
+ */
+
+ ByteCodeSetInternalRep(objPtr, typePtr, codePtr);
+ return codePtr;
}
/*
@@ -2950,7 +3015,7 @@ TclFindCompiledLocal(
CompileEnv *envPtr) /* Points to the current compile environment*/
{
CompiledLocal *localPtr;
- int localVar = -1;
+ int localVar = TCL_INDEX_NONE;
int i;
Proc *procPtr;
@@ -2973,19 +3038,19 @@ TclFindCompiledLocal(
int len;
if (!cachePtr || !name) {
- return -1;
+ return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = Tcl_GetStringFromObj(*varNamePtr, &len);
+ localName = TclGetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
- return -1;
+ return TCL_INDEX_NONE;
}
if (name != NULL) {
@@ -3011,7 +3076,7 @@ TclFindCompiledLocal(
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
- localPtr = (CompiledLocal *)ckalloc(TclOffset(CompiledLocal, name) + 1U + nameBytes);
+ localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + 1U + nameBytes);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -3042,16 +3107,15 @@ TclFindCompiledLocal(
*
* TclExpandCodeArray --
*
- * Procedure that uses malloc to allocate more storage for a CompileEnv's
- * code array.
+ * Uses malloc to allocate more storage for a CompileEnv's code array.
*
* Results:
* None.
*
* Side effects:
- * The byte code array in *envPtr is reallocated to a new array of double
- * the size, and if envPtr->mallocedCodeArray is non-zero the old array
- * is freed. Byte codes are copied from the old array to the new one.
+ * The size of the bytecode array is doubled. If envPtr->mallocedCodeArray
+ * is non-zero the old array is freed. Byte codes are copied from the old
+ * array to the new one.
*
*----------------------------------------------------------------------
*/
@@ -3078,8 +3142,8 @@ TclExpandCodeArray(
envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes);
} else {
/*
- * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
- * ckrealloc equivalent for ourselves.
+ * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so
+ * perform the equivalent of Tcl_Realloc directly.
*/
unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
@@ -3167,8 +3231,8 @@ EnterCmdStartData(
cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
- cmdLocPtr->numSrcBytes = -1;
- cmdLocPtr->numCodeBytes = -1;
+ cmdLocPtr->numSrcBytes = TCL_INDEX_NONE;
+ cmdLocPtr->numCodeBytes = TCL_INDEX_NONE;
}
/*
@@ -3246,7 +3310,6 @@ EnterCmdWordData(
int srcOffset, /* Offset of first char of the command. */
Tcl_Token *tokenPtr,
const char *cmd,
- int len,
int numWords,
int line,
int *clNext,
@@ -3255,7 +3318,8 @@ EnterCmdWordData(
{
ECL *ePtr;
const char *last;
- int wordIdx, wordLine, *wwlines, *wordNext;
+ int wordIdx, wordLine;
+ int *wwlines, *wordNext;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
@@ -3290,7 +3354,7 @@ EnterCmdWordData(
/* See Ticket 4b61afd660 */
wwlines[wordIdx] =
((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL))
- ? wordLine : -1;
+ ? wordLine : TCL_INDEX_NONE;
ePtr->line[wordIdx] = wordLine;
ePtr->next[wordIdx] = wordNext;
last = tokenPtr->start;
@@ -3340,7 +3404,7 @@ TclCreateExceptRange(
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
- int newElems = 2*envPtr->exceptArrayEnd;
+ size_t newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
@@ -3371,16 +3435,16 @@ TclCreateExceptRange(
rangePtr = &envPtr->exceptArrayPtr[index];
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
- rangePtr->codeOffset = -1;
- rangePtr->numCodeBytes = -1;
- rangePtr->breakOffset = -1;
- rangePtr->continueOffset = -1;
- rangePtr->catchOffset = -1;
+ 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 = -1;
+ auxPtr->expandTargetDepth = TCL_INDEX_NONE;
auxPtr->numBreakTargets = 0;
auxPtr->breakTargets = NULL;
auxPtr->allocBreakTargets = 0;
@@ -3396,7 +3460,7 @@ TclCreateExceptRange(
* TclGetInnermostExceptionRange --
*
* Returns the innermost exception range that covers the current code
- * creation point, and (optionally) the stack depth that is expected at
+ * creation point, and optionally the stack depth that is expected at
* that point. Relies on the fact that the range has a numCodeBytes = -1
* when it is being populated and that inner ranges come after outer
* ranges.
@@ -3410,14 +3474,14 @@ TclGetInnermostExceptionRange(
int returnCode,
ExceptionAux **auxPtrPtr)
{
- int i = envPtr->exceptArrayNext;
+ size_t i = envPtr->exceptArrayNext;
ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i;
while (i > 0) {
rangePtr--; i--;
if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
- (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
+ (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) <
rangePtr->codeOffset+rangePtr->numCodeBytes) &&
(returnCode != TCL_CONTINUE ||
envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
@@ -3502,8 +3566,8 @@ TclAddLoopContinueFixup(
*
* TclCleanupStackForBreakContinue --
*
- * Ditch the extra elements from the auxiliary stack and the main stack.
- * How to do this exactly depends on whether there are any elements on
+ * Removes the extra elements from the auxiliary stack and the main stack.
+ * How this is done depends on whether there are any elements on
* the auxiliary stack to pop.
*
* ---------------------------------------------------------------------
@@ -3514,7 +3578,7 @@ TclCleanupStackForBreakContinue(
CompileEnv *envPtr,
ExceptionAux *auxPtr)
{
- int savedStackDepth = envPtr->currStackDepth;
+ size_t savedStackDepth = envPtr->currStackDepth;
int toPop = envPtr->expandCount - auxPtr->expandTarget;
if (toPop > 0) {
@@ -3568,12 +3632,12 @@ StartExpanding(
if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
continue;
}
- if (rangePtr->numCodeBytes != -1) {
+ if (rangePtr->numCodeBytes != TCL_INDEX_NONE) {
continue;
}
/*
- * Adequate condition: further out loops and further in exceptions
+ * Adequate condition: loops further out and exceptions further in
* don't actually need this information.
*/
@@ -3583,7 +3647,7 @@ StartExpanding(
}
/*
- * There's now one more expansion being processed on the auxiliary stack.
+ * One more expansion is now being processed on the auxiliary stack.
*/
envPtr->expandCount++;
@@ -3596,7 +3660,7 @@ StartExpanding(
*
* Finalizes a loop exception range, binding the registered [break] and
* [continue] implementations so that they jump to the correct place.
- * Note that this must only be called after *all* the exception range
+ * This must be called only after *all* the exception range
* target offsets have been set.
*
* ---------------------------------------------------------------------
@@ -3628,7 +3692,7 @@ TclFinalizeLoopExceptionRange(
}
for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
site = envPtr->codeStart + auxPtr->continueTargets[i];
- if (rangePtr->continueOffset == -1) {
+ if (rangePtr->continueOffset == TCL_INDEX_NONE) {
int j;
/*
@@ -3667,27 +3731,23 @@ TclFinalizeLoopExceptionRange(
*
* TclCreateAuxData --
*
- * Procedure that allocates and initializes a new AuxData structure in a
+ * Allocates and initializes a new AuxData structure in a
* CompileEnv's array of compilation auxiliary data records. These
* AuxData records hold information created during compilation by
* CompileProcs and used by instructions during execution.
*
* Results:
- * Returns the index for the newly created AuxData structure.
+ * The index of the newly-created AuxData structure in the array.
*
* Side effects:
- * If there is not enough room in the CompileEnv's AuxData array, the
- * AuxData array in expanded: a new array of double the size is
- * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array
- * is freed, and AuxData entries are copied from the old array to the new
- * one.
- *
+ * If there is not enough room in the CompileEnv's AuxData array, its size
+ * is doubled.
*----------------------------------------------------------------------
*/
int
TclCreateAuxData(
- ClientData clientData, /* The compilation auxiliary data to store in
+ 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 */
@@ -3707,7 +3767,7 @@ TclCreateAuxData(
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
- int newElems = 2*envPtr->auxDataArrayEnd;
+ size_t newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
@@ -3769,8 +3829,7 @@ TclInitJumpFixupArray(
*
* TclExpandJumpFixupArray --
*
- * Procedure that uses malloc to allocate more storage for a jump fixup
- * array.
+ * Uses malloc to allocate more storage for a jump fixup array.
*
* Results:
* None.
@@ -3797,7 +3856,7 @@ TclExpandJumpFixupArray(
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
- int newElems = 2*(fixupArrayPtr->end + 1);
+ size_t newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
@@ -3849,10 +3908,11 @@ TclFreeJumpFixupArray(
*
* TclEmitForwardJump --
*
- * Procedure to emit a two-byte forward jump of kind "jumpType". Since
- * the jump may later have to be grown to five bytes if the jump target
- * is more than, say, 127 bytes away, this procedure also initializes a
- * JumpFixup record with information about the jump.
+ * Emits a two-byte forward jump of kind "jumpType". Also initializes a
+ * JumpFixup record with information about the jump. Since may later be
+ * necessary to increase the size of the jump instruction to five bytes if
+ * the jump target is more than, say, 127 bytes away.
+ *
*
* Results:
* None.
@@ -3907,16 +3967,17 @@ TclEmitForwardJump(
*
* TclFixupForwardJump --
*
- * Procedure that updates a previously-emitted forward jump to jump a
- * specified number of bytes, "jumpDist". If necessary, the jump is grown
- * from two to five bytes; this is done if the jump distance is greater
- * than "distThreshold" (normally 127 bytes). The jump is described by a
- * JumpFixup record previously initialized by TclEmitForwardJump.
+ * Modifies a previously-emitted forward jump to jump a specified number
+ * of bytes, "jumpDist". If necessary, the size of the jump instruction is
+ * increased from two to five bytes. This is done if the jump distance is
+ * greater than "distThreshold" (normally 127 bytes). The jump is
+ * described by a JumpFixup record previously initialized by
+ * TclEmitForwardJump.
*
* Results:
- * 1 if the jump was grown and subsequent instructions had to be moved;
- * otherwise 0. This result is returned to allow callers to update any
- * additional code offsets they may hold.
+ * 1 if the jump was grown and subsequent instructions had to be moved, or
+ * 0 otherwsie. This allows callers to update any additional code offsets
+ * they may hold.
*
* Side effects:
* The jump may be grown and subsequent instructions moved. If this
@@ -3940,7 +4001,7 @@ TclFixupForwardJump(
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
- unsigned numBytes;
+ size_t numBytes;
if (jumpDist <= distThreshold) {
jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
@@ -3959,10 +4020,10 @@ TclFixupForwardJump(
}
/*
- * We must grow the jump then move subsequent instructions down. Note that
- * if we expand the space for generated instructions, code addresses might
- * change; be careful about updating any of these addresses held in
- * variables.
+ * Increase the size of the jump instruction, and then move subsequent
+ * instructions down. Expanding the space for generated instructions means
+ * that code addresses might change. Be careful about updating any of
+ * these addresses held in variables.
*/
if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
@@ -4009,7 +4070,7 @@ TclFixupForwardJump(
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
- if (rangePtr->continueOffset != -1) {
+ if (rangePtr->continueOffset != TCL_INDEX_NONE) {
rangePtr->continueOffset += 3;
}
break;
@@ -4046,7 +4107,7 @@ TclFixupForwardJump(
*
* TclEmitInvoke --
*
- * Emit one of the invoke-related instructions, wrapping it if necessary
+ * Emits one of the invoke-related instructions, wrapping it if necessary
* in code that ensures that any break or continue operation passing
* through it gets the stack unwinding correct, converting it into an
* internal jump if in an appropriate context.
@@ -4056,7 +4117,7 @@ TclFixupForwardJump(
*
* Side effects:
* Issues the jump with all correct stack management. May create another
- * loop exception range; pointers to ExceptionRange and ExceptionAux
+ * loop exception range. Pointers to ExceptionRange and ExceptionAux
* structures should not be held across this call.
*
*----------------------------------------------------------------------
@@ -4114,12 +4175,11 @@ TclEmitInvoke(
va_end(argList);
/*
- * Determine if we need to handle break and continue exceptions with a
- * special handling exception range (so that we can correctly unwind the
- * stack).
+ * If the exceptions is for break or continue handle it with special
+ * handling exception range so the stack may be correctly unwound.
*
- * These must be done separately; they can be different (especially for
- * calls from inside a [for] increment clause).
+ * These must be done separately since they can be different, especially
+ * for calls from inside a [for] increment clause.
*/
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
@@ -4127,7 +4187,7 @@ TclEmitInvoke(
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxContinuePtr = NULL;
} else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
- && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
+ && (auxContinuePtr->expandTarget+expandCount == envPtr->expandCount)) {
auxContinuePtr = NULL;
} else {
continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr;
@@ -4137,8 +4197,8 @@ TclEmitInvoke(
if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
auxBreakPtr = NULL;
} else if (auxContinuePtr == NULL
- && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
- && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
+ && auxBreakPtr->stackDepth+wordCount == envPtr->currStackDepth
+ && auxBreakPtr->expandTarget+expandCount == envPtr->expandCount) {
auxBreakPtr = NULL;
} else {
breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
@@ -4339,16 +4399,16 @@ GetCmdLocEncodingSize(
*
* EncodeCmdLocMap --
*
- * Encode the command location information for some compiled code into a
+ * Encodes the command location information for some compiled code into a
* ByteCode structure. The encoded command location map is stored as
- * three adjacent byte sequences.
+ * three-adjacent-byte sequences.
*
* Results:
- * Pointer to the first byte after the encoded command location
+ * A pointer to the first byte after the encoded command location
* information.
*
* Side effects:
- * The encoded information is stored into the block of memory headed by
+ * Stores encoded information into the block of memory headed by
* codePtr. Also records pointers to the start of the four byte sequences
* in fields in codePtr's ByteCode header structure.
*
@@ -4463,9 +4523,9 @@ EncodeCmdLocMap(
*
* RecordByteCodeStats --
*
- * Accumulates various compilation-related statistics for each newly
- * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
- * compiled with the -DTCL_COMPILE_STATS flag
+ * Accumulates compilation-related statistics for each newly-compiled
+ * ByteCode. Called by the TclInitByteCodeObj when Tcl is compiled with
+ * the -DTCL_COMPILE_STATS flag
*
* Results:
* None.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index f262b37..1d748b5 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -87,22 +87,22 @@ typedef enum {
* to a catch PC offset. */
} ExceptionRangeType;
-typedef struct ExceptionRange {
+typedef struct {
ExceptionRangeType type; /* The kind of ExceptionRange. */
- int nestingLevel; /* Static depth of the exception range. Used
+ Tcl_Size nestingLevel; /* Static depth of the exception range. Used
* to find the most deeply-nested range
* surrounding a PC at runtime. */
- int codeOffset; /* Offset of the first instruction byte of the
+ Tcl_Size codeOffset; /* Offset of the first instruction byte of the
* code range. */
- int numCodeBytes; /* Number of bytes in the code range. */
- int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
+ Tcl_Size numCodeBytes; /* Number of bytes in the code range. */
+ Tcl_Size breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
* offset for a break command in the range. */
- int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the
+ Tcl_Size 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. */
- int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
+ Tcl_Size catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
* offset for any "exception" in range. */
} ExceptionRange;
@@ -118,40 +118,40 @@ typedef struct ExceptionAux {
* one (see [for] next-clause) then we must
* not pick up the range when scanning for a
* target to continue to. */
- int stackDepth; /* The stack depth at the point where the
+ Tcl_Size 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. */
- int expandTarget; /* The number of expansions expected on the
+ Tcl_Size 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. */
- int expandTargetDepth; /* The stack depth expected at the outermost
+ Tcl_Size 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. */
- int numBreakTargets; /* The number of [break]s that want to be
+ Tcl_Size numBreakTargets; /* The number of [break]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
- unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions
+ 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. */
- int allocBreakTargets; /* The size of the breakTargets array. */
- int numContinueTargets; /* The number of [continue]s that want to be
+ Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */
+ Tcl_Size numContinueTargets; /* The number of [continue]s that want to be
* targeted to the place where this loop
* exception will be bound to. */
- unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions
+ 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. */
- int allocContinueTargets; /* The size of the continueTargets array. */
+ Tcl_Size allocContinueTargets; /* The size of the continueTargets array. */
} ExceptionAux;
/*
@@ -162,11 +162,11 @@ typedef struct ExceptionAux {
* source offset is not monotonic.
*/
-typedef struct CmdLocation {
- int codeOffset; /* Offset of first byte of command code. */
- int numCodeBytes; /* Number of bytes for command's code. */
- int srcOffset; /* Offset of first char of the command. */
- int numSrcBytes; /* Number of command source chars. */
+typedef struct {
+ Tcl_Size codeOffset; /* Offset of first byte of command code. */
+ Tcl_Size numCodeBytes; /* Number of bytes for command's code. */
+ Tcl_Size srcOffset; /* Offset of first char of the command. */
+ Tcl_Size numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
@@ -180,26 +180,26 @@ typedef struct CmdLocation {
* frame and associated information, like the path of a sourced file.
*/
-typedef struct ECL {
- int srcOffset; /* Command location to find the entry. */
- int nline; /* Number of words in the command */
- int *line; /* Line information for all words in the
+typedef struct {
+ Tcl_Size srcOffset; /* Command location to find the entry. */
+ Tcl_Size nline; /* Number of words in the command */
+ Tcl_Size *line; /* Line information for all words in the
* command. */
- int **next; /* Transient information used by the compiler
+ Tcl_Size **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
-typedef struct ExtCmdLoc {
+typedef struct {
int type; /* Context type. */
- int start; /* Starting line for compiled script. Needed
+ Tcl_Size 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). */
- int nloc; /* Number of allocated entries in 'loc'. */
- int nuloc; /* Number of used entries in 'loc'. */
+ Tcl_Size nloc; /* Number of allocated entries in 'loc'. */
+ Tcl_Size nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
@@ -217,11 +217,11 @@ typedef struct ExtCmdLoc {
* the AuxData structure.
*/
-typedef ClientData (AuxDataDupProc) (ClientData clientData);
-typedef void (AuxDataFreeProc) (ClientData clientData);
-typedef void (AuxDataPrintProc)(ClientData clientData,
+typedef void *(AuxDataDupProc) (void *clientData);
+typedef void (AuxDataFreeProc) (void *clientData);
+typedef void (AuxDataPrintProc)(void *clientData,
Tcl_Obj *appendObj, struct ByteCode *codePtr,
- unsigned int pcOffset);
+ TCL_HASH_TYPE pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
@@ -266,7 +266,7 @@ typedef struct AuxDataType {
typedef struct AuxData {
const AuxDataType *type; /* Pointer to the AuxData type associated with
* this ClientData. */
- ClientData clientData; /* The compilation data itself. */
+ void *clientData; /* The compilation data itself. */
} AuxData;
/*
@@ -290,21 +290,21 @@ typedef struct CompileEnv {
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
- int numSrcBytes; /* Number of bytes in source. */
+ Tcl_Size 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. */
- int numCommands; /* Number of commands compiled. */
- int exceptDepth; /* Current exception range nesting level; -1
+ Tcl_Size numCommands; /* Number of commands compiled. */
+ Tcl_Size exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE
* if not in any range currently. */
- int maxExceptDepth; /* Max nesting level of exception ranges; -1
+ Tcl_Size maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE
* if no ranges have been compiled. */
- int maxStackDepth; /* Maximum number of stack elements needed to
+ Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to
* execute the code. Set by compilation
* procedures before returning. */
- int currStackDepth; /* Current stack depth. */
+ Tcl_Size currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl
* objects referenced by this compiled code.
* Indexed by the string representations of
@@ -318,18 +318,18 @@ typedef struct CompileEnv {
* codeStart points into the heap.*/
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
- int literalArrayNext; /* Index of next free object array entry. */
- int literalArrayEnd; /* Index just after last obj array entry. */
+ Tcl_Size literalArrayNext; /* Index of next free object array entry. */
+ Tcl_Size 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. */
- int exceptArrayNext; /* Next free ExceptionRange array index.
+ Tcl_Size 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. */
- int exceptArrayEnd; /* Index after the last ExceptionRange array
+ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
@@ -342,15 +342,15 @@ typedef struct CompileEnv {
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
* for the last command. */
- int cmdMapEnd; /* Index after last CmdLocation entry. */
+ Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
- int auxDataArrayNext; /* Next free compile aux data array index.
+ Tcl_Size 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. */
- int auxDataArrayEnd; /* Index after last aux data array entry. */
+ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
@@ -369,7 +369,7 @@ typedef struct CompileEnv {
/* TIP #280 */
ExtCmdLoc *extCmdMapPtr; /* Extended command location information for
* 'info frame'. */
- int line; /* First line of the script, based on the
+ Tcl_Size 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
@@ -378,11 +378,11 @@ typedef struct CompileEnv {
* inefficient. If set to 2, that instruction
* should not be issued at all (by the generic
* part of the command compiler). */
- int expandCount; /* Number of INST_EXPAND_START instructions
+ Tcl_Size 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
+ Tcl_Size *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
} CompileEnv;
@@ -417,7 +417,7 @@ typedef struct ByteCode {
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
- int compileEpoch; /* Value of iPtr->compileEpoch when this
+ Tcl_Size compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
@@ -425,11 +425,11 @@ typedef struct ByteCode {
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
- int nsEpoch; /* Value of nsPtr->resolverEpoch when this
+ Tcl_Size nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
- int refCount; /* Reference count: set 1 when created plus 1
+ Tcl_Size refCount; /* Reference count: set 1 when created plus 1
* for each execution of the code currently
* active. This structure can be freed when
* refCount becomes zero. */
@@ -449,17 +449,17 @@ typedef struct ByteCode {
* itself. Does not include heap space for
* literal Tcl objects or storage referenced
* by AuxData entries. */
- int numCommands; /* Number of commands compiled. */
- int numSrcBytes; /* Number of source bytes compiled. */
- int numCodeBytes; /* Number of code bytes. */
- int numLitObjects; /* Number of objects in literal array. */
- int numExceptRanges; /* Number of ExceptionRange array elems. */
- int numAuxDataItems; /* Number of AuxData items. */
- int numCmdLocBytes; /* Number of bytes needed for encoded command
+ Tcl_Size numCommands; /* Number of commands compiled. */
+ Tcl_Size numSrcBytes; /* Number of source bytes compiled. */
+ Tcl_Size numCodeBytes; /* Number of code bytes. */
+ Tcl_Size numLitObjects; /* Number of objects in literal array. */
+ Tcl_Size numExceptRanges; /* Number of ExceptionRange array elems. */
+ Tcl_Size numAuxDataItems; /* Number of AuxData items. */
+ Tcl_Size numCmdLocBytes; /* Number of bytes needed for encoded command
* location information. */
- int maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
- * -1 if no ranges were compiled. */
- int maxStackDepth; /* Maximum number of stack elements needed to
+ Tcl_Size maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
+ * TCL_INDEX_NONE if no ranges were compiled. */
+ Tcl_Size 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
@@ -514,12 +514,29 @@ typedef struct ByteCode {
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
+
+#define ByteCodeSetInternalRep(objPtr, typePtr, codePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (codePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), (typePtr), &ir); \
+ } while (0)
+
+
+
+#define ByteCodeGetInternalRep(objPtr, typePtr, codePtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), (typePtr)); \
+ (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
- * INST_LOR) must match the entries in the array operatorStrings in
+ * INST_BITOR) must match the entries in the array operatorStrings in
* tclExecute.c.
*/
@@ -823,8 +840,18 @@ typedef struct ByteCode {
#define INST_CLOCK_READ 189
+#define INST_DICT_GET_DEF 190
+
+/* TIP 461 */
+#define INST_STR_LT 191
+#define INST_STR_GT 192
+#define INST_STR_LE 193
+#define INST_STR_GE 194
+
+#define INST_LREPLACE4 195
+
/* The last opcode */
-#define LAST_INST_OPCODE 189
+#define LAST_INST_OPCODE 195
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -862,7 +889,7 @@ typedef enum InstOperandType {
typedef struct InstructionDesc {
const char *name; /* Name of instruction. */
- int numBytes; /* Total number of bytes for instruction. */
+ Tcl_Size numBytes; /* Total number of bytes for instruction. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
* computations. The value INT_MIN signals
@@ -897,12 +924,13 @@ typedef enum InstStringClassType {
STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
- STR_CLASS_XDIGIT /* Characters that can be used as digits in
+ STR_CLASS_XDIGIT, /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
+ STR_CLASS_UNICODE /* Unicode characters. */
} InstStringClassType;
typedef struct StringClassDesc {
- const char *name; /* Name of the class. */
+ char name[8]; /* Name of the class. */
int (*comparator)(int); /* Function to test if a single unicode
* character is a member of the class. */
} StringClassDesc;
@@ -949,8 +977,8 @@ typedef struct JumpFixup {
typedef struct JumpFixupArray {
JumpFixup *fixup; /* Points to start of jump fixup array. */
- int next; /* Index of next free array entry. */
- int end; /* Index of last usable entry in array. */
+ Tcl_Size next; /* Index of next free array entry. */
+ Tcl_Size 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];
@@ -965,8 +993,8 @@ typedef struct JumpFixupArray {
*/
typedef struct ForeachVarList {
- int numVars; /* The number of variables in the list. */
- int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers")
+ Tcl_Size numVars; /* The number of variables in the list. */
+ Tcl_Size 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
@@ -982,11 +1010,11 @@ typedef struct ForeachVarList {
*/
typedef struct ForeachInfo {
- int numLists; /* The number of both the variable and value
+ Tcl_Size numLists; /* The number of both the variable and value
* lists of the foreach command. */
- int firstValueTemp; /* Index of the first temp var in a proc frame
+ Tcl_Size firstValueTemp; /* Index of the first temp var in a proc frame
* used to point to a value list. */
- int loopCtTemp; /* Index of temp var in a proc frame holding
+ Tcl_Size loopCtTemp; /* Index of temp var in a proc frame holding
* the loop's iteration count. Used to
* determine next value list element to assign
* each loop var. */
@@ -1020,8 +1048,8 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType;
*/
typedef struct {
- int length; /* Size of array */
- int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when
+ Tcl_Size length; /* Size of array */
+ Tcl_Size 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
@@ -1067,16 +1095,15 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
*/
MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
+ Tcl_Parse *parsePtr, Tcl_Size depth, Command *cmdPtr,
CompileEnv *envPtr);
-MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
- int numBytes, CompileEnv *envPtr, int optimize);
+ Tcl_Size numBytes, CompileEnv *envPtr, int optimize);
MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr);
@@ -1084,7 +1111,7 @@ MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp,
Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp,
- const char *script, int numBytes,
+ const char *script, Tcl_Size numBytes,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp,
CompileEnv *envPtr);
@@ -1093,13 +1120,13 @@ MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp,
Tcl_Token *tokenPtr, CompileEnv *envPtr);
-MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
+MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData,
const AuxDataType *typePtr, CompileEnv *envPtr);
-MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
+MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
-MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
-MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
- int length, unsigned int hash, int *newPtr,
+MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, TCL_HASH_TYPE size);
+MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
+ Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
@@ -1113,8 +1140,8 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
-MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
-MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
+MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index);
+MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
JumpFixup *jumpFixupPtr, int jumpDist,
@@ -1123,11 +1150,12 @@ MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr,
int before, int after, int *indexPtr);
-MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
- CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr);
+MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr,
+ const Tcl_ObjType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
- int numBytes, const CmdFrame *invoker, int word);
+ TCL_HASH_TYPE numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
@@ -1142,9 +1170,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr);
MODULE_SCOPE int TclLog2(int value);
#endif
-MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes,
+MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, TCL_HASH_TYPE numBytes,
CompileEnv *envPtr);
-MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr,
+MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr,
CompileEnv *envPtr);
MODULE_SCOPE void TclOptimizeBytecode(void *envPtr);
#ifdef TCL_COMPILE_DEBUG
@@ -1154,39 +1182,22 @@ MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp,
MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr,
const unsigned char *pc);
MODULE_SCOPE void TclPrintObject(FILE *outFile,
- Tcl_Obj *objPtr, int maxChars);
+ Tcl_Obj *objPtr, Tcl_Size maxChars);
MODULE_SCOPE void TclPrintSource(FILE *outFile,
- const char *string, int maxChars);
+ const char *string, Tcl_Size maxChars);
MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr);
-
-static inline void
-TclPreserveByteCode(
- ByteCode *codePtr)
-{
- codePtr->refCount++;
-}
-
-static inline void
-TclReleaseByteCode(
- ByteCode *codePtr)
-{
- if (codePtr->refCount-- > 1) {
- return;
- }
- /* Just dropped to refcount==0. Clean up. */
- TclCleanupByteCode(codePtr);
-}
-
+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;
+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);
@@ -1195,15 +1206,14 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
const char *script, const char *command,
- int length, const unsigned char *pc,
+ Tcl_Size 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(ClientData clientData,
- Tcl_Interp *interp, int objc,
+MODULE_SCOPE int TclPushProcCallFrame(void *clientData,
+ Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int isLambda);
-
/*
*----------------------------------------------------------------
@@ -1215,7 +1225,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
/*
* Simplified form to access AuxData.
*
- * ClientData TclFetchAuxData(CompileEng *envPtr, int index);
+ * void *TclFetchAuxData(CompileEng *envPtr, int index);
*/
#define TclFetchAuxData(envPtr, index) \
@@ -1226,29 +1236,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_UNSHARED 0x04
/*
- * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
- * cast away constness, and it is cleanest to do that here, all in one place.
- *
- * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes,
- * int length);
- */
-
-#define TclRegisterNewLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0)
-
-/*
- * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it
- * is safe to cast away constness, and it is cleanest to do that here, all in
- * one place.
- *
- * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes,
- * int length);
- */
-
-#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
-
-/*
* Macro used to manually adjust the stack requirements; used in cases where
* the stack effect cannot be computed from the opcode and its operands, but
* is still known at compile time.
@@ -1274,10 +1261,10 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define TclCheckStackDepth(depth, envPtr) \
do { \
- int _dd = (depth); \
- if (_dd != (envPtr)->currStackDepth) { \
- Tcl_Panic("bad stack depth computations: is %i, should be %i", \
- (envPtr)->currStackDepth, _dd); \
+ size_t _dd = (depth); \
+ if (_dd != (size_t)(envPtr)->currStackDepth) { \
+ Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \
+ (size_t)(envPtr)->currStackDepth, _dd); \
} \
} while (0)
@@ -1519,7 +1506,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
(*((p)+3))))
/*
- * Macros used to compute the minimum and maximum of two integers. The ANSI C
+ * Macros used to compute the minimum and maximum of two values. The ANSI C
* "prototypes" for these macros are:
*
* int TclMin(int i, int j);
@@ -1557,15 +1544,15 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* these macros are:
*
* static void PushLiteral(CompileEnv *envPtr,
- * const char *string, int length);
+ * const char *string, Tcl_Size length);
* static void PushStringLiteral(CompileEnv *envPtr,
* const char *string);
*/
#define PushLiteral(envPtr, string, length) \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+ TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr))
#define PushStringLiteral(envPtr, string) \
- PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
+ PushLiteral((envPtr), (string), sizeof(string "") - 1)
/*
* Macro to advance to the next token; it is more mnemonic than the address
@@ -1581,7 +1568,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* Macro to get the offset to the next instruction to be issued. The ANSI C
* "prototype" for this macro is:
*
- * static int CurrentOffset(CompileEnv *envPtr);
+ * static ptrdiff_t CurrentOffset(CompileEnv *envPtr);
*/
#define CurrentOffset(envPtr) \
@@ -1594,9 +1581,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* of LOOP ranges is an interesting datum for debugging purposes, and that is
* what we compute now.
*
- * static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
- * static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
- * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
+ * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index);
+ * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index);
+ * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL);
*/
#define ExceptionRangeStarts(envPtr, index) \
@@ -1655,7 +1642,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
+ Tcl_Size eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
@@ -1697,6 +1684,12 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
/*
+ * Flags bits used by lreplace4 instruction
+ */
+#define TCL_LREPLACE4_END_IS_LAST 1 /* "end" refers to last element */
+#define TCL_LREPLACE4_SINGLE_INDEX 2 /* Second index absent (pure insert) */
+
+/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
@@ -1833,8 +1826,8 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi);
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { \
char n[35]; \
- snprintf(n, sizeof(n), "/tmp/tclDTraceDebug-%lu.log", \
- (unsigned long) getpid()); \
+ snprintf(n, sizeof(n), "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \
+ (size_t) getpid()); \
tclDTraceDebugLog = fopen(n, "a"); \
}
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index a1a53bc..28853a1 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -4,7 +4,7 @@
* This file provides the facilities which allow Tcl and other packages
* to embed configuration information into their binary libraries.
*
- * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -41,11 +41,10 @@ typedef struct QCCD {
* Static functions in this file:
*/
-static Tcl_ObjCmdProc QueryConfigObjCmd;
-static void QueryConfigDelete(ClientData clientData);
+static Tcl_ObjCmdProc QueryConfigObjCmd;
+static Tcl_CmdDeleteProc QueryConfigDelete;
+static Tcl_InterpDeleteProc ConfigDictDeleteProc;
static Tcl_Obj * GetConfigDict(Tcl_Interp *interp);
-static void ConfigDictDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -179,7 +178,7 @@ Tcl_RegisterConfig(
* QueryConfigObjCmd --
*
* Implementation of "::<package>::pkgconfig", the command to query
- * configuration information embedded into a binary library.
+ * configuration information embedded into a library.
*
* Results:
* A standard Tcl result.
@@ -230,7 +229,7 @@ QueryConfigObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
- Tcl_GetString(pkgName), NULL);
+ TclGetString(pkgName), (void *)NULL);
return TCL_ERROR;
}
@@ -245,7 +244,7 @@ QueryConfigObjCmd(
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
- Tcl_GetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -278,7 +277,7 @@ QueryConfigObjCmd(
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
return TCL_ERROR;
}
@@ -331,9 +330,9 @@ QueryConfigDelete(
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
- ckfree((char *)cdPtr->encoding);
+ ckfree(cdPtr->encoding);
}
- ckfree((char *)cdPtr);
+ ckfree(cdPtr);
}
/*
@@ -390,11 +389,9 @@ GetConfigDict(
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ TCL_UNUSED(Tcl_Interp *))
{
- Tcl_Obj *pDB = (Tcl_Obj *)clientData;
-
- Tcl_DecrRefCount(pDB);
+ Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
diff --git a/generic/tclDate.c b/generic/tclDate.c
index fa27475..2f05753 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -351,7 +351,6 @@ typedef short yytype_int16;
# elif defined size_t
# define YYSIZE_T size_t
# elif ! defined YYSIZE_T
-# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# define YYSIZE_T size_t
# else
# define YYSIZE_T unsigned
@@ -2738,7 +2737,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
@@ -2748,7 +2747,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2756,7 +2754,7 @@ TclClockOldscanObjCmd(
return TCL_ERROR;
}
- yyInput = Tcl_GetString( objv[1] );
+ yyInput = TclGetString( objv[1] );
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
@@ -2790,12 +2788,12 @@ TclClockOldscanObjCmd(
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (void *)NULL);
return TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_DecrRefCount(dateInfo.messages);
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
return TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
@@ -2803,7 +2801,7 @@ TclClockOldscanObjCmd(
"report this error as a "
"bug in Tcl.", -1));
Tcl_DecrRefCount(dateInfo.messages);
- Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "BUG", (void *)NULL);
return TCL_ERROR;
}
Tcl_DecrRefCount(dateInfo.messages);
@@ -2811,31 +2809,31 @@ TclClockOldscanObjCmd(
if (yyHaveDate > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one date in string", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL);
return TCL_ERROR;
}
if (yyHaveTime > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time of day in string", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL);
return TCL_ERROR;
}
if (yyHaveZone > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time zone in string", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL);
return TCL_ERROR;
}
if (yyHaveDay > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one weekday in string", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL);
return TCL_ERROR;
}
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (void *)NULL);
return TCL_ERROR;
}
@@ -2855,7 +2853,8 @@ TclClockOldscanObjCmd(
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int)
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
- Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
+ TclNewObj(resultElement);
+ Tcl_ListObjAppendElement(interp, result, resultElement);
}
TclNewObj(resultElement);
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index a91f718..5768233 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -12,6 +12,12 @@
#ifndef _TCLDECLS
#define _TCLDECLS
+#include <stddef.h> /* for size_t */
+
+#ifdef TCL_NO_DEPRECATED
+# define Tcl_SavedResult void
+#endif /* TCL_NO_DEPRECATED */
+
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
@@ -23,6 +29,15 @@
# endif
#endif
+#if !defined(BUILD_tcl)
+# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg)
+#elif defined(TCL_NO_DEPRECATED)
+# define TCL_DEPRECATED(msg) MODULE_SCOPE
+#else
+# define TCL_DEPRECATED(msg) EXTERN
+#endif
+
+
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
* script. Any modifications to the function declarations below should be made
@@ -44,34 +59,34 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp,
const char *name, const char *version,
const void *clientData);
/* 1 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp,
+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 char * Tcl_Alloc(unsigned int size);
+EXTERN char * Tcl_Alloc(TCL_HASH_TYPE size);
/* 4 */
EXTERN void Tcl_Free(char *ptr);
/* 5 */
-EXTERN char * Tcl_Realloc(char *ptr, unsigned int size);
+EXTERN char * Tcl_Realloc(char *ptr, TCL_HASH_TYPE size);
/* 6 */
-EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file,
+EXTERN char * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file,
int line);
/* 7 */
EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line);
/* 8 */
-EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size,
+EXTERN char * Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line);
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
- Tcl_FileProc *proc, ClientData clientData);
+ Tcl_FileProc *proc, void *clientData);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 9 */
EXTERN void Tcl_CreateFileHandler(int fd, int mask,
- Tcl_FileProc *proc, ClientData clientData);
+ Tcl_FileProc *proc, void *clientData);
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
/* 10 */
@@ -94,9 +109,9 @@ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp,
EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...);
/* 16 */
EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes,
- int length);
+ Tcl_Size length);
/* 17 */
-EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]);
+EXTERN Tcl_Obj * Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[]);
/* 18 */
EXTERN int Tcl_ConvertToType(Tcl_Interp *interp,
Tcl_Obj *objPtr, const Tcl_ObjType *typePtr);
@@ -110,25 +125,28 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
/* 22 */
-EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file,
int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
- int length, const char *file, int line);
+ Tcl_Size 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(int objc, Tcl_Obj *const *objv,
+EXTERN Tcl_Obj * Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line);
/* 26 */
-EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
int line);
/* 27 */
EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line);
/* 28 */
-EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length,
- const char *file, int line);
+EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes,
+ Tcl_Size length, const char *file, int line);
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr);
/* 30 */
@@ -141,7 +159,7 @@ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *intPtr);
/* 33 */
EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
- int *numBytesPtr);
+ Tcl_Size *numBytesPtr);
/* 34 */
EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
double *doublePtr);
@@ -149,9 +167,9 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
-EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GetIndexFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
@@ -180,59 +198,70 @@ EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp,
Tcl_Obj ***objvPtr);
/* 46 */
EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp,
- Tcl_Obj *listPtr, int index,
+ Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr);
/* 47 */
EXTERN int Tcl_ListObjLength(Tcl_Interp *interp,
Tcl_Obj *listPtr, int *lengthPtr);
/* 48 */
EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
- Tcl_Obj *listPtr, int first, int count,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Obj *listPtr, Tcl_Size first,
+ Tcl_Size count, Tcl_Size objc,
+ Tcl_Obj *const objv[]);
/* 49 */
-EXTERN Tcl_Obj * Tcl_NewBooleanObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewBooleanObj(int intValue);
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
- int numBytes);
+ Tcl_Size numBytes);
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue);
/* 52 */
-EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewIntObj(int intValue);
/* 53 */
-EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
+EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]);
/* 54 */
-EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+Tcl_Obj * Tcl_NewLongObj(long longValue);
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj(void);
/* 56 */
-EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length);
+EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length);
/* 57 */
-EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue);
/* 58 */
-EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes);
+EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr,
+ Tcl_Size numBytes);
/* 59 */
EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
- const unsigned char *bytes, int numBytes);
+ const unsigned char *bytes,
+ Tcl_Size numBytes);
/* 60 */
EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
/* 61 */
-EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
/* 62 */
-EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
+EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 63 */
-EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
/* 64 */
-EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
+EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length);
/* 65 */
EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
- int length);
+ Tcl_Size length);
/* 66 */
-EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddErrorInfo(Tcl_Interp *interp,
const char *message);
/* 67 */
-EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
- const char *message, int length);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
+ const char *message, Tcl_Size length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
/* 69 */
@@ -242,7 +271,7 @@ EXTERN void Tcl_AppendElement(Tcl_Interp *interp,
EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...);
/* 71 */
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
- ClientData clientData);
+ void *clientData);
/* 72 */
EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async);
/* 73 */
@@ -252,95 +281,96 @@ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async);
/* 75 */
EXTERN int Tcl_AsyncReady(void);
/* 76 */
-EXTERN void Tcl_BackgroundError(Tcl_Interp *interp);
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_BackgroundError(Tcl_Interp *interp);
/* 77 */
-EXTERN char Tcl_Backslash(const char *src, int *readPtr);
+TCL_DEPRECATED("Use Tcl_UtfBackslash")
+char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
const char *optionName,
const char *optionList);
/* 79 */
EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp,
- Tcl_InterpDeleteProc *proc,
- ClientData clientData);
+ Tcl_InterpDeleteProc *proc, void *clientData);
/* 80 */
EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc,
- ClientData clientData);
+ 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(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Concat(Tcl_Size argc, const char *const *argv);
/* 84 */
-EXTERN int Tcl_ConvertElement(const char *src, char *dst,
+EXTERN Tcl_Size Tcl_ConvertElement(const char *src, char *dst,
int flags);
/* 85 */
-EXTERN int Tcl_ConvertCountedElement(const char *src,
- int length, char *dst, int flags);
+EXTERN Tcl_Size Tcl_ConvertCountedElement(const char *src,
+ Tcl_Size length, char *dst, int flags);
/* 86 */
EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp,
const char *childCmd, Tcl_Interp *target,
- const char *targetCmd, int argc,
- CONST84 char *const *argv);
+ const char *targetCmd, Tcl_Size argc,
+ const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp,
const char *childCmd, Tcl_Interp *target,
- const char *targetCmd, int objc,
+ const char *targetCmd, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 88 */
EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr,
- const char *chanName,
- ClientData instanceData, int mask);
+ const char *chanName, void *instanceData,
+ int mask);
/* 89 */
EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
- Tcl_ChannelProc *proc, ClientData clientData);
+ Tcl_ChannelProc *proc, void *clientData);
/* 90 */
EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan,
- Tcl_CloseProc *proc, ClientData clientData);
+ Tcl_CloseProc *proc, void *clientData);
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdProc *proc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 92 */
EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
- ClientData clientData);
+ void *clientData);
/* 93 */
EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
/* 95 */
-EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+void Tcl_CreateMathFunc(Tcl_Interp *interp,
const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
- ClientData clientData);
+ void *clientData);
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 97 */
-EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, const char *name,
+EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name,
int isSafe);
/* 98 */
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
- Tcl_TimerProc *proc, ClientData clientData);
+ Tcl_TimerProc *proc, void *clientData);
/* 99 */
-EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
- Tcl_CmdTraceProc *proc,
- ClientData clientData);
+EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level,
+ Tcl_CmdTraceProc *proc, void *clientData);
/* 100 */
EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp,
const char *name);
/* 101 */
EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan,
- Tcl_ChannelProc *proc, ClientData clientData);
+ Tcl_ChannelProc *proc, void *clientData);
/* 102 */
EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan,
- Tcl_CloseProc *proc, ClientData clientData);
+ Tcl_CloseProc *proc, void *clientData);
/* 103 */
EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp,
const char *cmdName);
@@ -349,14 +379,14 @@ EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp,
Tcl_Command command);
/* 105 */
EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc,
- ClientData clientData);
+ void *clientData);
/* 106 */
EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
- ClientData clientData);
+ void *clientData);
/* 107 */
EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 108 */
EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr);
/* 109 */
@@ -364,23 +394,21 @@ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr);
/* 110 */
EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp);
/* 111 */
-EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr);
+EXTERN void Tcl_DetachPids(Tcl_Size 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,
- ClientData clientData);
+ Tcl_InterpDeleteProc *proc, void *clientData);
/* 115 */
EXTERN int Tcl_DoOneEvent(int flags);
/* 116 */
-EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc,
- ClientData clientData);
+EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData);
/* 117 */
EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr,
- const char *bytes, int length);
+ const char *bytes, Tcl_Size length);
/* 118 */
EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr,
const char *element);
@@ -397,24 +425,26 @@ EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr);
EXTERN void Tcl_DStringResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
/* 124 */
-EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length);
+EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr,
+ Tcl_Size length);
/* 125 */
EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
/* 127 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoId(void);
+EXTERN const char * Tcl_ErrnoId(void);
/* 128 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err);
+EXTERN const char * Tcl_ErrnoMsg(int err);
/* 129 */
EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
EXTERN int Tcl_EvalFile(Tcl_Interp *interp,
const char *fileName);
/* 131 */
-EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/* 132 */
-EXTERN void Tcl_EventuallyFree(ClientData clientData,
+EXTERN void Tcl_EventuallyFree(void *clientData,
Tcl_FreeProc *freeProc);
/* 133 */
EXTERN TCL_NORETURN void Tcl_Exit(int status);
@@ -448,44 +478,45 @@ EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr);
/* 143 */
EXTERN void Tcl_Finalize(void);
/* 144 */
-EXTERN void Tcl_FindExecutable(const char *argv0);
+EXTERN const char * Tcl_FindExecutable(const char *argv0);
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr);
/* 146 */
EXTERN int Tcl_Flush(Tcl_Channel chan);
/* 147 */
-EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
+TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult")
+void Tcl_FreeResult(Tcl_Interp *interp);
/* 148 */
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char **targetCmdPtr, int *argcPtr,
+ const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *childCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *objcPtr,
+ const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
-EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
+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 int Tcl_GetChannelBufferSize(Tcl_Channel chan);
+EXTERN Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan);
/* 153 */
EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
- ClientData *handlePtr);
+ void **handlePtr);
/* 154 */
-EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
+EXTERN void * Tcl_GetChannelInstanceData(Tcl_Channel chan);
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
/* 156 */
-EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan);
+EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan);
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -496,17 +527,17 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
-EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
+EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
/* 161 */
EXTERN int Tcl_GetErrno(void);
/* 162 */
-EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
+EXTERN const char * Tcl_GetHostName(void);
/* 163 */
EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp,
Tcl_Interp *childInterp);
/* 164 */
-EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp);
+EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp);
/* 165 */
EXTERN const char * Tcl_GetNameOfExecutable(void);
/* 166 */
@@ -515,40 +546,41 @@ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp);
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr);
+ int checkUsage, void **filePtr);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
- int checkUsage, ClientData *filePtr);
+ int checkUsage, void **filePtr);
#endif /* MACOSX */
/* 168 */
EXTERN Tcl_PathType Tcl_GetPathType(const char *path);
/* 169 */
-EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
+EXTERN Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr);
/* 170 */
-EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 171 */
EXTERN int Tcl_GetServiceMode(void);
/* 172 */
-EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *name);
+EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name);
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
-EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp);
+EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
-EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp,
- const char *varName, int flags);
-/* 176 */
-EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags);
+/* 176 */
+EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
/* 178 */
-EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_GlobalEvalObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 179 */
EXTERN int Tcl_HideCommand(Tcl_Interp *interp,
@@ -568,20 +600,21 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp);
/* 185 */
EXTERN int Tcl_IsSafe(Tcl_Interp *interp);
/* 186 */
-EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv,
+EXTERN char * Tcl_JoinPath(Tcl_Size argc, const char *const *argv,
Tcl_DString *resultPtr);
/* 187 */
EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
- char *addr, int type);
+ void *addr, int type);
/* Slot 188 is reserved */
/* 189 */
-EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode);
+EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode);
/* 190 */
-EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
+TCL_DEPRECATED("")
+int Tcl_MakeSafe(Tcl_Interp *interp);
/* 191 */
-EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
+EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket);
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Merge(Tcl_Size argc, const char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
/* 194 */
@@ -594,8 +627,8 @@ 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, int argc,
- CONST84 char **argv, int flags);
+EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp,
+ Tcl_Size argc, const char **argv, int flags);
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
const char *fileName, const char *modeString,
@@ -608,21 +641,21 @@ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host,
Tcl_TcpAcceptProc *acceptProc,
- ClientData callbackData);
+ void *callbackData);
/* 201 */
-EXTERN void Tcl_Preserve(ClientData data);
+EXTERN void Tcl_Preserve(void *data);
/* 202 */
EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
char *dst);
/* 203 */
EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
-EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp);
+EXTERN const char * Tcl_PosixError(Tcl_Interp *interp);
/* 205 */
-EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr,
- Tcl_QueuePosition position);
+EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position);
/* 206 */
-EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead);
+EXTERN Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr,
+ Tcl_Size toRead);
/* 207 */
EXTERN void Tcl_ReapDetachedProcs(void);
/* 208 */
@@ -646,20 +679,20 @@ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern);
/* 215 */
-EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr,
- CONST84 char **endPtr);
+EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index,
+ const char **startPtr, const char **endPtr);
/* 216 */
-EXTERN void Tcl_Release(ClientData clientData);
+EXTERN void Tcl_Release(void *clientData);
/* 217 */
EXTERN void Tcl_ResetResult(Tcl_Interp *interp);
/* 218 */
-EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
+EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr);
/* 219 */
-EXTERN int Tcl_ScanCountedElement(const char *src, int length,
- int *flagPtr);
+EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src,
+ Tcl_Size length, int *flagPtr);
/* 220 */
-EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
+TCL_DEPRECATED("")
+int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
/* 221 */
EXTERN int Tcl_ServiceAll(void);
/* 222 */
@@ -667,9 +700,10 @@ EXTERN int Tcl_ServiceEvent(int flags);
/* 223 */
EXTERN void Tcl_SetAssocData(Tcl_Interp *interp,
const char *name, Tcl_InterpDeleteProc *proc,
- ClientData clientData);
+ void *clientData);
/* 224 */
-EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz);
+EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan,
+ Tcl_Size sz);
/* 225 */
EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -685,10 +719,11 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...);
/* 229 */
EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr);
/* 230 */
-EXTERN void Tcl_SetPanicProc(
+EXTERN const char * Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
/* 231 */
-EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
+EXTERN Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp,
+ Tcl_Size depth);
/* 232 */
EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc);
@@ -703,50 +738,52 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
-EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp,
- const char *varName, const char *newValue,
- int flags);
-/* 238 */
-EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
+/* 238 */
+EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, const char *newValue,
+ int flags);
/* 239 */
-EXTERN CONST84_RETURN char * Tcl_SignalId(int sig);
+EXTERN const char * Tcl_SignalId(int sig);
/* 240 */
-EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig);
+EXTERN const char * Tcl_SignalMsg(int sig);
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 243 */
EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 244 */
-EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
+EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
- Tcl_PackageInitProc *initProc,
- Tcl_PackageInitProc *safeInitProc);
+ Tcl_LibraryInitProc *initProc,
+ Tcl_LibraryInitProc *safeInitProc);
/* 245 */
-EXTERN int Tcl_StringMatch(const char *str, const char *pattern);
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
-EXTERN int Tcl_TellOld(Tcl_Channel chan);
+TCL_DEPRECATED("")
+int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
-EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
- ClientData clientData);
+ void *clientData);
/* 248 */
EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags,
- Tcl_VarTraceProc *proc,
- ClientData clientData);
+ Tcl_VarTraceProc *proc, void *clientData);
/* 249 */
EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp,
const char *name, Tcl_DString *bufferPtr);
/* 250 */
-EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str,
- int len, int atHead);
+EXTERN Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str,
+ Tcl_Size len, int atHead);
/* 251 */
EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
const char *varName);
@@ -754,26 +791,28 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
/* 253 */
-EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
int flags);
/* 254 */
EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 255 */
-EXTERN void Tcl_UntraceVar(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void Tcl_UntraceVar(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_VarTraceProc *proc,
- ClientData clientData);
+ Tcl_VarTraceProc *proc, void *clientData);
/* 256 */
EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc,
- ClientData clientData);
+ void *clientData);
/* 257 */
EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp,
const char *varName);
/* 258 */
-EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName,
int flags);
/* 259 */
@@ -783,59 +822,67 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
/* 260 */
EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...);
/* 261 */
-EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("No longer in use, changed to macro")
+void * Tcl_VarTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 262 */
-EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp,
+EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 263 */
-EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen);
+EXTERN Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s,
+ Tcl_Size slen);
/* 264 */
-EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
+EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size 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);
/* 267 */
-EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
/* 268 */
-EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
-EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
- const char *start, CONST84 char **termPtr);
+EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr);
/* 271 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 272 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
-EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("No longer in use, changed to macro")
+int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version);
/* 274 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+TCL_DEPRECATED("No longer in use, changed to macro")
+const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 275 */
-EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
+TCL_DEPRECATED("see TIP #422")
+void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
/* 276 */
-EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
/* 278 */
-EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
+TCL_DEPRECATED("see TIP #422")
+TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
@@ -844,7 +891,7 @@ EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
/* 281 */
EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
const Tcl_ChannelType *typePtr,
- ClientData instanceData, int mask,
+ void *instanceData, int mask,
Tcl_Channel prevChan);
/* 282 */
EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp,
@@ -861,38 +908,39 @@ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr,
EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr);
/* 288 */
EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 289 */
EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ void *clientData);
/* 290 */
-EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
+TCL_DEPRECATED("Use Tcl_DiscardInterpState")
+void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
/* 291 */
EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script,
- int numBytes, int flags);
+ Tcl_Size numBytes, int flags);
/* 292 */
-EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
+EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags);
/* 293 */
EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
/* 294 */
-EXTERN void Tcl_ExitThread(int status);
+EXTERN TCL_NORETURN void Tcl_ExitThread(int status);
/* 295 */
EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
- int srcLen, int flags,
+ Tcl_Size srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr,
+ Tcl_Size dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 296 */
EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
- const char *src, int srcLen,
+ const char *src, Tcl_Size srcLen,
Tcl_DString *dsPtr);
/* 297 */
EXTERN void Tcl_FinalizeThread(void);
/* 298 */
-EXTERN void Tcl_FinalizeNotifier(ClientData clientData);
+EXTERN void Tcl_FinalizeNotifier(void *clientData);
/* 299 */
EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding);
/* 300 */
@@ -900,22 +948,22 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
-EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding);
+EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp,
Tcl_Obj *objPtr, const void *tablePtr,
- int offset, const char *msg, int flags,
- int *indexPtr);
+ Tcl_Size offset, const char *msg, int flags,
+ void *indexPtr);
/* 305 */
EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
- int size);
+ Tcl_Size size);
/* 306 */
EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 307 */
-EXTERN ClientData Tcl_InitNotifier(void);
+EXTERN void * Tcl_InitNotifier(void);
/* 308 */
EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr);
/* 309 */
@@ -926,15 +974,17 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr);
EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr,
Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr);
/* 312 */
-EXTERN int Tcl_NumUtfChars(const char *src, int length);
+EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length);
/* 313 */
-EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
- int charsToRead, int appendFlag);
+EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
+ Tcl_Size charsToRead, int appendFlag);
/* 314 */
-EXTERN void Tcl_RestoreResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_RestoreInterpState")
+void Tcl_RestoreResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 315 */
-EXTERN void Tcl_SaveResult(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_SaveInterpState")
+void Tcl_SaveResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 316 */
EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp,
@@ -947,64 +997,67 @@ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
/* 319 */
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
- Tcl_Event *evPtr, Tcl_QueuePosition position);
+ Tcl_Event *evPtr, int position);
/* 320 */
-EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int Tcl_UniCharAtIndex(const char *src, Tcl_Size index);
/* 321 */
-EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch);
+EXTERN int Tcl_UniCharToLower(int ch);
/* 322 */
-EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch);
+EXTERN int Tcl_UniCharToTitle(int ch);
/* 323 */
-EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
+EXTERN int Tcl_UniCharToUpper(int ch);
/* 324 */
-EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
+EXTERN Tcl_Size Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
+EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index);
/* 326 */
-EXTERN int Tcl_UtfCharComplete(const char *src, int length);
+EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length);
/* 327 */
-EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
+EXTERN Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
/* 328 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
-EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src);
+EXTERN const char * TclUtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
+EXTERN const char * TclUtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
- int srcLen, int flags,
+ Tcl_Size srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr,
+ Tcl_Size dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 333 */
EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding,
- const char *src, int srcLen,
+ const char *src, Tcl_Size srcLen,
Tcl_DString *dsPtr);
/* 334 */
-EXTERN int Tcl_UtfToLower(char *src);
+EXTERN Tcl_Size Tcl_UtfToLower(char *src);
/* 335 */
-EXTERN int Tcl_UtfToTitle(char *src);
+EXTERN Tcl_Size Tcl_UtfToTitle(char *src);
/* 336 */
-EXTERN int Tcl_UtfToUniChar(const char *src, Tcl_UniChar *chPtr);
+EXTERN Tcl_Size Tcl_UtfToChar16(const char *src,
+ unsigned short *chPtr);
/* 337 */
-EXTERN int Tcl_UtfToUpper(char *src);
+EXTERN Tcl_Size Tcl_UtfToUpper(char *src);
/* 338 */
-EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src,
- int srcLen);
+EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src,
+ Tcl_Size srcLen);
/* 339 */
-EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
/* 341 */
-EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void);
+TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath")
+const char * Tcl_GetDefaultEncodingDir(void);
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir(const char *path);
+TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath")
+void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
-EXTERN void Tcl_AlertNotifier(ClientData clientData);
+EXTERN void Tcl_AlertNotifier(void *clientData);
/* 344 */
EXTERN void Tcl_ServiceModeHook(int mode);
/* 345 */
@@ -1022,49 +1075,51 @@ EXTERN int Tcl_UniCharIsUpper(int ch);
/* 351 */
EXTERN int Tcl_UniCharIsWordChar(int ch);
/* 352 */
-EXTERN int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
+EXTERN Tcl_Size Tcl_Char16Len(const unsigned short *uniStr);
/* 353 */
-EXTERN int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
- const Tcl_UniChar *uct,
+TCL_DEPRECATED("Use Tcl_UtfNcmp")
+int Tcl_UniCharNcmp(const unsigned short *ucs,
+ const unsigned short *uct,
unsigned long numChars);
/* 354 */
-EXTERN char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr,
- int uniLength, Tcl_DString *dsPtr);
+EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr);
/* 355 */
-EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
- Tcl_DString *dsPtr);
+EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr);
/* 356 */
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
/* 357 */
-EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
- Tcl_Token *tokenPtr, int count);
+TCL_DEPRECATED("Use Tcl_EvalTokensStandard")
+Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, Tcl_Size count);
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
/* 359 */
EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
const char *script, const char *command,
- int length);
+ Tcl_Size length);
/* 360 */
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
- const char *start, int numBytes, int nested,
- Tcl_Parse *parsePtr);
+ const char *start, Tcl_Size numBytes,
+ int nested, Tcl_Parse *parsePtr);
/* 362 */
EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
- int numBytes, Tcl_Parse *parsePtr);
+ Tcl_Size numBytes, Tcl_Parse *parsePtr);
/* 363 */
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
- const char *start, int numBytes,
+ const char *start, Tcl_Size numBytes,
Tcl_Parse *parsePtr, int append);
/* 365 */
EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
@@ -1094,32 +1149,38 @@ EXTERN int Tcl_UniCharIsPunct(int ch);
/* 376 */
EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp,
Tcl_RegExp regexp, Tcl_Obj *textObj,
- int offset, int nmatches, int flags);
+ Tcl_Size offset, Tcl_Size nmatches,
+ int flags);
/* 377 */
EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp,
Tcl_RegExpInfo *infoPtr);
/* 378 */
-EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode,
- int numChars);
+EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode,
+ Tcl_Size numChars);
/* 379 */
EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const unsigned short *unicode,
+ Tcl_Size numChars);
/* 380 */
-EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
+EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
-EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index);
/* 382 */
-EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
+TCL_DEPRECATED("No longer in use, changed to macro")
+unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
-EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
+EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first,
+ Tcl_Size last);
/* 384 */
EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int length);
+ const unsigned short *unicode,
+ Tcl_Size length);
/* 385 */
EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp,
Tcl_Obj *textObj, Tcl_Obj *patternObj);
/* 386 */
-EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr);
+EXTERN void Tcl_SetNotifier(
+ const Tcl_NotifierProcs *notifierProcPtr);
/* 387 */
EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void);
/* 388 */
@@ -1128,31 +1189,28 @@ EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp);
EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp,
const char *pattern);
/* 390 */
-EXTERN int Tcl_ProcObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp,
+ Tcl_Size 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,
- ClientData clientData, int stackSize,
- int flags);
+ Tcl_ThreadCreateProc *proc, void *clientData,
+ TCL_HASH_TYPE stackSize, int flags);
/* 394 */
-EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst,
- int bytesToRead);
+EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst,
+ Tcl_Size bytesToRead);
/* 395 */
-EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src,
- int srcLen);
+EXTERN Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src,
+ Tcl_Size srcLen);
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
/* 398 */
-EXTERN CONST84_RETURN char * Tcl_ChannelName(
- const Tcl_ChannelType *chanTypePtr);
+EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
@@ -1160,7 +1218,8 @@ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr);
/* 401 */
-EXTERN Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
+TCL_DEPRECATED("Use Tcl_ChannelClose2Proc")
+Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr);
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(
@@ -1172,7 +1231,8 @@ EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc(
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr);
/* 405 */
-EXTERN Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
+TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc")
+Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr);
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(
@@ -1208,12 +1268,14 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel);
/* 418 */
EXTERN int Tcl_IsChannelExisting(const char *channelName);
/* 419 */
-EXTERN int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
- const Tcl_UniChar *uct,
+TCL_DEPRECATED("Use Tcl_UtfNcasecmp")
+int Tcl_UniCharNcasecmp(const unsigned short *ucs,
+ const unsigned short *uct,
unsigned long numChars);
/* 420 */
-EXTERN int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
- const Tcl_UniChar *uniPattern, int nocase);
+TCL_DEPRECATED("Use Tcl_StringCaseMatch")
+int Tcl_UniCharCaseMatch(const unsigned short *uniStr,
+ const unsigned short *uniPattern, int nocase);
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr,
const void *key);
@@ -1226,45 +1288,45 @@ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr,
/* 424 */
EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr);
/* 425 */
-EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp,
+EXTERN void * Tcl_CommandTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_CommandTraceProc *procPtr,
- ClientData prevClientData);
+ void *prevClientData);
/* 426 */
EXTERN int Tcl_TraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_CommandTraceProc *proc,
- ClientData clientData);
+ Tcl_CommandTraceProc *proc, void *clientData);
/* 427 */
EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
- Tcl_CommandTraceProc *proc,
- ClientData clientData);
+ Tcl_CommandTraceProc *proc, void *clientData);
/* 428 */
-EXTERN char * Tcl_AttemptAlloc(unsigned int size);
+EXTERN char * Tcl_AttemptAlloc(TCL_HASH_TYPE size);
/* 429 */
-EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size,
+EXTERN char * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size,
const char *file, int line);
/* 430 */
-EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size);
+EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size);
/* 431 */
-EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
+EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size,
const char *file, int line);
/* 432 */
-EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length);
+EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr,
+ Tcl_Size length);
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
/* 434 */
-EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
+EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 435 */
-EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
- Tcl_MathProc **procPtr,
- ClientData *clientDataPtr);
+ Tcl_MathProc **procPtr, void **clientDataPtr);
/* 436 */
-EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -1287,8 +1349,8 @@ EXTERN int Tcl_FSDeleteFile(Tcl_Obj *pathPtr);
/* 444 */
EXTERN int Tcl_FSLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *sym1, const char *sym2,
- Tcl_PackageInitProc **proc1Ptr,
- Tcl_PackageInitProc **proc2Ptr,
+ Tcl_LibraryInitProc **proc1Ptr,
+ Tcl_LibraryInitProc **proc2Ptr,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr);
/* 445 */
@@ -1333,7 +1395,7 @@ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr);
EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/* 460 */
-EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, int elements);
+EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements);
/* 461 */
EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
/* 462 */
@@ -1343,10 +1405,10 @@ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr,
EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
/* 464 */
-EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
+EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 465 */
-EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
+EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr);
/* 466 */
EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp,
@@ -1356,7 +1418,7 @@ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName);
/* 468 */
EXTERN Tcl_Obj * Tcl_FSNewNativePath(
const Tcl_Filesystem *fromFilesystem,
- ClientData clientData);
+ void *clientData);
/* 469 */
EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr);
/* 470 */
@@ -1366,12 +1428,12 @@ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr);
/* 472 */
EXTERN Tcl_Obj * Tcl_FSListVolumes(void);
/* 473 */
-EXTERN int Tcl_FSRegister(ClientData clientData,
+EXTERN int Tcl_FSRegister(void *clientData,
const Tcl_Filesystem *fsPtr);
/* 474 */
EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr);
/* 475 */
-EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr);
+EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr);
/* 476 */
EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
@@ -1385,13 +1447,14 @@ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan);
EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr);
/* 481 */
EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp,
- Tcl_Token *tokenPtr, int count);
+ Tcl_Token *tokenPtr, Tcl_Size count);
/* 482 */
EXTERN void Tcl_GetTime(Tcl_Time *timeBuf);
/* 483 */
-EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level,
- int flags, Tcl_CmdObjTraceProc *objProc,
- ClientData clientData,
+EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp,
+ Tcl_Size level, int flags,
+ Tcl_CmdObjTraceProc *objProc,
+ void *clientData,
Tcl_CmdObjTraceDeleteProc *delProc);
/* 484 */
EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token,
@@ -1413,10 +1476,10 @@ EXTERN void Tcl_SetWideIntObj(Tcl_Obj *objPtr,
/* 490 */
EXTERN Tcl_StatBuf * Tcl_AllocStatBuf(void);
/* 491 */
-EXTERN Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset,
+EXTERN long long Tcl_Seek(Tcl_Channel chan, long long offset,
int mode);
/* 492 */
-EXTERN Tcl_WideInt Tcl_Tell(Tcl_Channel chan);
+EXTERN long long Tcl_Tell(Tcl_Channel chan);
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr);
@@ -1445,11 +1508,11 @@ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr,
EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr);
/* 501 */
EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp,
- Tcl_Obj *dictPtr, int keyc,
+ Tcl_Obj *dictPtr, Tcl_Size keyc,
Tcl_Obj *const *keyv, Tcl_Obj *valuePtr);
/* 502 */
EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp,
- Tcl_Obj *dictPtr, int keyc,
+ Tcl_Obj *dictPtr, Tcl_Size keyc,
Tcl_Obj *const *keyv);
/* 503 */
EXTERN Tcl_Obj * Tcl_NewDictObj(void);
@@ -1462,7 +1525,7 @@ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp,
const char *valEncoding);
/* 506 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- const char *name, ClientData clientData,
+ const char *name, void *clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 507 */
EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
@@ -1503,12 +1566,12 @@ EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc);
/* 520 */
EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData,
+ void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc);
/* 521 */
EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData);
+ void *clientData);
/* 522 */
EXTERN int Tcl_LimitReady(Tcl_Interp *interp);
/* 523 */
@@ -1517,7 +1580,7 @@ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp);
EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp);
/* 525 */
EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp,
- int commandLimit);
+ Tcl_Size commandLimit);
/* 526 */
EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp,
Tcl_Time *timeLimitPtr);
@@ -1591,30 +1654,30 @@ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp,
/* 552 */
EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
- ClientData clientData);
+ void *clientData);
/* 553 */
EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
- ClientData *clientData);
+ void **clientData);
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr);
/* 555 */
-EXTERN Tcl_Obj * Tcl_NewBignumObj(mp_int *value);
+EXTERN Tcl_Obj * Tcl_NewBignumObj(void *value);
/* 556 */
-EXTERN Tcl_Obj * Tcl_DbNewBignumObj(mp_int *value, const char *file,
+EXTERN Tcl_Obj * Tcl_DbNewBignumObj(void *value, const char *file,
int line);
/* 557 */
-EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, mp_int *value);
+EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, void *value);
/* 558 */
EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp,
- Tcl_Obj *obj, mp_int *value);
+ Tcl_Obj *obj, void *value);
/* 559 */
EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp,
- Tcl_Obj *obj, mp_int *value);
+ Tcl_Obj *obj, void *value);
/* 560 */
EXTERN int Tcl_TruncateChannel(Tcl_Channel chan,
- Tcl_WideInt length);
+ long long length);
/* 561 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc(
const Tcl_ChannelType *chanTypePtr);
@@ -1630,7 +1693,7 @@ EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg);
EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg);
/* 566 */
EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp,
- double initval, mp_int *toInit);
+ double initval, void *toInit);
/* 567 */
EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr);
@@ -1649,22 +1712,22 @@ EXTERN const char * Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr);
/* 573 */
EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp,
- const char *name, int objc,
+ const char *name, Tcl_Size 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, int length, int limit,
- const char *ellipsis);
+ const char *bytes, Tcl_Size length,
+ Tcl_Size limit, const char *ellipsis);
/* 576 */
EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 577 */
EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, const char *format,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 578 */
EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2);
/* 579 */
@@ -1672,7 +1735,7 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr,
const char *format, ...) TCL_FORMAT_PRINTF(2, 3);
/* 580 */
EXTERN int Tcl_CancelEval(Tcl_Interp *interp,
- Tcl_Obj *resultObjPtr, ClientData clientData,
+ Tcl_Obj *resultObjPtr, void *clientData,
int flags);
/* 581 */
EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags);
@@ -1683,28 +1746,26 @@ EXTERN int Tcl_CreatePipe(Tcl_Interp *interp,
/* 583 */
EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
- Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
+ 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, int objc,
+EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags);
/* 586 */
EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd,
- int objc, Tcl_Obj *const objv[], int flags);
+ Tcl_Size objc, Tcl_Obj *const objv[],
+ int flags);
/* 587 */
EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp,
- Tcl_NRPostProc *postProcPtr,
- ClientData data0, ClientData data1,
- ClientData data2, ClientData data3);
+ Tcl_NRPostProc *postProcPtr, void *data0,
+ void *data1, void *data2, void *data3);
/* 588 */
EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp,
- Tcl_ObjCmdProc *objProc,
- ClientData clientData, int objc,
- Tcl_Obj *const objv[]);
+ Tcl_ObjCmdProc *objProc, void *clientData,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 589 */
EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr);
/* 590 */
@@ -1720,16 +1781,16 @@ EXTERN int Tcl_GetGroupIdFromStat(const Tcl_StatBuf *statPtr);
/* 595 */
EXTERN int Tcl_GetDeviceTypeFromStat(const Tcl_StatBuf *statPtr);
/* 596 */
-EXTERN Tcl_WideInt Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr);
+EXTERN long long Tcl_GetAccessTimeFromStat(const Tcl_StatBuf *statPtr);
/* 597 */
-EXTERN Tcl_WideInt Tcl_GetModificationTimeFromStat(
+EXTERN long long Tcl_GetModificationTimeFromStat(
const Tcl_StatBuf *statPtr);
/* 598 */
-EXTERN Tcl_WideInt Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr);
+EXTERN long long Tcl_GetChangeTimeFromStat(const Tcl_StatBuf *statPtr);
/* 599 */
-EXTERN Tcl_WideUInt Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr);
+EXTERN unsigned long long Tcl_GetSizeFromStat(const Tcl_StatBuf *statPtr);
/* 600 */
-EXTERN Tcl_WideUInt Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr);
+EXTERN unsigned long long Tcl_GetBlocksFromStat(const Tcl_StatBuf *statPtr);
/* 601 */
EXTERN unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr);
/* 602 */
@@ -1759,14 +1820,14 @@ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format,
Tcl_Obj *gzipHeaderDictObj);
/* 611 */
EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format,
- Tcl_Obj *data, int buffersize,
+ Tcl_Obj *data, Tcl_Size buffersize,
Tcl_Obj *gzipHeaderDictObj);
/* 612 */
EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc,
- const unsigned char *buf, int len);
+ const unsigned char *buf, Tcl_Size len);
/* 613 */
EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler,
- const unsigned char *buf, int len);
+ const unsigned char *buf, Tcl_Size len);
/* 614 */
EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode,
int format, int level, Tcl_Obj *dictObj,
@@ -1782,7 +1843,7 @@ EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle,
Tcl_Obj *data, int flush);
/* 619 */
EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle,
- Tcl_Obj *data, int count);
+ Tcl_Obj *data, Tcl_Size count);
/* 620 */
EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle);
/* 621 */
@@ -1815,36 +1876,91 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
-/* Slot 631 is reserved */
-/* Slot 632 is reserved */
-/* Slot 633 is reserved */
-/* Slot 634 is reserved */
-/* Slot 635 is reserved */
-/* Slot 636 is reserved */
-/* Slot 637 is reserved */
-/* Slot 638 is reserved */
-/* Slot 639 is reserved */
-/* Slot 640 is reserved */
-/* Slot 641 is reserved */
-/* Slot 642 is reserved */
-/* Slot 643 is reserved */
-/* Slot 644 is reserved */
-/* Slot 645 is reserved */
-/* Slot 646 is reserved */
-/* Slot 647 is reserved */
-/* Slot 648 is reserved */
-/* Slot 649 is reserved */
+/* 631 */
+EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
+ const char *service, const char *host,
+ unsigned int flags, int backlog,
+ Tcl_TcpAcceptProc *acceptProc,
+ void *callbackData);
+/* 632 */
+EXTERN int TclZipfs_Mount(Tcl_Interp *interp,
+ const char *zipname, const char *mountPoint,
+ const char *passwd);
+/* 633 */
+EXTERN int TclZipfs_Unmount(Tcl_Interp *interp,
+ const char *mountPoint);
+/* 634 */
+EXTERN Tcl_Obj * TclZipfs_TclLibrary(void);
+/* 635 */
+EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp,
+ const void *data, size_t datalen,
+ const char *mountPoint, 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);
+/* 640 */
+EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
+/* 641 */
+EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
+/* 642 */
+EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
+/* 643 */
+EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
+/* 644 */
+EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
+ const char *varName, void *addr, int type,
+ Tcl_Size size);
+/* 645 */
+EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Size endValue,
+ Tcl_Size *indexPtr);
+/* 646 */
+EXTERN Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr);
+/* 647 */
+EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr,
+ Tcl_Size uniLength, Tcl_DString *dsPtr);
+/* 648 */
+EXTERN int * Tcl_UtfToUniCharDString(const char *src,
+ Tcl_Size length, Tcl_DString *dsPtr);
+/* 649 */
+EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *numBytesPtr);
/* Slot 650 is reserved */
/* Slot 651 is reserved */
/* Slot 652 is reserved */
/* Slot 653 is reserved */
-/* Slot 654 is reserved */
-/* Slot 655 is reserved */
-/* Slot 656 is reserved */
-/* Slot 657 is reserved */
-/* Slot 658 is reserved */
-/* Slot 659 is reserved */
-/* Slot 660 is reserved */
+/* 654 */
+EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length);
+/* 655 */
+EXTERN const char * Tcl_UtfNext(const char *src);
+/* 656 */
+EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
+/* 657 */
+EXTERN int Tcl_UniCharIsUnicode(int ch);
+/* 658 */
+EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp,
+ Tcl_Encoding encoding, const char *src,
+ Tcl_Size srcLen, int flags,
+ Tcl_DString *dsPtr,
+ Tcl_Size *errorLocationPtr);
+/* 659 */
+EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp,
+ Tcl_Encoding encoding, const char *src,
+ Tcl_Size srcLen, int flags,
+ Tcl_DString *dsPtr,
+ Tcl_Size *errorLocationPtr);
+/* 660 */
+EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async,
+ int sigNumber);
/* Slot 661 is reserved */
/* Slot 662 is reserved */
/* Slot 663 is reserved */
@@ -1852,24 +1968,47 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
/* Slot 665 is reserved */
/* Slot 666 is reserved */
/* Slot 667 is reserved */
-/* Slot 668 is reserved */
-/* Slot 669 is reserved */
-/* Slot 670 is reserved */
-/* Slot 671 is reserved */
-/* Slot 672 is reserved */
-/* Slot 673 is reserved */
-/* Slot 674 is reserved */
-/* Slot 675 is reserved */
+/* 668 */
+EXTERN Tcl_Size Tcl_UniCharLen(const int *uniStr);
+/* 669 */
+EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length);
+/* 670 */
+EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr);
+/* 671 */
+EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index);
+/* 672 */
+EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first,
+ Tcl_Size last);
+/* 673 */
+EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index);
+/* 674 */
+EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src,
+ int flags, char *charPtr);
+/* 675 */
+EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int flags, char *charPtr);
/* Slot 676 is reserved */
/* Slot 677 is reserved */
/* Slot 678 is reserved */
/* Slot 679 is reserved */
-/* Slot 680 is reserved */
-/* Slot 681 is reserved */
-/* Slot 682 is reserved */
-/* Slot 683 is reserved */
-/* Slot 684 is reserved */
-/* Slot 685 is reserved */
+/* 680 */
+EXTERN int Tcl_GetNumberFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, void **clientDataPtr,
+ int *typePtr);
+/* 681 */
+EXTERN int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes,
+ Tcl_Size numBytes, void **clientDataPtr,
+ int *typePtr);
+/* 682 */
+EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp,
+ Tcl_Channel chan, int mode);
+/* 683 */
+EXTERN Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
+/* 684 */
+EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr);
+/* 685 */
+EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr);
/* Slot 686 is reserved */
/* Slot 687 is reserved */
/* 688 */
@@ -1886,22 +2025,22 @@ typedef struct TclStubs {
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
- CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
+ 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 */
- char * (*tcl_Alloc) (unsigned int size); /* 3 */
+ char * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */
void (*tcl_Free) (char *ptr); /* 4 */
- char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
- char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */
+ char * (*tcl_Realloc) (char *ptr, TCL_HASH_TYPE size); /* 5 */
+ char * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */
void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */
- char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */
+ char * (*tcl_DbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
- void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
+ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
+ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
@@ -1917,27 +2056,27 @@ typedef struct TclStubs {
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, int length); /* 16 */
- Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */
+ void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 16 */
+ Tcl_Obj * (*tcl_ConcatObj) (Tcl_Size 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 */
- Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */
- Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */
+ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
- Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
- Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
+ Tcl_Obj * (*tcl_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
- Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
+ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, Tcl_Size 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 * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */
+ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, Tcl_Size *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 */
- int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
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 */
@@ -1947,93 +2086,93 @@ typedef struct TclStubs {
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 (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */
- int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */
+ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
- int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */
- Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */
- Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int numBytes); /* 50 */
+ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */
+ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
- Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
- Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */
- Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
+ Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
- Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
- void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */
- unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */
- void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int numBytes); /* 59 */
+ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */
+ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */
+ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
- void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
- void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */
- void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
- void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */
- void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */
- void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
- void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
+ void (*tcl_SetListObj) (Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
+ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */
+ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, Tcl_Size length); /* 67 */
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, ClientData clientData); /* 71 */
+ 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 (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
- char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
+ TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
- void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
- void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
+ 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) (int argc, CONST84 char *const *argv); /* 83 */
- int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
- int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
- int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
- int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
- Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
- void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
- void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */
- Tcl_Command (*tcl_CreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 91 */
- void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
- void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
+ char * (*tcl_Concat) (Tcl_Size argc, const char *const *argv); /* 83 */
+ Tcl_Size (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
+ Tcl_Size (*tcl_ConvertCountedElement) (const char *src, Tcl_Size length, char *dst, int flags); /* 85 */
+ int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size argc, const char *const *argv); /* 86 */
+ int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size 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 */
- void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
- Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
- Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
- Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
- Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */
+ TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, void *clientData); /* 95 */
+ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
+ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */
+ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */
+ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */
void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */
- void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */
- void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */
+ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */
+ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */
int (*tcl_DeleteCommand) (Tcl_Interp *interp, const char *cmdName); /* 103 */
int (*tcl_DeleteCommandFromToken) (Tcl_Interp *interp, Tcl_Command command); /* 104 */
- void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, ClientData clientData); /* 105 */
- void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 106 */
- void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 107 */
+ 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) (int numPids, Tcl_Pid *pidPtr); /* 111 */
+ void (*tcl_DetachPids) (Tcl_Size 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, ClientData clientData); /* 114 */
+ void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */
int (*tcl_DoOneEvent) (int flags); /* 115 */
- void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, ClientData clientData); /* 116 */
- char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */
+ void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */
+ char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, Tcl_Size length); /* 117 */
char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */
void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */
void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */
void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */
void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */
void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */
- void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */
+ void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, Tcl_Size length); /* 124 */
void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
- CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */
- CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */
+ const char * (*tcl_ErrnoId) (void); /* 127 */
+ const char * (*tcl_ErrnoMsg) (int err); /* 128 */
int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
- int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
- void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
+ void (*tcl_EventuallyFree) (void *clientData, Tcl_FreeProc *freeProc); /* 132 */
TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */
int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */
int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */
@@ -2045,49 +2184,49 @@ typedef struct TclStubs {
int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */
int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */
void (*tcl_Finalize) (void); /* 143 */
- void (*tcl_FindExecutable) (const char *argv0); /* 144 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_FindExecutable) (const char *argv0); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
- void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
- int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
- ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
+ TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
+ 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 */
- int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
- int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */
- ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
+ Tcl_Size (*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 */
- CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
+ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
- CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
+ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
- CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
+ const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */
- Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
+ Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
- int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
+ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved167)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */
+ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */
#endif /* MACOSX */
Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */
- int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
- int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
+ Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */
+ Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */
int (*tcl_GetServiceMode) (void); /* 171 */
- Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *name); /* 172 */
+ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
- CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
- CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
- CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
+ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
- int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
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 */
@@ -2095,27 +2234,27 @@ typedef struct TclStubs {
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
- char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */
- int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */
+ char * (*tcl_JoinPath) (Tcl_Size 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) (ClientData handle, int mode); /* 189 */
- int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
- Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */
- char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */
+ Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */
+ TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
+ Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */
+ char * (*tcl_Merge) (Tcl_Size 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, int argc, CONST84 char **argv, int flags); /* 197 */
+ Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, Tcl_Size 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 flags); /* 199 */
- Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
- void (*tcl_Preserve) (ClientData data); /* 201 */
+ 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 */
- CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
- void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
- int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
+ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
+ void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */
+ Tcl_Size (*tcl_Read) (Tcl_Channel chan, char *bufPtr, Tcl_Size 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 */
@@ -2124,135 +2263,135 @@ typedef struct TclStubs {
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, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
- void (*tcl_Release) (ClientData clientData); /* 216 */
+ void (*tcl_RegExpRange) (Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 215 */
+ void (*tcl_Release) (void *clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
- int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
- int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */
- int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
+ Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
+ Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */
+ TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
- void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
- void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
+ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */
+ void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, Tcl_Size 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 (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
- int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
+ Tcl_Size (*tcl_SetRecursionLimit) (Tcl_Interp *interp, Tcl_Size depth); /* 231 */
void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */
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 */
- CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
- CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
- CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */
- CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ 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 (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
- void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
- void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
- int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
- int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
- int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
- int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
+ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
+ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 244 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
+ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 247 */
+ 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 */
- int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
+ Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
- int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
- void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
- void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 255 */
+ 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 */
- int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
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 */
- ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
- ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
- int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
- void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */
+ void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */
+ Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */
+ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, Tcl_Size 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 (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
- void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
- CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */
- CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
- CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
- int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
- CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
- void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
- int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
+ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
+ TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
+ TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
- TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
+ TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
- Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
+ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
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, ClientData clientData); /* 288 */
- void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */
- void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
- int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
- int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
+ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */
+ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */
+ TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
+ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */
+ int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
- void (*tcl_ExitThread) (int status); /* 294 */
- int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
- char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
+ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
+ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
+ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
- void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
+ void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
- CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
+ const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
- int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */
- void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
+ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, Tcl_Size offset, const char *msg, int flags, void *indexPtr); /* 304 */
+ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, Tcl_Size size); /* 305 */
Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */
- ClientData (*tcl_InitNotifier) (void); /* 307 */
+ void * (*tcl_InitNotifier) (void); /* 307 */
void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */
void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */
void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */
void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */
- int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */
- int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */
- void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
- void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
+ Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */
+ Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */
+ TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
+ TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
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, Tcl_QueuePosition position); /* 319 */
- Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
- Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */
- Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
- Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
- int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
- CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
- int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
- int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
- CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
- CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
- CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */
- CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
- int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
- char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
- int (*tcl_UtfToLower) (char *src); /* 334 */
- int (*tcl_UtfToTitle) (char *src); /* 335 */
- int (*tcl_UtfToUniChar) (const char *src, Tcl_UniChar *chPtr); /* 336 */
- int (*tcl_UtfToUpper) (char *src); /* 337 */
- int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
- int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
+ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */
+ int (*tcl_UniCharAtIndex) (const char *src, Tcl_Size index); /* 320 */
+ int (*tcl_UniCharToLower) (int ch); /* 321 */
+ int (*tcl_UniCharToTitle) (int ch); /* 322 */
+ int (*tcl_UniCharToUpper) (int ch); /* 323 */
+ Tcl_Size (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
+ const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */
+ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */
+ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
+ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ const char * (*tclUtfNext) (const char *src); /* 330 */
+ const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */
+ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
+ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 333 */
+ Tcl_Size (*tcl_UtfToLower) (char *src); /* 334 */
+ Tcl_Size (*tcl_UtfToTitle) (char *src); /* 335 */
+ Tcl_Size (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */
+ Tcl_Size (*tcl_UtfToUpper) (char *src); /* 337 */
+ Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */
+ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
- CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
- void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
- void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */
+ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
+ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
+ void (*tcl_AlertNotifier) (void *clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
int (*tcl_UniCharIsAlpha) (int ch); /* 346 */
@@ -2261,19 +2400,19 @@ typedef struct TclStubs {
int (*tcl_UniCharIsSpace) (int ch); /* 349 */
int (*tcl_UniCharIsUpper) (int ch); /* 350 */
int (*tcl_UniCharIsWordChar) (int ch); /* 351 */
- int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
- int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */
- char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
- Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */
+ Tcl_Size (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */
+ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */
+ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */
+ unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
- Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
+ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 357 */
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
- void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */
- int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */
- int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
- int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
- int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */
- int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
+ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length); /* 359 */
+ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
+ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
+ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 362 */
+ int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
+ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
int (*tcl_Chdir) (const char *dirName); /* 366 */
int (*tcl_Access) (const char *path, int mode); /* 367 */
@@ -2285,36 +2424,36 @@ typedef struct TclStubs {
int (*tcl_UniCharIsGraph) (int ch); /* 373 */
int (*tcl_UniCharIsPrint) (int ch); /* 374 */
int (*tcl_UniCharIsPunct) (int ch); /* 375 */
- int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */
+ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */
void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */
- Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
- void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
- int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
- Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
- Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
- Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
- void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
+ Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, Tcl_Size numChars); /* 378 */
+ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars); /* 379 */
+ Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
+ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */
+ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
+ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */
+ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
- void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
+ 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) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */
+ int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, Tcl_Size 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, ClientData clientData, int stackSize, int flags); /* 393 */
- int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
- int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
+ int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, TCL_HASH_TYPE stackSize, int flags); /* 393 */
+ Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */
+ Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
- CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
+ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
- Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
+ TCL_DEPRECATED_API("Use Tcl_ChannelClose2Proc") Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */
Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */
Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */
- Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */
+ TCL_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */
@@ -2328,24 +2467,24 @@ typedef struct TclStubs {
void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */
void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */
int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */
- int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */
- int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */
+ TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */
+ TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */
Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */
Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */
void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */
void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */
- ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */
- int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */
- void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */
- char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */
- char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */
- char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */
- char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */
- int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
+ 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 */
+ char * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */
+ char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */
+ char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */
+ char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */
+ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
- Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
- int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
- Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
+ unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
+ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **clientDataPtr); /* 435 */
+ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */
@@ -2353,7 +2492,7 @@ typedef struct TclStubs {
int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */
int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */
int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */
- int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */
+ int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */
int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); /* 445 */
Tcl_Obj * (*tcl_FSLink) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); /* 446 */
int (*tcl_FSRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 447 */
@@ -2369,30 +2508,30 @@ typedef struct TclStubs {
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, int elements); /* 460 */
+ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, Tcl_Size elements); /* 460 */
Tcl_Obj * (*tcl_FSSplitPath) (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, int objc, Tcl_Obj *const objv[]); /* 464 */
- ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */
+ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, Tcl_Size 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, ClientData clientData); /* 468 */
+ 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 */
Tcl_Obj * (*tcl_FSListVolumes) (void); /* 472 */
- int (*tcl_FSRegister) (ClientData clientData, const Tcl_Filesystem *fsPtr); /* 473 */
+ int (*tcl_FSRegister) (void *clientData, const Tcl_Filesystem *fsPtr); /* 473 */
int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */
- ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */
+ void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */
const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */
CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */
Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */
int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */
void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */
- int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */
+ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */
void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */
- Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */
+ Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */
int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */
int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */
Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */
@@ -2400,8 +2539,8 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */
void (*tcl_SetWideIntObj) (Tcl_Obj *objPtr, Tcl_WideInt wideValue); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
- Tcl_WideInt (*tcl_Seek) (Tcl_Channel chan, Tcl_WideInt offset, int mode); /* 491 */
- Tcl_WideInt (*tcl_Tell) (Tcl_Channel chan); /* 492 */
+ long long (*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 */
@@ -2410,12 +2549,12 @@ typedef struct TclStubs {
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, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
- int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
+ int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
+ int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size 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, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
+ 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 */
@@ -2428,13 +2567,13 @@ typedef struct TclStubs {
Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */
void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */
int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
- Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */
- void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
- void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */
+ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */
+ 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, int commandLimit); /* 525 */
+ void (*tcl_LimitSetCommands) (Tcl_Interp *interp, Tcl_Size 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 */
@@ -2461,43 +2600,43 @@ typedef struct TclStubs {
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
- void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */
- void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */
+ void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, void *clientData); /* 552 */
+ void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, void **clientData); /* 553 */
Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */
- Tcl_Obj * (*tcl_NewBignumObj) (mp_int *value); /* 555 */
- Tcl_Obj * (*tcl_DbNewBignumObj) (mp_int *value, const char *file, int line); /* 556 */
- void (*tcl_SetBignumObj) (Tcl_Obj *obj, mp_int *value); /* 557 */
- int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 558 */
- int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, mp_int *value); /* 559 */
- int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */
+ Tcl_Obj * (*tcl_NewBignumObj) (void *value); /* 555 */
+ Tcl_Obj * (*tcl_DbNewBignumObj) (void *value, const char *file, int line); /* 556 */
+ void (*tcl_SetBignumObj) (Tcl_Obj *obj, void *value); /* 557 */
+ int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 558 */
+ int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */
+ int (*tcl_TruncateChannel) (Tcl_Channel chan, long long length); /* 560 */
Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */
void (*tcl_SetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj *msg); /* 562 */
void (*tcl_GetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj **msg); /* 563 */
void (*tcl_SetChannelError) (Tcl_Channel chan, Tcl_Obj *msg); /* 564 */
void (*tcl_GetChannelError) (Tcl_Channel chan, Tcl_Obj **msg); /* 565 */
- int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, mp_int *toInit); /* 566 */
+ 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, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
+ int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, Tcl_Size 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, int length, int limit, const char *ellipsis); /* 575 */
- Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */
- int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */
+ void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length, Tcl_Size limit, const char *ellipsis); /* 575 */
+ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, Tcl_Size objc, Tcl_Obj *const objv[]); /* 576 */
+ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, Tcl_Size 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, ClientData clientData, int flags); /* 580 */
+ 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, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */
+ 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, int objc, Tcl_Obj *const objv[], int flags); /* 585 */
- int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */
- void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */
- int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 588 */
+ int (*tcl_NREvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 585 */
+ int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size 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, Tcl_Size 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 */
@@ -2505,11 +2644,11 @@ typedef struct TclStubs {
int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */
int (*tcl_GetGroupIdFromStat) (const Tcl_StatBuf *statPtr); /* 594 */
int (*tcl_GetDeviceTypeFromStat) (const Tcl_StatBuf *statPtr); /* 595 */
- Tcl_WideInt (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */
- Tcl_WideInt (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */
- Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */
- Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */
- Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */
+ 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 */
@@ -2520,15 +2659,15 @@ typedef struct TclStubs {
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, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
- unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, int len); /* 612 */
- unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, int len); /* 613 */
+ int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
+ unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, Tcl_Size len); /* 612 */
+ unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, Tcl_Size len); /* 613 */
int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */
Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */
int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */
int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */
int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */
- int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 619 */
+ int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, Tcl_Size count); /* 619 */
int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */
int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */
void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */
@@ -2540,36 +2679,36 @@ typedef struct TclStubs {
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
- void (*reserved631)(void);
- void (*reserved632)(void);
- void (*reserved633)(void);
- void (*reserved634)(void);
- void (*reserved635)(void);
- void (*reserved636)(void);
- void (*reserved637)(void);
- void (*reserved638)(void);
- void (*reserved639)(void);
- void (*reserved640)(void);
- void (*reserved641)(void);
- void (*reserved642)(void);
- void (*reserved643)(void);
- void (*reserved644)(void);
- void (*reserved645)(void);
- void (*reserved646)(void);
- void (*reserved647)(void);
- void (*reserved648)(void);
- void (*reserved649)(void);
+ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, int backlog, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 631 */
+ int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *zipname, const char *mountPoint, 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 void *data, size_t datalen, const char *mountPoint, 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, Tcl_Size size); /* 644 */
+ int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */
+ Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
+ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */
+ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */
+ unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */
void (*reserved650)(void);
void (*reserved651)(void);
void (*reserved652)(void);
void (*reserved653)(void);
- void (*reserved654)(void);
- void (*reserved655)(void);
- void (*reserved656)(void);
- void (*reserved657)(void);
- void (*reserved658)(void);
- void (*reserved659)(void);
- void (*reserved660)(void);
+ int (*tcl_UtfCharComplete) (const char *src, Tcl_Size 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 */
+ int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */
+ int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */
+ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
void (*reserved661)(void);
void (*reserved662)(void);
void (*reserved663)(void);
@@ -2577,24 +2716,24 @@ typedef struct TclStubs {
void (*reserved665)(void);
void (*reserved666)(void);
void (*reserved667)(void);
- void (*reserved668)(void);
- void (*reserved669)(void);
- void (*reserved670)(void);
- void (*reserved671)(void);
- void (*reserved672)(void);
- void (*reserved673)(void);
- void (*reserved674)(void);
- void (*reserved675)(void);
+ Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */
+ Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 669 */
+ Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */
+ const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 671 */
+ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */
+ int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */
+ int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */
+ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */
void (*reserved676)(void);
void (*reserved677)(void);
void (*reserved678)(void);
void (*reserved679)(void);
- void (*reserved680)(void);
- void (*reserved681)(void);
- void (*reserved682)(void);
- void (*reserved683)(void);
- void (*reserved684)(void);
- void (*reserved685)(void);
+ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */
+ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */
+ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
+ Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
+ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
+ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
void (*reserved686)(void);
void (*reserved687)(void);
void (*tclUnusedStubEntry) (void); /* 688 */
@@ -2818,8 +2957,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_CreateMathFunc) /* 95 */
#define Tcl_CreateObjCommand \
(tclStubsPtr->tcl_CreateObjCommand) /* 96 */
-#define Tcl_CreateSlave \
- (tclStubsPtr->tcl_CreateSlave) /* 97 */
+#define Tcl_CreateChild \
+ (tclStubsPtr->tcl_CreateChild) /* 97 */
#define Tcl_CreateTimerHandler \
(tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
#define Tcl_CreateTrace \
@@ -2952,8 +3091,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_GetHostName) /* 162 */
#define Tcl_GetInterpPath \
(tclStubsPtr->tcl_GetInterpPath) /* 163 */
-#define Tcl_GetMaster \
- (tclStubsPtr->tcl_GetMaster) /* 164 */
+#define Tcl_GetParent \
+ (tclStubsPtr->tcl_GetParent) /* 164 */
#define Tcl_GetNameOfExecutable \
(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#define Tcl_GetObjResult \
@@ -2974,8 +3113,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_GetsObj) /* 170 */
#define Tcl_GetServiceMode \
(tclStubsPtr->tcl_GetServiceMode) /* 171 */
-#define Tcl_GetSlave \
- (tclStubsPtr->tcl_GetSlave) /* 172 */
+#define Tcl_GetChild \
+ (tclStubsPtr->tcl_GetChild) /* 172 */
#define Tcl_GetStdChannel \
(tclStubsPtr->tcl_GetStdChannel) /* 173 */
#define Tcl_GetStringResult \
@@ -3117,8 +3256,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_SplitList) /* 242 */
#define Tcl_SplitPath \
(tclStubsPtr->tcl_SplitPath) /* 243 */
-#define Tcl_StaticPackage \
- (tclStubsPtr->tcl_StaticPackage) /* 244 */
+#define Tcl_StaticLibrary \
+ (tclStubsPtr->tcl_StaticLibrary) /* 244 */
#define Tcl_StringMatch \
(tclStubsPtr->tcl_StringMatch) /* 245 */
#define Tcl_TellOld \
@@ -3280,18 +3419,18 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UniCharToUtf) /* 324 */
#define Tcl_UtfAtIndex \
(tclStubsPtr->tcl_UtfAtIndex) /* 325 */
-#define Tcl_UtfCharComplete \
- (tclStubsPtr->tcl_UtfCharComplete) /* 326 */
+#define TclUtfCharComplete \
+ (tclStubsPtr->tclUtfCharComplete) /* 326 */
#define Tcl_UtfBackslash \
(tclStubsPtr->tcl_UtfBackslash) /* 327 */
#define Tcl_UtfFindFirst \
(tclStubsPtr->tcl_UtfFindFirst) /* 328 */
#define Tcl_UtfFindLast \
(tclStubsPtr->tcl_UtfFindLast) /* 329 */
-#define Tcl_UtfNext \
- (tclStubsPtr->tcl_UtfNext) /* 330 */
-#define Tcl_UtfPrev \
- (tclStubsPtr->tcl_UtfPrev) /* 331 */
+#define TclUtfNext \
+ (tclStubsPtr->tclUtfNext) /* 330 */
+#define TclUtfPrev \
+ (tclStubsPtr->tclUtfPrev) /* 331 */
#define Tcl_UtfToExternal \
(tclStubsPtr->tcl_UtfToExternal) /* 332 */
#define Tcl_UtfToExternalDString \
@@ -3300,8 +3439,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UtfToLower) /* 334 */
#define Tcl_UtfToTitle \
(tclStubsPtr->tcl_UtfToTitle) /* 335 */
-#define Tcl_UtfToUniChar \
- (tclStubsPtr->tcl_UtfToUniChar) /* 336 */
+#define Tcl_UtfToChar16 \
+ (tclStubsPtr->tcl_UtfToChar16) /* 336 */
#define Tcl_UtfToUpper \
(tclStubsPtr->tcl_UtfToUpper) /* 337 */
#define Tcl_WriteChars \
@@ -3332,14 +3471,14 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
#define Tcl_UniCharIsWordChar \
(tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
-#define Tcl_UniCharLen \
- (tclStubsPtr->tcl_UniCharLen) /* 352 */
+#define Tcl_Char16Len \
+ (tclStubsPtr->tcl_Char16Len) /* 352 */
#define Tcl_UniCharNcmp \
(tclStubsPtr->tcl_UniCharNcmp) /* 353 */
-#define Tcl_UniCharToUtfDString \
- (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
-#define Tcl_UtfToUniCharDString \
- (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
+#define Tcl_Char16ToUtfDString \
+ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */
+#define Tcl_UtfToChar16DString \
+ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */
#define Tcl_GetRegExpFromObj \
(tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
#define Tcl_EvalTokens \
@@ -3890,36 +4029,62 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#define Tcl_ZlibStreamSetCompressionDictionary \
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
-/* Slot 631 is reserved */
-/* Slot 632 is reserved */
-/* Slot 633 is reserved */
-/* Slot 634 is reserved */
-/* Slot 635 is reserved */
-/* Slot 636 is reserved */
-/* Slot 637 is reserved */
-/* Slot 638 is reserved */
-/* Slot 639 is reserved */
-/* Slot 640 is reserved */
-/* Slot 641 is reserved */
-/* Slot 642 is reserved */
-/* Slot 643 is reserved */
-/* Slot 644 is reserved */
-/* Slot 645 is reserved */
-/* Slot 646 is reserved */
-/* Slot 647 is reserved */
-/* Slot 648 is reserved */
-/* Slot 649 is reserved */
+#define Tcl_OpenTcpServerEx \
+ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
+#define TclZipfs_Mount \
+ (tclStubsPtr->tclZipfs_Mount) /* 632 */
+#define TclZipfs_Unmount \
+ (tclStubsPtr->tclZipfs_Unmount) /* 633 */
+#define TclZipfs_TclLibrary \
+ (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */
+#define TclZipfs_MountBuffer \
+ (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */
+#define Tcl_FreeInternalRep \
+ (tclStubsPtr->tcl_FreeInternalRep) /* 636 */
+#define Tcl_InitStringRep \
+ (tclStubsPtr->tcl_InitStringRep) /* 637 */
+#define Tcl_FetchInternalRep \
+ (tclStubsPtr->tcl_FetchInternalRep) /* 638 */
+#define Tcl_StoreInternalRep \
+ (tclStubsPtr->tcl_StoreInternalRep) /* 639 */
+#define Tcl_HasStringRep \
+ (tclStubsPtr->tcl_HasStringRep) /* 640 */
+#define Tcl_IncrRefCount \
+ (tclStubsPtr->tcl_IncrRefCount) /* 641 */
+#define Tcl_DecrRefCount \
+ (tclStubsPtr->tcl_DecrRefCount) /* 642 */
+#define Tcl_IsShared \
+ (tclStubsPtr->tcl_IsShared) /* 643 */
+#define Tcl_LinkArray \
+ (tclStubsPtr->tcl_LinkArray) /* 644 */
+#define Tcl_GetIntForIndex \
+ (tclStubsPtr->tcl_GetIntForIndex) /* 645 */
+#define Tcl_UtfToUniChar \
+ (tclStubsPtr->tcl_UtfToUniChar) /* 646 */
+#define Tcl_UniCharToUtfDString \
+ (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */
+#define Tcl_UtfToUniCharDString \
+ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */
+#define Tcl_GetBytesFromObj \
+ (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */
/* Slot 650 is reserved */
/* Slot 651 is reserved */
/* Slot 652 is reserved */
/* Slot 653 is reserved */
-/* Slot 654 is reserved */
-/* Slot 655 is reserved */
-/* Slot 656 is reserved */
-/* Slot 657 is reserved */
-/* Slot 658 is reserved */
-/* Slot 659 is reserved */
-/* Slot 660 is reserved */
+#define Tcl_UtfCharComplete \
+ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */
+#define Tcl_UtfNext \
+ (tclStubsPtr->tcl_UtfNext) /* 655 */
+#define Tcl_UtfPrev \
+ (tclStubsPtr->tcl_UtfPrev) /* 656 */
+#define Tcl_UniCharIsUnicode \
+ (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 */
/* Slot 661 is reserved */
/* Slot 662 is reserved */
/* Slot 663 is reserved */
@@ -3927,24 +4092,38 @@ extern const TclStubs *tclStubsPtr;
/* Slot 665 is reserved */
/* Slot 666 is reserved */
/* Slot 667 is reserved */
-/* Slot 668 is reserved */
-/* Slot 669 is reserved */
-/* Slot 670 is reserved */
-/* Slot 671 is reserved */
-/* Slot 672 is reserved */
-/* Slot 673 is reserved */
-/* Slot 674 is reserved */
-/* Slot 675 is reserved */
+#define Tcl_UniCharLen \
+ (tclStubsPtr->tcl_UniCharLen) /* 668 */
+#define TclNumUtfChars \
+ (tclStubsPtr->tclNumUtfChars) /* 669 */
+#define TclGetCharLength \
+ (tclStubsPtr->tclGetCharLength) /* 670 */
+#define TclUtfAtIndex \
+ (tclStubsPtr->tclUtfAtIndex) /* 671 */
+#define TclGetRange \
+ (tclStubsPtr->tclGetRange) /* 672 */
+#define TclGetUniChar \
+ (tclStubsPtr->tclGetUniChar) /* 673 */
+#define Tcl_GetBool \
+ (tclStubsPtr->tcl_GetBool) /* 674 */
+#define Tcl_GetBoolFromObj \
+ (tclStubsPtr->tcl_GetBoolFromObj) /* 675 */
/* Slot 676 is reserved */
/* Slot 677 is reserved */
/* Slot 678 is reserved */
/* Slot 679 is reserved */
-/* Slot 680 is reserved */
-/* Slot 681 is reserved */
-/* Slot 682 is reserved */
-/* Slot 683 is reserved */
-/* Slot 684 is reserved */
-/* Slot 685 is reserved */
+#define Tcl_GetNumberFromObj \
+ (tclStubsPtr->tcl_GetNumberFromObj) /* 680 */
+#define Tcl_GetNumber \
+ (tclStubsPtr->tcl_GetNumber) /* 681 */
+#define Tcl_RemoveChannelMode \
+ (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
+#define Tcl_GetEncodingNulLength \
+ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
+#define Tcl_GetWideUIntFromObj \
+ (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */
+#define Tcl_DStringToObj \
+ (tclStubsPtr->tcl_DStringToObj) /* 685 */
/* Slot 686 is reserved */
/* Slot 687 is reserved */
#define TclUnusedStubEntry \
@@ -3962,32 +4141,29 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_GetStringResult
# undef Tcl_Init
# undef Tcl_SetPanicProc
-# undef Tcl_SetVar
+# undef Tcl_SetExitProc
# undef Tcl_ObjSetVar2
-# undef Tcl_StaticPackage
+# undef Tcl_StaticLibrary
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
-# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc))
-# define Tcl_SetVar(interp, varName, newValue, flags) \
- (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags))
# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
(tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
-#ifndef __cplusplus
-# undef Tcl_EventuallyFree
-# define Tcl_EventuallyFree \
- ((void (*)(void *,void *))(void *)(tclStubsPtr->tcl_EventuallyFree)) /* 132 */
-# undef Tcl_SetResult
-# define Tcl_SetResult \
- ((void (*)(Tcl_Interp *, char *, void *))(void *)(tclStubsPtr->tcl_SetResult)) /* 232 */
-#endif
#endif
#if defined(_WIN32) && defined(UNICODE)
-# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
+# if defined(TCL_NO_DEPRECATED)
+# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
+# else
+# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)((const char *)(arg))))
+# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg)))
+# endif
# define Tcl_MainEx Tcl_MainExW
- EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
+ EXTERN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
+#elif !defined(TCL_NO_DEPRECATED)
+# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)(arg)))
+# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg)))
#endif
#undef TCL_STORAGE_CLASS
@@ -4011,13 +4187,13 @@ extern const TclStubs *tclStubsPtr;
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj(intValue) \
- Tcl_NewIntObj((intValue)!=0)
+ Tcl_NewWideIntObj((intValue)!=0)
#undef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj(intValue, file, line) \
- Tcl_DbNewLongObj((intValue)!=0, file, line)
+ Tcl_DbNewWideIntObj((intValue)!=0, file, line)
#undef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj(objPtr, intValue) \
- Tcl_SetIntObj((objPtr), (intValue)!=0)
+ Tcl_SetWideIntObj(objPtr, (intValue)!=0)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
@@ -4039,6 +4215,53 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_UpVar
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
+#undef Tcl_AddErrorInfo
+#define Tcl_AddErrorInfo(interp, message) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE))
+#undef Tcl_AddObjErrorInfo
+#define Tcl_AddObjErrorInfo(interp, message, length) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
+#ifdef TCL_NO_DEPRECATED
+#undef Tcl_FreeResult
+#undef Tcl_AppendResultVA
+#undef Tcl_AppendStringsToObjVA
+#undef Tcl_SetErrorCodeVA
+#undef Tcl_VarEvalVA
+#undef Tcl_PanicVA
+#undef Tcl_GetStringResult
+#undef Tcl_GetDefaultEncodingDir
+#undef Tcl_SetDefaultEncodingDir
+#undef Tcl_UniCharNcmp
+#undef Tcl_EvalTokens
+#undef Tcl_UniCharNcasecmp
+#undef Tcl_UniCharCaseMatch
+#undef Tcl_GetMathFuncInfo
+#undef Tcl_ListMathFuncs
+#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
+#undef Tcl_Eval
+#define Tcl_Eval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0)
+#undef Tcl_GlobalEval
+#define Tcl_GlobalEval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
+#undef Tcl_SaveResult
+#undef Tcl_RestoreResult
+#undef Tcl_DiscardResult
+#undef Tcl_SetResult
+#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) { \
+ ckfree((char *)__result); \
+ } else { \
+ (*__freeProc)((char *)__result); \
+ } \
+ } \
+ } while(0)
+#endif /* TCL_NO_DEPRECATED */
#if defined(USE_TCL_STUBS)
# if defined(_WIN32) && defined(_WIN64)
@@ -4048,7 +4271,7 @@ extern const TclStubs *tclStubsPtr;
do { \
struct { \
Tcl_Time now; \
- __int64 reserved; \
+ long long reserved; \
} _t; \
_t.reserved = -1; \
tclStubsPtr->tcl_GetTime((&_t.now)); \
@@ -4066,20 +4289,14 @@ extern const TclStubs *tclStubsPtr;
* possible. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
-# undef Tcl_DbNewLongObj
# undef Tcl_GetLongFromObj
-# undef Tcl_NewLongObj
-# undef Tcl_SetLongObj
# undef Tcl_ExprLong
# undef Tcl_ExprLongObj
# undef Tcl_UniCharNcmp
# undef Tcl_UtfNcmp
# undef Tcl_UtfNcasecmp
# undef Tcl_UniCharNcasecmp
-# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))(void *)Tcl_DbNewWideIntObj)
-# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetWideIntFromObj)
-# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))(void *)Tcl_NewWideIntObj)
-# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))(void *)Tcl_SetWideIntObj)
+# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
@@ -4095,7 +4312,7 @@ extern const TclStubs *tclStubsPtr;
return result;
}
# define Tcl_UniCharNcmp(ucs,uct,n) \
- ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))(void *)tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
# define Tcl_UtfNcmp(s1,s2,n) \
((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
# define Tcl_UtfNcasecmp(s1,s2,n) \
@@ -4105,18 +4322,145 @@ extern const TclStubs *tclStubsPtr;
# endif
#endif
+#undef Tcl_GetString
+#undef Tcl_GetUnicode
+#define Tcl_GetString(objPtr) \
+ Tcl_GetStringFromObj(objPtr, NULL)
+#define Tcl_GetUnicode(objPtr) \
+ Tcl_GetUnicodeFromObj(objPtr, NULL)
+#undef Tcl_GetIndexFromObjStruct
+#undef Tcl_GetBooleanFromObj
+#undef Tcl_GetBoolean
+#ifdef __GNUC__
+ /* If this gives: "error: size of array ‘_boolVar’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */
+# define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}),
+#else
+# define TCLBOOLWARNING(boolPtr)
+#endif
+#if defined(USE_TCL_STUBS)
+#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
+ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
+#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
+ (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr))) : \
+ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#define Tcl_GetBoolean(interp, src, boolPtr) \
+ (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr))) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#else
+#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
+ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
+#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
+ (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr))) : \
+ Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#define Tcl_GetBoolean(interp, src, boolPtr) \
+ (sizeof(*(boolPtr)) >= sizeof(int) ? (TCLBOOLWARNING(boolPtr)Tcl_GetBoolean(interp, src, (int *)(boolPtr))) : \
+ Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
+#endif
+
+#undef Tcl_NewLongObj
+#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))
+#undef Tcl_NewIntObj
+#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
+#undef Tcl_DbNewLongObj
+#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
+#undef Tcl_SetIntObj
+#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
+#undef Tcl_SetLongObj
+#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
+#undef Tcl_BackgroundError
+#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
+#undef Tcl_StringMatch
+#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
+
+#if TCL_UTF_MAX < 4
+# undef Tcl_UniCharToUtfDString
+# 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
+#elif !defined(BUILD_tcl)
+# undef Tcl_NumUtfChars
+# define Tcl_NumUtfChars TclNumUtfChars
+# undef Tcl_GetCharLength
+# define Tcl_GetCharLength TclGetCharLength
+# undef Tcl_UtfAtIndex
+# define Tcl_UtfAtIndex TclUtfAtIndex
+# undef Tcl_GetRange
+# define Tcl_GetRange TclGetRange
+# undef Tcl_GetUniChar
+# define Tcl_GetUniChar TclGetUniChar
+#endif
+#if defined(USE_TCL_STUBS)
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, Tcl_Size, 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) \
+ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \
+ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
+#else /* !defined(USE_TCL_STUBS) */
+# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
+ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \
+ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
+# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
+ ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \
+ : (wchar_t *(*)(const char *, Tcl_Size, 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) \
+ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \
+ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len)
+#endif /* defined(USE_TCL_STUBS) */
+
/*
* Deprecated Tcl procedures:
*/
+#ifdef TCL_NO_DEPRECATED
+# undef Tcl_SavedResult
+#endif /* TCL_NO_DEPRECATED */
#undef Tcl_EvalObj
-#define Tcl_EvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),0)
+#define Tcl_EvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
-#define Tcl_GlobalEvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
-#define Tcl_CreateChild Tcl_CreateSlave
-#define Tcl_GetChild Tcl_GetSlave
-#define Tcl_GetParent Tcl_GetMaster
+#define Tcl_GlobalEvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
+
+#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS)
+#undef Tcl_Close
+#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
+#endif
+
+#undef TclUtfCharComplete
+#undef TclUtfNext
+#undef TclUtfPrev
+#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED)
+# undef Tcl_UtfCharComplete
+# undef Tcl_UtfNext
+# undef Tcl_UtfPrev
+# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete)
+# define Tcl_UtfNext (tclStubsPtr->tclUtfNext)
+# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev)
+#endif
+#define Tcl_CreateSlave Tcl_CreateChild
+#define Tcl_GetSlave Tcl_GetChild
+#define Tcl_GetMaster Tcl_GetParent
+
+#define Tcl_NRCallObjProc2 Tcl_NRCallObjProc
+#define Tcl_CreateObjCommand2 Tcl_CreateObjCommand
+#define Tcl_CreateObjTrace2 Tcl_CreateObjTrace
+#define Tcl_NRCreateCommand2 Tcl_NRCreateCommand
+
+/* TIP #660 */
+#define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 52e4224..9e0baea 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -4,14 +4,15 @@
* This file contains functions that implement the Tcl dict object type
* and its accessor command.
*
- * Copyright (c) 2002-2010 by Donal K. Fellows.
+ * Copyright © 2002-2010 Donal K. Fellows.
*
* 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 "tommath.h"
+#include "tclTomMath.h"
+#include <assert.h>
/*
* Forward declaration.
@@ -22,60 +23,44 @@ struct Dict;
* Prototypes for functions defined later in this file:
*/
-static void DeleteDict(struct Dict *dict);
-static int DictAppendCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictCreateCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictGetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictMergeCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictRemoveCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictReplaceCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictSetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictSizeCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictUnsetCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictUpdateCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictValuesCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int DictWithCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static void FreeDictInternalRep(Tcl_Obj *dictPtr);
-static void InvalidateDictChain(Tcl_Obj *dictObj);
-static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void UpdateStringOfDict(Tcl_Obj *dictPtr);
-static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
-static inline void InitChainTable(struct Dict *dict);
-static inline void DeleteChainTable(struct Dict *dict);
-static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
- Tcl_Obj *keyPtr, int *newPtr);
-static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
-static Tcl_NRPostProc FinalizeDictUpdate;
-static Tcl_NRPostProc FinalizeDictWith;
-static Tcl_ObjCmdProc DictForNRCmd;
-static Tcl_ObjCmdProc DictMapNRCmd;
-static Tcl_NRPostProc DictForLoopCallback;
-static Tcl_NRPostProc DictMapLoopCallback;
+static void DeleteDict(struct Dict *dict);
+static Tcl_ObjCmdProc DictAppendCmd;
+static Tcl_ObjCmdProc DictCreateCmd;
+static Tcl_ObjCmdProc DictExistsCmd;
+static Tcl_ObjCmdProc DictFilterCmd;
+static Tcl_ObjCmdProc DictGetCmd;
+static Tcl_ObjCmdProc DictGetDefCmd;
+static Tcl_ObjCmdProc DictIncrCmd;
+static Tcl_ObjCmdProc DictInfoCmd;
+static Tcl_ObjCmdProc DictKeysCmd;
+static Tcl_ObjCmdProc DictLappendCmd;
+static Tcl_ObjCmdProc DictMergeCmd;
+static Tcl_ObjCmdProc DictRemoveCmd;
+static Tcl_ObjCmdProc DictReplaceCmd;
+static Tcl_ObjCmdProc DictSetCmd;
+static Tcl_ObjCmdProc DictSizeCmd;
+static Tcl_ObjCmdProc DictUnsetCmd;
+static Tcl_ObjCmdProc DictUpdateCmd;
+static Tcl_ObjCmdProc DictValuesCmd;
+static Tcl_ObjCmdProc DictWithCmd;
+static Tcl_DupInternalRepProc DupDictInternalRep;
+static Tcl_FreeInternalRepProc FreeDictInternalRep;
+static void InvalidateDictChain(Tcl_Obj *dictObj);
+static Tcl_SetFromAnyProc SetDictFromAny;
+static Tcl_UpdateStringProc UpdateStringOfDict;
+static Tcl_AllocHashEntryProc AllocChainEntry;
+static inline void InitChainTable(struct Dict *dict);
+static inline void DeleteChainTable(struct Dict *dict);
+static inline Tcl_HashEntry * CreateChainEntry(struct Dict *dict,
+ Tcl_Obj *keyPtr, int *newPtr);
+static inline int DeleteChainEntry(struct Dict *dict,
+ Tcl_Obj *keyPtr);
+static Tcl_NRPostProc FinalizeDictUpdate;
+static Tcl_NRPostProc FinalizeDictWith;
+static Tcl_ObjCmdProc DictForNRCmd;
+static Tcl_ObjCmdProc DictMapNRCmd;
+static Tcl_NRPostProc DictForLoopCallback;
+static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
@@ -88,6 +73,9 @@ static const EnsembleImplMap implementationMap[] = {
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
+ {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0},
+ {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd,
+ NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
{"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
@@ -141,7 +129,7 @@ typedef struct Dict {
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
- int epoch; /* Epoch counter */
+ TCL_HASH_TYPE epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
@@ -149,13 +137,6 @@ typedef struct Dict {
} Dict;
/*
- * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
- * must be assignable as well as readable.
- */
-
-#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1)
-
-/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
@@ -168,6 +149,21 @@ const Tcl_ObjType tclDictType = {
SetDictFromAny /* setFromAnyProc */
};
+#define DictSetInternalRep(objPtr, dictRepPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (dictRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
+ } while (0)
+
+#define DictGetInternalRep(objPtr, dictRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
+ (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
@@ -226,7 +222,7 @@ typedef struct {
static Tcl_HashEntry *
AllocChainEntry(
- Tcl_HashTable *tablePtr,
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr)
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
@@ -235,7 +231,7 @@ AllocChainEntry(
cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry));
cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
- cPtr->entry.clientData = NULL;
+ Tcl_SetHashValue(&cPtr->entry, NULL);
cPtr->prevPtr = cPtr->nextPtr = NULL;
return &cPtr->entry;
@@ -363,10 +359,11 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = (Dict *)DICT(srcPtr);
- Dict *newDict = (Dict *)ckalloc(sizeof(Dict));
+ Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict));
ChainEntry *cPtr;
+ DictGetInternalRep(srcPtr, oldDict);
+
/*
* Copy values across from the old hash table.
*/
@@ -390,7 +387,7 @@ DupDictInternalRep(
* Initialise other fields.
*/
- newDict->epoch = 0;
+ newDict->epoch = 1;
newDict->chain = NULL;
newDict->refCount = 1;
@@ -398,9 +395,7 @@ DupDictInternalRep(
* Store in the object.
*/
- DICT(copyPtr) = newDict;
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- copyPtr->typePtr = &tclDictType;
+ DictSetInternalRep(copyPtr, newDict);
}
/*
@@ -425,12 +420,13 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = (Dict *)DICT(dictPtr);
+ Dict *dict;
+
+ DictGetInternalRep(dictPtr, dict);
if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
- dictPtr->typePtr = NULL;
}
/*
@@ -489,11 +485,11 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = (Dict *)DICT(dictPtr);
+ Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length;
- unsigned int bytesNeeded = 0;
+ TCL_HASH_TYPE bytesNeeded = 0;
const char *elem;
char *dst;
@@ -502,12 +498,17 @@ UpdateStringOfDict(
* is not exposed by any API function...
*/
- int numElems = dict->table.numEntries * 2;
+ int numElems;
+
+ DictGetInternalRep(dictPtr, dict);
+
+ assert (dict != NULL);
+
+ numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
- dictPtr->bytes = tclEmptyStringRep;
- dictPtr->length = 0;
+ Tcl_InitStringRep(dictPtr, NULL, 0);
return;
}
@@ -551,9 +552,8 @@ UpdateStringOfDict(
* Pass 2: copy into string rep buffer.
*/
- dictPtr->length = bytesNeeded - 1;
- dictPtr->bytes = (char *)ckalloc(bytesNeeded);
- dst = dictPtr->bytes;
+ dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
+ TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
@@ -567,7 +567,8 @@ UpdateStringOfDict(
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
- dictPtr->bytes[dictPtr->length] = '\0';
+ /* Last space overwrote the terminating NUL; cal T_ISR again to restore */
+ (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
ckfree(flagPtr);
@@ -611,12 +612,12 @@ SetDictFromAny(
* the conversion from lists to dictionaries.
*/
- if (objPtr->typePtr == &tclListType) {
+ if (TclHasInternalRep(objPtr, &tclListType)) {
int objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
- TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
}
@@ -634,7 +635,7 @@ SetDictFromAny(
* convert back.
*/
- (void) Tcl_GetString(objPtr);
+ (void) TclGetString(objPtr);
TclDecrRefCount(discardedValue);
}
@@ -649,7 +650,8 @@ SetDictFromAny(
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
- int elemSize, literal;
+ int elemSize;
+ int literal;
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
&elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
@@ -666,10 +668,14 @@ SetDictFromAny(
TclNewStringObj(keyPtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(keyPtr);
- keyPtr->bytes = (char *)ckalloc(elemSize + 1);
- keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
- keyPtr->bytes);
+ Tcl_InvalidateStringRep(keyPtr);
+ dst = Tcl_InitStringRep(keyPtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(keyPtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
@@ -682,10 +688,14 @@ SetDictFromAny(
TclNewStringObj(valuePtr, elemStart, elemSize);
} else {
/* Avoid double copy */
+ char *dst;
+
TclNewObj(valuePtr);
- valuePtr->bytes = (char *)ckalloc(elemSize + 1);
- valuePtr->length = TclCopyAndCollapse(elemSize, elemStart,
- valuePtr->bytes);
+ Tcl_InvalidateStringRep(valuePtr);
+ dst = Tcl_InitStringRep(valuePtr, NULL, elemSize);
+ TclOOM(dst, elemSize); /* Consider error */
+ (void)Tcl_InitStringRep(valuePtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
@@ -707,26 +717,40 @@ SetDictFromAny(
* Tcl_GetStringFromObj, to use that old internalRep.
*/
- TclFreeIntRep(objPtr);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(objPtr) = dict;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclDictType;
+ DictSetInternalRep(objPtr, dict);
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (void *)NULL);
}
errorInFindDictElement:
DeleteChainTable(dict);
ckfree(dict);
return TCL_ERROR;
}
+
+static Dict *
+GetDictFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr)
+{
+ Dict *dict;
+
+ DictGetInternalRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetInternalRep(dictPtr, dict);
+ }
+ return dict;
+}
/*
*----------------------------------------------------------------------
@@ -771,11 +795,13 @@ TclTraceDictPath(
Dict *dict, *newDict;
int i;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
- return NULL;
+ DictGetInternalRep(dictPtr, dict);
+ if (dict == NULL) {
+ if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ DictGetInternalRep(dictPtr, dict);
}
- dict = (Dict *)DICT(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -796,7 +822,7 @@ TclTraceDictPath(
"key \"%s\" not known in dictionary",
TclGetString(keyv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
- TclGetString(keyv[i]), NULL);
+ TclGetString(keyv[i]), (void *)NULL);
}
return NULL;
}
@@ -811,13 +837,17 @@ TclTraceDictPath(
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
- if (tmpObj->typePtr != &tclDictType
- && SetDictFromAny(interp, tmpObj) != TCL_OK) {
- return NULL;
+
+ DictGetInternalRep(tmpObj, newDict);
+
+ if (newDict == NULL) {
+ if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
+ }
}
}
- newDict = (Dict *)DICT(tmpObj);
+ DictGetInternalRep(tmpObj, newDict);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -825,7 +855,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = (Dict *)DICT(tmpObj);
+ DictGetInternalRep(tmpObj, newDict);
}
newDict->chain = dictPtr;
@@ -860,17 +890,24 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = (Dict *)DICT(dictObj);
+ Dict *dict;
+
+ DictGetInternalRep(dictObj, dict);
+ assert( dict != NULL);
do {
+ dict->refCount++;
TclInvalidateStringRep(dictObj);
+ TclFreeInternalRep(dictObj);
+ DictSetInternalRep(dictObj, dict);
+
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = (Dict *)DICT(dictObj);
+ DictGetInternalRep(dictObj, dict);
} while (dict != NULL);
}
@@ -908,16 +945,16 @@ Tcl_DictObjPut(
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
- dict = (Dict *)DICT(dictPtr);
+ TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
+ dict->refCount++;
+ TclFreeInternalRep(dictPtr)
+ DictSetInternalRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
@@ -959,13 +996,12 @@ Tcl_DictObjGet(
Dict *dict;
Tcl_HashEntry *hPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
*valuePtrPtr = NULL;
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1006,16 +1042,13 @@ Tcl_DictObjRemove(
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
if (DeleteChainEntry(dict, keyPtr)) {
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
dict->epoch++;
}
return TCL_OK;
@@ -1039,6 +1072,7 @@ Tcl_DictObjRemove(
*----------------------------------------------------------------------
*/
+#undef Tcl_DictObjSize
int
Tcl_DictObjSize(
Tcl_Interp *interp,
@@ -1047,12 +1081,11 @@ Tcl_DictObjSize(
{
Dict *dict;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1099,15 +1132,14 @@ Tcl_DictObjFirst(
Dict *dict;
ChainEntry *cPtr;
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, dictPtr);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
- searchPtr->epoch = -1;
+ searchPtr->epoch = 0;
*donePtr = 1;
} else {
*donePtr = 0;
@@ -1168,7 +1200,7 @@ Tcl_DictObjNext(
* If the search is done; we do no work.
*/
- if (searchPtr->epoch == -1) {
+ if (!searchPtr->epoch) {
*donePtr = 1;
return;
}
@@ -1225,8 +1257,8 @@ Tcl_DictObjDone(
{
Dict *dict;
- if (searchPtr->epoch != -1) {
- searchPtr->epoch = -1;
+ if (searchPtr->epoch) {
+ searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
DeleteDict(dict);
@@ -1278,7 +1310,8 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1335,7 +1368,8 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
+ DictGetInternalRep(dictPtr, dict);
+ assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1378,12 +1412,10 @@ Tcl_NewDictObj(void)
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetInternalRep(dictPtr, dict);
return dictPtr;
#endif
}
@@ -1415,12 +1447,12 @@ Tcl_NewDictObj(void)
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
-#ifdef TCL_MEM_DEBUG
Tcl_Obj *dictPtr;
Dict *dict;
@@ -1428,17 +1460,21 @@ Tcl_DbNewDictObj(
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
- dict->epoch = 0;
+ dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DICT(dictPtr) = dict;
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
- dictPtr->typePtr = &tclDictType;
+ DictSetInternalRep(dictPtr, dict);
return dictPtr;
+}
#else /* !TCL_MEM_DEBUG */
+Tcl_Obj *
+Tcl_DbNewDictObj(
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
return Tcl_NewDictObj();
-#endif
}
+#endif
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
@@ -1462,7 +1498,7 @@ Tcl_DbNewDictObj(
static int
DictCreateCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1512,7 +1548,7 @@ DictCreateCmd(
static int
DictGetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1578,7 +1614,7 @@ DictGetCmd(
"key \"%s\" not known in dictionary",
TclGetString(objv[objc-1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
- TclGetString(objv[objc-1]), NULL);
+ TclGetString(objv[objc-1]), (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
@@ -1588,6 +1624,71 @@ DictGetCmd(
/*
*----------------------------------------------------------------------
*
+ * DictGetDefCmd --
+ *
+ * This function implements the "dict getdef" and "dict getwithdefault"
+ * Tcl commands. See the user documentation for details on what it does,
+ * and TIP#342 for the formal specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictGetDefCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
+ Tcl_Obj *const *keyPath;
+ int numKeys;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Give the bits of arguments names for clarity.
+ */
+
+ dictPtr = objv[1];
+ keyPath = &objv[2];
+ numKeys = objc - 4; /* Number of keys in keyPath; there's always
+ * one extra key afterwards too. */
+ keyPtr = objv[objc - 2];
+ defaultPtr = objv[objc - 1];
+
+ /*
+ * Implement the getting-with-default operation.
+ */
+
+ dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath,
+ DICT_PATH_EXISTS);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ } else if (dictPtr == DICT_PATH_NON_EXISTENT) {
+ Tcl_SetObjResult(interp, defaultPtr);
+ } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
+ return TCL_ERROR;
+ } else if (valuePtr == NULL) {
+ Tcl_SetObjResult(interp, defaultPtr);
+ } else {
+ Tcl_SetObjResult(interp, valuePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DictReplaceCmd --
*
* This function implements the "dict replace" Tcl command. See the user
@@ -1605,7 +1706,7 @@ DictGetCmd(
static int
DictReplaceCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1619,16 +1720,13 @@ DictReplaceCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i+=2) {
Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
}
@@ -1656,7 +1754,7 @@ DictReplaceCmd(
static int
DictRemoveCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1670,16 +1768,13 @@ DictRemoveCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ if (GetDictFromObj(interp, dictPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
+ TclInvalidateStringRep(dictPtr);
for (i=2 ; i<objc ; i++) {
Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
@@ -1707,7 +1802,7 @@ DictRemoveCmd(
static int
DictMergeCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1730,8 +1825,7 @@ DictMergeCmd(
*/
targetObj = objv[1];
- if (targetObj->typePtr != &tclDictType
- && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ if (GetDictFromObj(interp, targetObj) == NULL) {
return TCL_ERROR;
}
@@ -1795,7 +1889,7 @@ DictMergeCmd(
static int
DictKeysCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1814,8 +1908,7 @@ DictKeysCmd(
* need. [Bug 1705778, leak K04]
*/
- if (objv[1]->typePtr != &tclDictType
- && SetDictFromAny(interp, objv[1]) != TCL_OK) {
+ if (GetDictFromObj(interp, objv[1]) == NULL) {
return TCL_ERROR;
}
@@ -1875,7 +1968,7 @@ DictKeysCmd(
static int
DictValuesCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1935,12 +2028,13 @@ DictValuesCmd(
static int
DictSizeCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- int result, size;
+ int result;
+ int size;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
@@ -1948,7 +2042,7 @@ DictSizeCmd(
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
}
return result;
}
@@ -1973,7 +2067,7 @@ DictSizeCmd(
static int
DictExistsCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1985,11 +2079,9 @@ DictExistsCmd(
return TCL_ERROR;
}
- dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2,
- DICT_PATH_EXISTS);
- if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT
- || Tcl_DictObjGet(interp, dictPtr, objv[objc-1],
- &valuePtr) != TCL_OK) {
+ dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS);
+ if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT ||
+ Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
@@ -2017,12 +2109,11 @@ DictExistsCmd(
static int
DictInfoCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Tcl_Obj *dictPtr;
Dict *dict;
char *statsStr;
@@ -2031,12 +2122,10 @@ DictInfoCmd(
return TCL_ERROR;
}
- dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType
- && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ dict = GetDictFromObj(interp, objv[1]);
+ if (dict == NULL) {
return TCL_ERROR;
}
- dict = (Dict *)DICT(dictPtr);
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2064,7 +2153,7 @@ DictInfoCmd(
static int
DictIncrCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2097,12 +2186,11 @@ DictIncrCmd(
* soon be no good.
*/
- char *saved = dictPtr->bytes;
Tcl_Obj *oldPtr = dictPtr;
- dictPtr->bytes = NULL;
- dictPtr = Tcl_DuplicateObj(dictPtr);
- oldPtr->bytes = saved;
+ TclNewObj(dictPtr);
+ TclInvalidateStringRep(dictPtr);
+ DupDictInternalRep(oldPtr, dictPtr);
}
if (valuePtr == NULL) {
/*
@@ -2129,7 +2217,7 @@ DictIncrCmd(
Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
}
} else {
- Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewWideIntObj(1));
}
} else {
/*
@@ -2186,7 +2274,7 @@ DictIncrCmd(
static int
DictLappendCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2240,7 +2328,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
- } else if (dictPtr->bytes != NULL) {
+ } else {
TclInvalidateStringRep(dictPtr);
}
@@ -2273,13 +2361,13 @@ DictLappendCmd(
static int
DictAppendCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
- int i, allocatedDict = 0;
+ int allocatedDict = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
@@ -2302,17 +2390,49 @@ DictAppendCmd(
return TCL_ERROR;
}
- if (valuePtr == NULL) {
- TclNewObj(valuePtr);
- } else if (Tcl_IsShared(valuePtr)) {
- valuePtr = Tcl_DuplicateObj(valuePtr);
- }
+ if ((objc > 3) || (valuePtr == NULL)) {
+ /* Only go through append activites when something will change. */
+ Tcl_Obj *appendObjPtr = NULL;
- for (i=3 ; i<objc ; i++) {
- Tcl_AppendObjToObj(valuePtr, objv[i]);
+ if (objc > 3) {
+ /* Something to append */
+
+ if (objc == 4) {
+ appendObjPtr = objv[3];
+ } else {
+ appendObjPtr = TclStringCat(interp, objc-3, objv+3,
+ TCL_STRING_IN_PLACE);
+ if (appendObjPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ if (appendObjPtr == NULL) {
+ /* => (objc == 3) => (valuePtr == NULL) */
+ TclNewObj(valuePtr);
+ } else if (valuePtr == NULL) {
+ valuePtr = appendObjPtr;
+ appendObjPtr = NULL;
+ }
+
+ if (appendObjPtr) {
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ }
+
+ Tcl_IncrRefCount(appendObjPtr);
+ Tcl_AppendObjToObj(valuePtr, appendObjPtr);
+ Tcl_DecrRefCount(appendObjPtr);
+ }
+
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
- Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+ /*
+ * Even if nothing changed, we still overwrite so that variable
+ * trace expectations are met.
+ */
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
@@ -2343,7 +2463,7 @@ DictAppendCmd(
static int
DictForNRCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2352,7 +2472,8 @@ DictForNRCmd(
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
Tcl_DictSearch *searchPtr;
- int varc, done;
+ int varc;
+ int done;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -2364,13 +2485,13 @@ DictForNRCmd(
* Parse arguments.
*/
- if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", (void *)NULL);
return TCL_ERROR;
}
searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
@@ -2383,7 +2504,7 @@ DictForNRCmd(
TclStackFree(interp, searchPtr);
return TCL_OK;
}
- TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[3];
@@ -2438,7 +2559,7 @@ DictForNRCmd(
static int
DictForLoopCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2538,7 +2659,7 @@ DictForLoopCallback(
static int
DictMapNRCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2559,13 +2680,13 @@ DictMapNRCmd(
* Parse arguments.
*/
- if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", (void *)NULL);
return TCL_ERROR;
}
storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
@@ -2585,7 +2706,7 @@ DictMapNRCmd(
return TCL_OK;
}
TclNewObj(storagePtr->accumulatorObj);
- TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ TclListObjGetElementsM(NULL, objv[1], &varc, &varv);
storagePtr->keyVarObj = varv[0];
storagePtr->valueVarObj = varv[1];
storagePtr->scriptObj = objv[3];
@@ -2643,7 +2764,7 @@ DictMapNRCmd(
static int
DictMapLoopCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2751,7 +2872,7 @@ DictMapLoopCallback(
static int
DictSetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2811,7 +2932,7 @@ DictSetCmd(
static int
DictUnsetCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2870,7 +2991,7 @@ DictUnsetCmd(
static int
DictFilterCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2885,7 +3006,8 @@ DictFilterCmd(
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
- int index, varc, done, result, satisfied;
+ int index, done, result, satisfied;
+ int varc;
const char *pattern;
if (objc < 3) {
@@ -2998,13 +3120,13 @@ DictFilterCmd(
* copying from the "dict for" implementation has occurred!
*/
- if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", (void *)NULL);
return TCL_ERROR;
}
keyVarObj = varv[0];
@@ -3155,14 +3277,15 @@ DictFilterCmd(
static int
DictUpdateCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
- int i, dummy;
+ int i;
+ int dummy;
if (objc < 5 || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -3185,7 +3308,7 @@ DictUpdateCmd(
}
if (objPtr == NULL) {
/* ??? */
- Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
+ Tcl_UnsetVar2(interp, TclGetString(objv[i+1]), NULL, 0);
} else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(dictPtr);
@@ -3209,7 +3332,7 @@ DictUpdateCmd(
static int
FinalizeDictUpdate(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3259,7 +3382,7 @@ FinalizeDictUpdate(
* an instruction to remove the key.
*/
- TclListObjGetElements(NULL, argsObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, argsObj, &objc, &objv);
for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
@@ -3313,7 +3436,7 @@ FinalizeDictUpdate(
static int
DictWithCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -3360,7 +3483,7 @@ DictWithCmd(
static int
FinalizeDictWith(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3383,7 +3506,7 @@ FinalizeDictWith(
state = Tcl_SaveInterpState(interp, result);
if (pathPtr != NULL) {
- TclListObjGetElements(NULL, pathPtr, &pathc, &pathv);
+ TclListObjGetElementsM(NULL, pathPtr, &pathc, &pathv);
} else {
pathc = 0;
pathv = NULL;
@@ -3589,7 +3712,7 @@ TclDictWithFinish(
* Now process our updates on the leaf dictionary.
*/
- TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
+ TclListObjGetElementsM(NULL, keysPtr, &keyc, &keyv);
for (i=0 ; i<keyc ; i++) {
valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
if (valPtr == NULL) {
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 9597beb..cc13ce9 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -4,9 +4,9 @@
* This file contains procedures that disassemble bytecode into either
* human-readable or Tcl-processable forms.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2013-2016 Donal K. Fellows.
+ * Copyright © 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2013-2016 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,16 +21,14 @@
* Prototypes for procedures defined later in this file:
*/
-static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
+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, int maxChars);
+ const char *stringPtr, Tcl_Size maxChars);
static void UpdateStringOfInstName(Tcl_Obj *objPtr);
/*
@@ -38,7 +36,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr);
* reporting of inner contexts in errorstack without string allocation.
*/
-static const Tcl_ObjType tclInstNameType = {
+static const Tcl_ObjType instNameType = {
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
@@ -46,12 +44,21 @@ static const Tcl_ObjType tclInstNameType = {
NULL, /* setFromAnyProc */
};
-/*
- * How to get the bytecode out of a Tcl_Obj.
- */
+#define InstNameSetInternalRep(objPtr, inst) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.wideValue = (inst); \
+ Tcl_StoreInternalRep((objPtr), &instNameType, &ir); \
+ } while (0)
+
+#define InstNameGetInternalRep(objPtr, inst) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &instNameType); \
+ assert(irPtr != NULL); \
+ (inst) = (size_t)irPtr->wideValue; \
+ } while (0)
-#define BYTECODE(objPtr) \
- ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
/*
*----------------------------------------------------------------------
@@ -123,10 +130,10 @@ GetLocationInformation(
void
TclPrintByteCodeObj(
- Tcl_Interp *interp, /* Used only for getting location info. */
+ TCL_UNUSED(Tcl_Interp *), /* Stuck with this in internal stubs */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr);
+ Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
@@ -186,12 +193,12 @@ TclPrintObject(
FILE *outFile, /* The file to print the source to. */
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
- int maxChars) /* Maximum number of chars to print. */
+ Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
- int length;
+ Tcl_Size length;
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
@@ -217,7 +224,7 @@ void
TclPrintSource(
FILE *outFile, /* The file to print the source to. */
const char *stringPtr, /* The string to print. */
- int maxChars) /* Maximum number of chars to print. */
+ Tcl_Size maxChars) /* Maximum number of chars to print. */
{
Tcl_Obj *bufferObj;
@@ -242,20 +249,23 @@ TclPrintSource(
static Tcl_Obj *
DisassembleByteCodeObj(
- Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
- Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, line;
+ Tcl_Size i;
+ Interp *iPtr;
Tcl_Obj *bufferObj, *fileObj;
- char ptrBuf1[20], ptrBuf2[20];
+
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+
+ iPtr = (Interp *) *codePtr->interpHandle;
TclNewObj(bufferObj);
- if (codePtr->refCount <= 0) {
+ if (!codePtr->refCount) {
return bufferObj; /* Already freed. */
}
@@ -267,22 +277,19 @@ DisassembleByteCodeObj(
* Print header lines describing the ByteCode.
*/
- snprintf(ptrBuf1, sizeof(ptrBuf1), "%p", codePtr);
- snprintf(ptrBuf2, sizeof(ptrBuf1), "%p", iPtr);
Tcl_AppendPrintfToObj(bufferObj,
- "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
- ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
- iPtr->compileEpoch);
+ "ByteCode %p, refCt %" TCL_SIZE_MODIFIER "u, epoch %" TCL_SIZE_MODIFIER "u, interp %p (epoch %" TCL_SIZE_MODIFIER "u)\n",
+ codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch);
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
GetLocationInformation(codePtr->procPtr, &fileObj, &line);
- if (line > -1 && fileObj != NULL) {
+ if (line >= 0 && fileObj != NULL) {
Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
- Tcl_GetString(fileObj), line);
+ TclGetString(fileObj), line);
}
Tcl_AppendPrintfToObj(bufferObj,
- "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ "\n Cmds %d, src %" TCL_SIZE_MODIFIER "u, inst %" TCL_SIZE_MODIFIER "u, litObjs %" TCL_SIZE_MODIFIER "u, aux %" TCL_SIZE_MODIFIER "u, stkDepth %" TCL_SIZE_MODIFIER "u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
codePtr->maxStackDepth,
@@ -294,13 +301,14 @@ DisassembleByteCodeObj(
#ifdef TCL_COMPILE_STATS
Tcl_AppendPrintfToObj(bufferObj,
- " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
- (unsigned long) codePtr->structureSize,
- (unsigned long) (TclOffset(ByteCode, localCachePtr)),
+ " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_SIZE_MODIFIER "u+litObj %"
+ TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_SIZE_MODIFIER "u\n",
+ codePtr->structureSize,
+ offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
- (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
- (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
- (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numLitObjects * sizeof(Tcl_Obj *),
+ codePtr->numExceptRanges*sizeof(ExceptionRange),
+ codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
@@ -312,19 +320,18 @@ DisassembleByteCodeObj(
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
- int numCompiledLocals = procPtr->numCompiledLocals;
+ Tcl_Size numCompiledLocals = procPtr->numCompiledLocals;
- snprintf(ptrBuf1, sizeof(ptrBuf1), "%p", procPtr);
Tcl_AppendPrintfToObj(bufferObj,
- " Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
- ptrBuf1, procPtr->refCount, procPtr->numArgs,
+ " Proc %p, refCt %" TCL_SIZE_MODIFIER "u, args %" TCL_SIZE_MODIFIER "u, compiled locals %" TCL_SIZE_MODIFIER "u\n",
+ procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
Tcl_AppendPrintfToObj(bufferObj,
- " slot %d%s%s%s%s%s%s", i,
+ " slot %" TCL_SIZE_MODIFIER "u%s%s%s%s%s%s", i,
(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
(localPtr->flags & VAR_ARRAY) ? ", array" : "",
(localPtr->flags & VAR_LINK) ? ", link" : "",
@@ -347,24 +354,24 @@ DisassembleByteCodeObj(
*/
if (codePtr->numExceptRanges > 0) {
- Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n",
+ Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "u, depth %" TCL_SIZE_MODIFIER "u:\n",
codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < codePtr->numExceptRanges; i++) {
ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i];
Tcl_AppendPrintfToObj(bufferObj,
- " %d: level %d, %s, pc %d-%d, ",
+ " %" TCL_SIZE_MODIFIER "u: level %" TCL_SIZE_MODIFIER "u, %s, pc %" TCL_SIZE_MODIFIER "u-%" TCL_SIZE_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 %d, break %d\n",
+ Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_SIZE_MODIFIER "u, break %" TCL_SIZE_MODIFIER "u\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
- Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+ Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_SIZE_MODIFIER "u\n",
rangePtr->catchOffset);
break;
default:
@@ -400,7 +407,7 @@ DisassembleByteCodeObj(
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
- if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
+ if (*codeDeltaNext == 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
@@ -410,7 +417,7 @@ DisassembleByteCodeObj(
}
codeOffset += delta;
- if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
+ if (*codeLengthNext == 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
@@ -419,7 +426,7 @@ DisassembleByteCodeObj(
codeLengthNext++;
}
- if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
+ if (*srcDeltaNext == 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
@@ -429,7 +436,7 @@ DisassembleByteCodeObj(
}
srcOffset += delta;
- if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
+ if (*srcLengthNext == 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
@@ -438,7 +445,7 @@ DisassembleByteCodeObj(
srcLengthNext++;
}
- Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
+ Tcl_AppendPrintfToObj(bufferObj, "%s%4" TCL_SIZE_MODIFIER "u: pc %d-%d, src %d-%d",
((i % 2)? " " : "\n "),
(i+1), codeOffset, (codeOffset + codeLen - 1),
srcOffset, (srcOffset + srcLen - 1));
@@ -459,7 +466,7 @@ DisassembleByteCodeObj(
codeOffset = srcOffset = 0;
pc = codeStart;
for (i = 0; i < numCmds; i++) {
- if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
+ if (*codeDeltaNext == 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
@@ -469,7 +476,7 @@ DisassembleByteCodeObj(
}
codeOffset += delta;
- if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
+ if (*srcDeltaNext == 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
@@ -479,7 +486,7 @@ DisassembleByteCodeObj(
}
srcOffset += delta;
- if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
+ if (*srcLengthNext == 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
@@ -497,7 +504,7 @@ DisassembleByteCodeObj(
pc += FormatInstruction(codePtr, pc, bufferObj);
}
- Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1);
+ Tcl_AppendPrintfToObj(bufferObj, " Command %" TCL_SIZE_MODIFIER "u: ", i+1);
PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
TclMin(srcLen, 55));
Tcl_AppendToObj(bufferObj, "\n", -1);
@@ -537,7 +544,7 @@ FormatInstruction(
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
- int localCt = procPtr ? procPtr->numCompiledLocals : 0;
+ Tcl_Size localCt = procPtr ? procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
char suffixBuffer[128]; /* Additional info to print after main opcode
* and immediates. */
@@ -559,7 +566,7 @@ FormatInstruction(
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
- Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_UINT4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -567,7 +574,7 @@ FormatInstruction(
snprintf(suffixBuffer+strlen(suffixBuffer), sizeof(suffixBuffer) - strlen(suffixBuffer),
", %u cmds start here", opnd);
}
- Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_OFFSET1:
opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
@@ -586,16 +593,16 @@ FormatInstruction(
case OPERAND_LIT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
suffixObj = codePtr->objArrayPtr[opnd];
- Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_LIT4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
suffixObj = codePtr->objArrayPtr[opnd];
- Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_AUX4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
- Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
auxPtr = &codePtr->auxDataArrayPtr[opnd];
break;
case OPERAND_IDX4:
@@ -618,20 +625,20 @@ FormatInstruction(
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
- Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
- (unsigned) opnd, localCt);
+ Tcl_Panic("FormatInstruction: bad local var index %u (%" TCL_SIZE_MODIFIER "u locals)",
+ opnd, localCt);
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
- snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", (unsigned) opnd);
+ snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", opnd);
} else {
snprintf(suffixBuffer, sizeof(suffixBuffer), "var ");
suffixSrc = localPtr->name;
}
}
- Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd);
break;
case OPERAND_SCLS1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
@@ -645,10 +652,10 @@ FormatInstruction(
}
if (suffixObj) {
const char *bytes;
- int length;
+ Tcl_Size length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
- bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
+ bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
@@ -683,7 +690,7 @@ TclGetInnerContext(
const unsigned char *pc,
Tcl_Obj **tosPtr)
{
- int objc = 0, off = 0;
+ Tcl_Size objc = 0;
Tcl_Obj *result;
Interp *iPtr = (Interp *) interp;
@@ -752,13 +759,13 @@ TclGetInnerContext(
iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL);
Tcl_IncrRefCount(result);
} else {
- int len;
+ Tcl_Size len;
/*
* Reset while keeping the list internalrep as much as possible.
*/
- TclListObjLength(interp, result, &len);
+ TclListObjLengthM(interp, result, &len);
Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
}
Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
@@ -766,7 +773,7 @@ TclGetInnerContext(
for (; objc>0 ; objc--) {
Tcl_Obj *objPtr;
- objPtr = tosPtr[1 - objc + off];
+ objPtr = tosPtr[1 - objc];
if (!objPtr) {
Tcl_Panic("InnerContext: bad tos -- appending null object");
}
@@ -801,9 +808,8 @@ TclNewInstNameObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- objPtr->typePtr = &tclInstNameType;
- objPtr->internalRep.longValue = (long) inst;
- objPtr->bytes = NULL;
+ TclInvalidateStringRep(objPtr);
+ InstNameSetInternalRep(objPtr, inst);
return objPtr;
}
@@ -822,20 +828,22 @@ static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
- int inst = objPtr->internalRep.longValue;
- char *s, buf[20];
- int len;
+ size_t inst; /* NOTE: We know this is really an unsigned char */
+ char *dst;
+
+ InstNameGetInternalRep(objPtr, inst);
- if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
- snprintf(buf, sizeof(buf), "inst_%d", inst);
- s = buf;
+ if (inst > LAST_INST_OPCODE) {
+ dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
+ TclOOM(dst, TCL_INTEGER_SPACE + 5);
+ snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
- s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
+ const char *s = tclInstructionTable[inst].name;
+ unsigned int len = strlen(s);
+ dst = Tcl_InitStringRep(objPtr, s, len);
+ TclOOM(dst, len);
}
- len = strlen(s);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, s, len + 1);
- objPtr->length = len;
}
/*
@@ -852,10 +860,10 @@ static void
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
- int maxChars) /* Maximum number of chars to print. */
+ Tcl_Size maxChars) /* Maximum number of chars to print. */
{
const char *p;
- int i = 0, len;
+ Tcl_Size i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
@@ -867,7 +875,7 @@ PrintSourceToObj(
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
- len = TclUtfToUCS4(p, &ucs4);
+ len = Tcl_UtfToUniChar(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
@@ -929,16 +937,16 @@ PrintSourceToObj(
static Tcl_Obj *
DisassembleByteCodeAsDicts(
- Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
- * procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
- ByteCode *codePtr = BYTECODE(objPtr);
+ ByteCode *codePtr;
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
- int codeOffset, codeLength, sourceOffset, sourceLength;
- int i, val, line;
+ int codeOffset, codeLength, sourceOffset, sourceLength, val, line;
+ Tcl_Size i;
+
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
@@ -955,7 +963,7 @@ DisassembleByteCodeAsDicts(
TclNewObj(variables);
if (codePtr->procPtr) {
- int localCount = codePtr->procPtr->numCompiledLocals;
+ Tcl_Size localCount = codePtr->procPtr->numCompiledLocals;
CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr;
for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) {
@@ -1028,7 +1036,7 @@ DisassembleByteCodeAsDicts(
val = TclGetUInt4AtPtr(opnd);
opnd += 4;
formatNumber:
- Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val));
+ Tcl_ListObjAppendElement(NULL, inst, Tcl_NewWideIntObj(val));
break;
case OPERAND_OFFSET1:
@@ -1096,7 +1104,7 @@ DisassembleByteCodeAsDicts(
Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
}
}
- Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst);
+ Tcl_DictObjPut(NULL, instructions, Tcl_NewWideIntObj(address), inst);
pc += instDesc->numBytes;
}
@@ -1138,14 +1146,14 @@ DisassembleByteCodeAsDicts(
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf(
- "type %s level %d from %d to %d break %d continue %d",
+ "type %s level %" TCL_SIZE_MODIFIER "u from %" TCL_SIZE_MODIFIER "u to %" TCL_SIZE_MODIFIER "u break %" TCL_SIZE_MODIFIER "u continue %" TCL_SIZE_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 %d from %d to %d catch %d",
+ "type %s level %" TCL_SIZE_MODIFIER "u from %" TCL_SIZE_MODIFIER "u to %" TCL_SIZE_MODIFIER "u catch %" TCL_SIZE_MODIFIER "u",
"catch", rangePtr->nestingLevel, rangePtr->codeOffset,
rangePtr->codeOffset + rangePtr->numCodeBytes - 1,
rangePtr->catchOffset));
@@ -1181,9 +1189,9 @@ DisassembleByteCodeAsDicts(
sourceLength = Decode(srcLenPtr);
TclNewObj(cmd);
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1),
- Tcl_NewIntObj(codeOffset));
+ Tcl_NewWideIntObj(codeOffset));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1),
- Tcl_NewIntObj(codeOffset + codeLength - 1));
+ Tcl_NewWideIntObj(codeOffset + codeLength - 1));
/*
* Convert byte offsets to character offsets; important if multibyte
@@ -1191,10 +1199,10 @@ DisassembleByteCodeAsDicts(
*/
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1),
- Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+ Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source,
sourceOffset)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1),
- Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source,
+ Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source,
sourceOffset + sourceLength - 1)));
Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1),
Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength));
@@ -1230,13 +1238,13 @@ DisassembleByteCodeAsDicts(
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1),
Tcl_NewStringObj(codePtr->nsPtr->fullName, -1));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1),
- Tcl_NewIntObj(codePtr->maxStackDepth));
+ Tcl_NewWideIntObj(codePtr->maxStackDepth));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
- Tcl_NewIntObj(codePtr->maxExceptDepth));
- if (line > -1) {
+ Tcl_NewWideIntObj(codePtr->maxExceptDepth));
+ if (line >= 0) {
Tcl_DictObjPut(NULL, description,
Tcl_NewStringObj("initiallinenumber", -1),
- Tcl_NewIntObj(line));
+ Tcl_NewWideIntObj(line));
}
if (file) {
Tcl_DictObjPut(NULL, description,
@@ -1279,6 +1287,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ ByteCode *codePtr;
Method *methodPtr;
if (objc < 2) {
@@ -1297,27 +1306,19 @@ Tcl_DisassembleObjCmd(
/*
* Compile (if uncompiled) and disassemble a lambda term.
- *
- * WARNING! Pokes inside the lambda objtype.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm");
return TCL_ERROR;
}
- if (objv[2]->typePtr == &tclLambdaType) {
- procPtr = (Proc *)objv[2]->internalRep.twoPtrValue.ptr1;
- }
- if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
- result = tclLambdaType.setFromAnyProc(interp, objv[2]);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = (Proc *)objv[2]->internalRep.twoPtrValue.ptr1;
+
+ procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr);
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
memset(&cmd, 0, sizeof(Command));
- nsObjPtr = (Tcl_Obj *)objv[2]->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
@@ -1343,7 +1344,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't a procedure", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -1367,8 +1368,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if ((objv[2]->typePtr != &tclByteCodeType)
- && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+
+ if (!TclHasInternalRep(objv[2], &tclByteCodeType) && (TCL_OK
+ != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) {
return TCL_ERROR;
}
codeObjPtr = objv[2];
@@ -1392,7 +1394,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -1402,7 +1404,7 @@ Tcl_DisassembleObjCmd(
"\"%s\" has no defined constructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "CONSRUCTOR", NULL);
+ "CONSRUCTOR", (void *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
@@ -1410,7 +1412,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", NULL);
+ "METHODTYPE", (void *)NULL);
return TCL_ERROR;
}
@@ -1418,7 +1420,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1457,7 +1459,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -1467,7 +1469,7 @@ Tcl_DisassembleObjCmd(
"\"%s\" has no defined destructor",
TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "DESRUCTOR", NULL);
+ "DESRUCTOR", (void *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod(methodPtr);
@@ -1475,7 +1477,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of destructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", NULL);
+ "METHODTYPE", (void *)NULL);
return TCL_ERROR;
}
@@ -1483,7 +1485,7 @@ Tcl_DisassembleObjCmd(
* Compile if necessary.
*/
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1522,11 +1524,11 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
- (char *) objv[3]);
+ (char *)objv[3]);
goto methodBody;
case DISAS_OBJECT_METHOD:
if (objc != 4) {
@@ -1545,7 +1547,7 @@ Tcl_DisassembleObjCmd(
if (oPtr->methodsPtr == NULL) {
goto unknownMethod;
}
- hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]);
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)objv[3]);
/*
* Compile (if necessary) and disassemble a method body.
@@ -1557,7 +1559,7 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[3]), NULL);
+ TclGetString(objv[3]), (void *)NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
@@ -1565,10 +1567,10 @@ Tcl_DisassembleObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "METHODTYPE", NULL);
+ "METHODTYPE", (void *)NULL);
return TCL_ERROR;
}
- if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) {
Command cmd;
/*
@@ -1596,19 +1598,21 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
+ ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr);
+
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
- "BYTECODE", NULL);
+ "BYTECODE", (void *)NULL);
return TCL_ERROR;
}
- if (PTR2INT(clientData)) {
+ if (clientData) {
Tcl_SetObjResult(interp,
- DisassembleByteCodeAsDicts(interp, codeObjPtr));
+ DisassembleByteCodeAsDicts(codeObjPtr));
} else {
Tcl_SetObjResult(interp,
- DisassembleByteCodeObj(interp, codeObjPtr));
+ DisassembleByteCodeObj(codeObjPtr));
}
return TCL_OK;
}
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index ba9f811..262dd01 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -3,13 +3,14 @@
*
* Contains the implementation of the encoding conversion package.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 1996-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.
*/
#include "tclInt.h"
+#include <assert.h>
typedef size_t (LengthProc)(const char *src);
@@ -33,20 +34,22 @@ typedef struct {
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
- int nullSize; /* Number of 0x00 bytes that signify
+ void *clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion functions. */
+ Tcl_Size nullSize; /* Number of 0x00 bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
- * negative. This number can be 1 or 2. */
- ClientData clientData; /* Arbitrary value associated with encoding
- * type. Passed to conversion functions. */
+ * negative. This number can be 1, 2, or 4. */
LengthProc *lengthProc; /* Function to compute length of
* null-terminated strings in this encoding.
* If nullSize is 1, this is strlen; if
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
- * terminated string. */
- int refCount; /* Number of uses of this structure. */
+ * terminated string; if nullSize is 4, this
+ * is a function that returns the number of
+ * bytes in a 0x00000000 terminated string. */
+ size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -183,6 +186,30 @@ TCL_DECLARE_MUTEX(encodingMutex)
static Tcl_Encoding defaultEncoding = NULL;
static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;
+Tcl_Encoding tclUtf8Encoding = NULL;
+
+/*
+ * Names of encoding profiles and corresponding integer values.
+ * Keep alphabetical order for error messages.
+ */
+static const struct TclEncodingProfiles {
+ const char *name;
+ int value;
+} encodingProfiles[] = {
+ {"replace", TCL_ENCODING_PROFILE_REPLACE},
+ {"strict", TCL_ENCODING_PROFILE_STRICT},
+ {"tcl8", TCL_ENCODING_PROFILE_TCL8},
+};
+#define PROFILE_STRICT(flags_) \
+ ((flags_) & TCL_ENCODING_PROFILE_STRICT)
+
+#define PROFILE_REPLACE(flags_) \
+ ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) && !PROFILE_STRICT(flags_))
+
+#define UNICODE_REPLACE_CHAR ((Tcl_UniChar)0xFFFD)
+#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800)
+#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800)
+#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00)
/*
* The following variable is used in the sparse matrix code for a
@@ -214,51 +241,19 @@ static Tcl_Encoding LoadEscapeEncoding(const char *name,
static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp,
const char *name);
static Tcl_EncodingFreeProc TableFreeProc;
-static int TableFromUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int TableToUtfProc(ClientData clientData, const char *src,
- int srcLen, int flags, Tcl_EncodingState *statePtr,
- char *dst, int dstLen, int *srcReadPtr,
- int *dstWrotePtr, int *dstCharsPtr);
+static Tcl_EncodingConvertProc TableFromUtfProc;
+static Tcl_EncodingConvertProc TableToUtfProc;
static size_t unilen(const char *src);
-static int UnicodeToUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int UtfToUnicodeProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int UtfToUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr, int pureNullMode);
-static int UtfIntToUtfExtProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int UtfExtToUtfIntProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int Iso88591FromUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst, int dstLen,
- int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
-static int Iso88591ToUtfProc(ClientData clientData,
- const char *src, int srcLen, int flags,
- Tcl_EncodingState *statePtr, char *dst,
- int dstLen, int *srcReadPtr, int *dstWrotePtr,
- int *dstCharsPtr);
+static size_t unilen4(const char *src);
+static Tcl_EncodingConvertProc Utf32ToUtfProc;
+static Tcl_EncodingConvertProc UtfToUtf32Proc;
+static Tcl_EncodingConvertProc Utf16ToUtfProc;
+static Tcl_EncodingConvertProc UtfToUtf16Proc;
+static Tcl_EncodingConvertProc UtfToUcs2Proc;
+static Tcl_EncodingConvertProc UtfToUtfProc;
+static Tcl_EncodingConvertProc Iso88591FromUtfProc;
+static Tcl_EncodingConvertProc Iso88591ToUtfProc;
+
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
@@ -267,8 +262,28 @@ static int Iso88591ToUtfProc(ClientData clientData,
*/
static const Tcl_ObjType encodingType = {
- "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL
+ "encoding",
+ FreeEncodingInternalRep,
+ DupEncodingInternalRep,
+ NULL,
+ NULL
};
+
+#define EncodingSetInternalRep(objPtr, encoding) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (encoding); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &encodingType, &ir); \
+ } while (0)
+
+#define EncodingGetInternalRep(objPtr, encoding) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep ((objPtr), &encodingType); \
+ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -295,17 +310,16 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
+ Tcl_Encoding encoding;
const char *name = TclGetString(objPtr);
- if (objPtr->typePtr != &encodingType) {
- Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
-
+ EncodingGetInternalRep(objPtr, encoding);
+ if (encoding == NULL) {
+ encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = encoding;
- objPtr->typePtr = &encodingType;
+ EncodingSetInternalRep(objPtr, encoding);
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -325,8 +339,10 @@ static void
FreeEncodingInternalRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding((Tcl_Encoding)objPtr->internalRep.twoPtrValue.ptr1);
- objPtr->typePtr = NULL;
+ Tcl_Encoding encoding;
+
+ EncodingGetInternalRep(objPtr, encoding);
+ Tcl_FreeEncoding(encoding);
}
/*
@@ -344,7 +360,8 @@ DupEncodingInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr));
+ EncodingSetInternalRep(dupPtr, encoding);
}
/*
@@ -382,9 +399,9 @@ int
Tcl_SetEncodingSearchPath(
Tcl_Obj *searchPath)
{
- int dummy;
+ Tcl_Size dummy;
- if (TCL_ERROR == TclListObjLength(NULL, searchPath, &dummy)) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) {
return TCL_ERROR;
}
TclSetProcessGlobalValue(&encodingSearchPath, searchPath, NULL);
@@ -429,9 +446,9 @@ void
TclSetLibraryPath(
Tcl_Obj *path)
{
- int dummy;
+ Tcl_Size dummy;
- if (TCL_ERROR == TclListObjLength(NULL, path, &dummy)) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, path, &dummy)) {
return;
}
TclSetProcessGlobalValue(&libraryPath, path, NULL);
@@ -465,22 +482,22 @@ TclSetLibraryPath(
static void
FillEncodingFileMap(void)
{
- int i, numDirs = 0;
+ Tcl_Size i, numDirs = 0;
Tcl_Obj *map, *searchPath;
searchPath = Tcl_GetEncodingSearchPath();
Tcl_IncrRefCount(searchPath);
- TclListObjLength(NULL, searchPath, &numDirs);
+ TclListObjLengthM(NULL, searchPath, &numDirs);
map = Tcl_NewDictObj();
Tcl_IncrRefCount(map);
- for (i = numDirs-1; i >= 0; i--) {
+ 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.
*/
- int j, numFiles;
+ Tcl_Size j, numFiles;
Tcl_Obj *directory, *matchFileList;
Tcl_Obj **filev;
Tcl_GlobTypeData readableFiles = {
@@ -494,7 +511,7 @@ FillEncodingFileMap(void)
Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc",
&readableFiles);
- TclListObjGetElements(NULL, matchFileList, &numFiles, &filev);
+ TclListObjGetElementsM(NULL, matchFileList, &numFiles, &filev);
for (j=0; j<numFiles; j++) {
Tcl_Obj *encodingName, *fileObj;
@@ -529,6 +546,17 @@ FillEncodingFileMap(void)
*---------------------------------------------------------------------------
*/
+/*
+ * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS
+ * DEFINED IN tcl.h (TCL_ENCODING_* et al). Be cognizant of this
+ * when adding bits. TODO - should really be defined in a single file.
+ *
+ * To prevent conflicting bits, only define bits within 0xff00 mask here.
+ */
+#define TCL_ENCODING_LE 0x100 /* Used to distinguish LE/BE variants */
+#define ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */
+#define ENCODING_INPUT 0x400 /* For UTF-8/CESU-8 encoding, means external -> internal */
+
void
TclInitEncodingSubsystem(void)
{
@@ -540,12 +568,16 @@ TclInitEncodingSubsystem(void)
char c;
short s;
} isLe;
+ int leFlags;
if (encodingsInitialized) {
return;
}
+ /* Note: This DEPENDS on TCL_ENCODING_LE being defined in least sig byte */
isLe.s = 1;
+ leFlags = isLe.c ? TCL_ENCODING_LE : 0;
+
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
@@ -556,7 +588,7 @@ TclInitEncodingSubsystem(void)
* properly formed stream.
*/
- type.encodingName = "identity";
+ type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
@@ -565,21 +597,63 @@ TclInitEncodingSubsystem(void)
tclIdentityEncoding = Tcl_CreateEncoding(&type);
type.encodingName = "utf-8";
- type.toUtfProc = UtfExtToUtfIntProc;
- type.fromUtfProc = UtfIntToUtfExtProc;
+ type.toUtfProc = UtfToUtfProc;
+ type.fromUtfProc = UtfToUtfProc;
type.freeProc = NULL;
type.nullSize = 1;
+ type.clientData = INT2PTR(ENCODING_UTF);
+ tclUtf8Encoding = Tcl_CreateEncoding(&type);
type.clientData = NULL;
+ type.encodingName = "cesu-8";
Tcl_CreateEncoding(&type);
- type.encodingName = "unicode";
- type.toUtfProc = UnicodeToUtfProc;
- type.fromUtfProc = UtfToUnicodeProc;
+ type.toUtfProc = Utf16ToUtfProc;
+ type.fromUtfProc = UtfToUcs2Proc;
type.freeProc = NULL;
type.nullSize = 2;
- type.clientData = INT2PTR(isLe.c);
+ type.encodingName = "ucs-2le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2be";
+ type.clientData = NULL;
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "ucs-2";
+ type.clientData = INT2PTR(leFlags);
+ Tcl_CreateEncoding(&type);
+
+ type.toUtfProc = Utf32ToUtfProc;
+ type.fromUtfProc = UtfToUtf32Proc;
+ type.freeProc = NULL;
+ type.nullSize = 4;
+ type.encodingName = "utf-32le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-32be";
+ type.clientData = NULL;
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-32";
+ type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
+ type.toUtfProc = Utf16ToUtfProc;
+ type.fromUtfProc = UtfToUtf16Proc;
+ type.freeProc = NULL;
+ type.nullSize = 2;
+ type.encodingName = "utf-16le";
+ type.clientData = INT2PTR(TCL_ENCODING_LE);
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16be";
+ type.clientData = NULL;
+ Tcl_CreateEncoding(&type);
+ type.encodingName = "utf-16";
+ type.clientData = INT2PTR(leFlags);
+ Tcl_CreateEncoding(&type);
+
+#ifndef TCL_NO_DEPRECATED
+ type.encodingName = "unicode";
+ Tcl_CreateEncoding(&type);
+#endif
+
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
@@ -650,6 +724,8 @@ TclFinalizeEncodingSubsystem(void)
defaultEncoding = NULL;
FreeEncoding(tclIdentityEncoding);
tclIdentityEncoding = NULL;
+ FreeEncoding(tclUtf8Encoding);
+ tclUtf8Encoding = NULL;
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
@@ -686,13 +762,14 @@ TclFinalizeEncodingSubsystem(void)
*-------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
int numDirs;
Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath();
- TclListObjLength(NULL, searchPath, &numDirs);
+ TclListObjLengthM(NULL, searchPath, &numDirs);
if (numDirs == 0) {
return NULL;
}
@@ -723,12 +800,13 @@ Tcl_SetDefaultEncodingDir(
const char *path)
{
Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath();
- Tcl_Obj *directory = Tcl_NewStringObj(path, -1);
+ Tcl_Obj *directory = Tcl_NewStringObj(path, TCL_INDEX_NONE);
searchPath = Tcl_DuplicateObj(searchPath);
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
+#endif
/*
*-------------------------------------------------------------------------
@@ -834,9 +912,6 @@ FreeEncoding(
if (encodingPtr == NULL) {
return;
}
- if (encodingPtr->refCount<=0) {
- Tcl_Panic("FreeEncoding: refcount problem !!!");
- }
if (encodingPtr->refCount-- <= 1) {
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
@@ -921,7 +996,7 @@ Tcl_GetEncodingNames(
Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
Tcl_CreateHashEntry(&table,
- Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
+ Tcl_NewStringObj(encodingPtr->name, TCL_INDEX_NONE), &dummy);
}
Tcl_MutexUnlock(&encodingMutex);
@@ -951,6 +1026,33 @@ Tcl_GetEncodingNames(
}
/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetEncodingNulLength --
+ *
+ * Given an encoding, return the number of nul bytes used for the
+ * string termination.
+ *
+ * Results:
+ * The number of nul bytes used for the string termination.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Size
+Tcl_GetEncodingNulLength(
+ Tcl_Encoding encoding)
+{
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+
+ return ((Encoding *) encoding)->nullSize;
+}
+
+/*
*------------------------------------------------------------------------
*
* Tcl_SetSystemEncoding --
@@ -1035,9 +1137,26 @@ Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
+ Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
+ encodingPtr->name = NULL;
+ encodingPtr->toUtfProc = typePtr->toUtfProc;
+ encodingPtr->fromUtfProc = typePtr->fromUtfProc;
+ encodingPtr->freeProc = typePtr->freeProc;
+ encodingPtr->nullSize = typePtr->nullSize;
+ encodingPtr->clientData = typePtr->clientData;
+ if (typePtr->nullSize == 2) {
+ encodingPtr->lengthProc = (LengthProc *) unilen;
+ } else if (typePtr->nullSize == 4) {
+ encodingPtr->lengthProc = (LengthProc *) unilen4;
+ } else {
+ encodingPtr->lengthProc = (LengthProc *) strlen;
+ }
+ encodingPtr->refCount = 1;
+ encodingPtr->hPtr = NULL;
+
+ if (typePtr->encodingName) {
Tcl_HashEntry *hPtr;
int isNew;
- Encoding *encodingPtr;
char *name;
Tcl_MutexLock(&encodingMutex);
@@ -1048,30 +1167,17 @@ Tcl_CreateEncoding(
* reference goes away.
*/
- encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
- encodingPtr->hPtr = NULL;
+ Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr);
+ replaceMe->hPtr = NULL;
}
name = (char *)ckalloc(strlen(typePtr->encodingName) + 1);
-
- encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
encodingPtr->name = strcpy(name, typePtr->encodingName);
- encodingPtr->toUtfProc = typePtr->toUtfProc;
- encodingPtr->fromUtfProc = typePtr->fromUtfProc;
- encodingPtr->freeProc = typePtr->freeProc;
- encodingPtr->nullSize = typePtr->nullSize;
- encodingPtr->clientData = typePtr->clientData;
- if (typePtr->nullSize == 1) {
- encodingPtr->lengthProc = (LengthProc *) strlen;
- } else {
- encodingPtr->lengthProc = (LengthProc *) unilen;
- }
- encodingPtr->refCount = 1;
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
-
+ }
return (Tcl_Encoding) encodingPtr;
}
@@ -1101,24 +1207,99 @@ Tcl_ExternalToUtfDString(
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
- int srcLen, /* Source string length in bytes, or < 0 for
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+ Tcl_ExternalToUtfDStringEx(
+ NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
+ return Tcl_DStringValue(dstPtr);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_ExternalToUtfDStringEx --
+ *
+ * Convert a source buffer from the specified encoding into UTF-8.
+ * The parameter flags controls the behavior, if any of the bytes in
+ * the source buffer are invalid or cannot be represented in utf-8.
+ * Possible flags values:
+ * target encoding. It should be composed by OR-ing the following:
+ * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT}
+ *
+ * Results:
+ * The return value is one of
+ * TCL_OK: success. Converted string in *dstPtr
+ * TCL_ERROR: error in passed parameters. Error message in interp
+ * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
+ * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
+ * TCL_CONVERT_UNKNOWN: source contained a character that could not
+ * be represented in target encoding.
+ *
+ * Side effects:
+ *
+ * TCL_OK: The converted bytes are stored in the DString and NUL
+ * terminated in an encoding-specific manner.
+ * TCL_ERROR: an error, message is stored in the interp if not NULL.
+ * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
+ * in the interpreter (if not NULL). If errorLocPtr is not NULL,
+ * no error message is stored as it is expected the caller is
+ * interested in whatever is decoded so far and not treating this
+ * as an error condition.
+ *
+ * In addition, *dstPtr is always initialized and must be cleared
+ * by the caller irrespective of the return code.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_ExternalToUtfDStringEx(
+ Tcl_Interp *interp, /* For error messages. May be NULL. */
+ Tcl_Encoding encoding, /* The encoding for the source string, or NULL
+ * for the default system encoding. */
+ const char *src, /* Source string in specified encoding. */
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
+ * encoding-specific string length. */
+ int flags, /* Conversion control flags. */
+ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the
+ * converted string is stored. */
+ Tcl_Size *errorLocPtr) /* Where to store the error location
+ (or TCL_INDEX_NONE if no error). May
+ be NULL. */
+{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
- int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ int result, srcRead, dstWrote, dstChars;
+ Tcl_Size dstLen, soFar;
+ const char *srcStart = src;
+ /* DO FIRST - Must always be initialized before returning */
Tcl_DStringInit(dstPtr);
+
+ if (flags & (TCL_ENCODING_START|TCL_ENCODING_END)) {
+ /* TODO - what other flags are illegal? - See TIP 656 */
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj(
+ "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.",
+ TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", (void *)NULL);
+ errno = EINVAL;
+ return TCL_ERROR;
+ }
+
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
- encodingPtr = (Encoding *) encoding;
+ encodingPtr = (Encoding *)encoding;
if (src == NULL) {
srcLen = 0;
@@ -1126,20 +1307,51 @@ Tcl_ExternalToUtfDString(
srcLen = encodingPtr->lengthProc(src);
}
- flags = TCL_ENCODING_START | TCL_ENCODING_END;
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
+ if (encodingPtr->toUtfProc == UtfToUtfProc) {
+ flags |= ENCODING_INPUT;
+ }
while (1) {
- result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
- flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars);
+ result = encodingPtr->toUtfProc(encodingPtr->clientData, src,
+ srcLen, flags, &state, dst, dstLen,
+ &srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ src += srcRead;
if (result != TCL_CONVERT_NOSPACE) {
+ Tcl_Size nBytesProcessed = (src - srcStart);
+
Tcl_DStringSetLength(dstPtr, soFar);
- return Tcl_DStringValue(dstPtr);
+ if (errorLocPtr) {
+ /*
+ * Do not write error message into interpreter if caller
+ * wants to know error location.
+ */
+ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed;
+ } else {
+ /* Caller wants error message on failure */
+ if (result != TCL_OK && interp != NULL) {
+ char buf[TCL_INTEGER_SPACE];
+ snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "u", nBytesProcessed);
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("unexpected byte sequence starting at index %"
+ TCL_SIZE_MODIFIER "u: '\\x%02X'",
+ nBytesProcessed,
+ UCHAR(srcStart[nBytesProcessed])));
+ Tcl_SetErrorCode(
+ interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL);
+ }
+ }
+ if (result != TCL_OK) {
+ errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
+ }
+ return result;
}
+ /* Expand space and continue */
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -1170,11 +1382,11 @@ Tcl_ExternalToUtfDString(
int
Tcl_ExternalToUtf(
- Tcl_Interp *interp, /* Interp for error return, if not NULL. */
+ TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
- int srcLen, /* Source string length in bytes, or < 0 for
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -1184,7 +1396,7 @@ Tcl_ExternalToUtf(
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string is
* stored. */
- int dstLen, /* The maximum length of output buffer in
+ Tcl_Size dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
@@ -1238,7 +1450,7 @@ Tcl_ExternalToUtf(
}
/*
* If there are any null characters in the middle of the buffer,
- * they will converted to the UTF-8 null character (\xC080). To get
+ * they will converted to the UTF-8 null character (\xC0\x80). To get
* the actual \0 at the end of the destination buffer, we need to
* append it manually. First make room for it...
*/
@@ -1249,6 +1461,9 @@ Tcl_ExternalToUtf(
return TCL_CONVERT_NOSPACE;
}
}
+ if (encodingPtr->toUtfProc == UtfToUtfProc) {
+ flags |= ENCODING_INPUT;
+ }
do {
Tcl_EncodingState savedState = *statePtr;
@@ -1258,7 +1473,7 @@ Tcl_ExternalToUtf(
if (*dstCharsPtr <= maxChars) {
break;
}
- dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1);
+ dstLen = TclUtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1);
*statePtr = savedState;
} while (1);
if (!noTerminate) {
@@ -1295,17 +1510,91 @@ Tcl_UtfToExternalDString(
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
- int srcLen, /* Source string length in bytes, or < 0 for
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
+ Tcl_UtfToExternalDStringEx(
+ NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
+ return Tcl_DStringValue(dstPtr);
+}
+
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_UtfToExternalDStringEx --
+ *
+ * Convert a source buffer from UTF-8 to the specified encoding.
+ * The parameter flags controls the behavior, if any of the bytes in
+ * the source buffer are invalid or cannot be represented in the
+ * target encoding. It should be composed by OR-ing the following:
+ * - *At most one* of TCL_ENCODING_PROFILE_*
+ *
+ * Results:
+ * The return value is one of
+ * TCL_OK: success. Converted string in *dstPtr
+ * TCL_ERROR: error in passed parameters. Error message in interp
+ * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence
+ * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition
+ * TCL_CONVERT_UNKNOWN: source contained a character that could not
+ * be represented in target encoding.
+ *
+ * Side effects:
+ *
+ * TCL_OK: The converted bytes are stored in the DString and NUL
+ * terminated in an encoding-specific manner
+ * TCL_ERROR: an error, message is stored in the interp if not NULL.
+ * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
+ * in the interpreter (if not NULL). If errorLocPtr is not NULL,
+ * no error message is stored as it is expected the caller is
+ * interested in whatever is decoded so far and not treating this
+ * as an error condition.
+ *
+ * In addition, *dstPtr is always initialized and must be cleared
+ * by the caller irrespective of the return code.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToExternalDStringEx(
+ Tcl_Interp *interp, /* For error messages. May be NULL. */
+ Tcl_Encoding encoding, /* The encoding for the converted string, or
+ * NULL for the default system encoding. */
+ const char *src, /* Source string in UTF-8. */
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ int flags, /* Conversion control flags. */
+ Tcl_DString *dstPtr, /* Uninitialized or free DString in which the
+ * converted string is stored. */
+ Tcl_Size *errorLocPtr) /* Where to store the error location
+ (or TCL_INDEX_NONE if no error). May
+ be NULL. */
+{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
- int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+ int result, srcRead, dstWrote, dstChars;
+ const char *srcStart = src;
+ Tcl_Size dstLen, soFar;
+ /* DO FIRST - must always be initialized on return */
Tcl_DStringInit(dstPtr);
+
+ if (flags & (TCL_ENCODING_START|TCL_ENCODING_END)) {
+ /* TODO - what other flags are illegal? - See TIP 656 */
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj(
+ "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.",
+ TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", (void *)NULL);
+ errno = EINVAL;
+ return TCL_ERROR;
+ }
+
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
@@ -1319,23 +1608,53 @@ Tcl_UtfToExternalDString(
} else if (srcLen < 0) {
srcLen = strlen(src);
}
- flags = TCL_ENCODING_START | TCL_ENCODING_END;
+
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
- srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
- &dstChars);
+ srcLen, flags, &state, dst, dstLen,
+ &srcRead, &dstWrote, &dstChars);
soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ src += srcRead;
if (result != TCL_CONVERT_NOSPACE) {
- if (encodingPtr->nullSize == 2) {
- Tcl_DStringSetLength(dstPtr, soFar + 1);
+ Tcl_Size nBytesProcessed = (src - srcStart);
+ int i = soFar + encodingPtr->nullSize - 1;
+ while (i >= soFar) {
+ Tcl_DStringSetLength(dstPtr, i--);
}
- Tcl_DStringSetLength(dstPtr, soFar);
- return Tcl_DStringValue(dstPtr);
+ if (errorLocPtr) {
+ /*
+ * Do not write error message into interpreter if caller
+ * wants to know error location.
+ */
+ *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed;
+ } else {
+ /* Caller wants error message on failure */
+ if (result != TCL_OK && interp != NULL) {
+ Tcl_Size pos = TclNumUtfChars(srcStart, nBytesProcessed);
+ int ucs4;
+ char buf[TCL_INTEGER_SPACE];
+ Tcl_UtfToUniChar(&srcStart[nBytesProcessed], &ucs4);
+ snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "u", nBytesProcessed);
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "unexpected character at index %" TCL_SIZE_MODIFIER
+ "u: 'U+%06X'",
+ pos,
+ ucs4));
+ Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE",
+ buf, (void *)NULL);
+ }
+ }
+ if (result != TCL_OK) {
+ errno = (result == TCL_CONVERT_NOSPACE) ? ENOMEM : EILSEQ;
+ }
+ return result;
}
flags &= ~TCL_ENCODING_START;
- src += srcRead;
srcLen -= srcRead;
if (Tcl_DStringLength(dstPtr) == 0) {
Tcl_DStringSetLength(dstPtr, dstLen);
@@ -1366,11 +1685,11 @@ Tcl_UtfToExternalDString(
int
Tcl_UtfToExternal(
- Tcl_Interp *interp, /* Interp for error return, if not NULL. */
+ TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
- int srcLen, /* Source string length in bytes, or < 0 for
+ Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
@@ -1380,7 +1699,7 @@ Tcl_UtfToExternal(
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string
* is stored. */
- int dstLen, /* The maximum length of output buffer in
+ Tcl_Size dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
@@ -1427,16 +1746,13 @@ Tcl_UtfToExternal(
}
dstLen -= encodingPtr->nullSize;
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen,
- flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
- dstCharsPtr);
+ flags, statePtr, dst, dstLen, srcReadPtr,
+ dstWrotePtr, dstCharsPtr);
/*
* Buffer is terminated irrespective of result. Not sure this is
* reasonable but keep for historical/compatibility reasons.
*/
- if (encodingPtr->nullSize == 2) {
- dst[*dstWrotePtr + 1] = '\0';
- }
- dst[*dstWrotePtr] = '\0';
+ memset(&dst[*dstWrotePtr], '\0', encodingPtr->nullSize);
return result;
}
@@ -1459,14 +1775,15 @@ Tcl_UtfToExternal(
*---------------------------------------------------------------------------
*/
#undef Tcl_FindExecutable
-void
+const char *
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
- TclInitSubsystems();
+ const char *version = Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
+ return version;
}
/*
@@ -1494,17 +1811,17 @@ OpenEncodingFileChannel(
const char *name) /* The name of the encoding file on disk and
* also the name for new encoding. */
{
- Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
+ Tcl_Obj *nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
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;
- int i, numDirs;
+ Tcl_Size i, numDirs;
- TclListObjGetElements(NULL, searchPath, &numDirs, &dir);
+ TclListObjGetElementsM(NULL, searchPath, &numDirs, &dir);
Tcl_IncrRefCount(nameObj);
- Tcl_AppendToObj(fileNameObj, ".enc", -1);
+ Tcl_AppendToObj(fileNameObj, ".enc", TCL_INDEX_NONE);
Tcl_IncrRefCount(fileNameObj);
Tcl_DictObjGet(NULL, map, nameObj, &directory);
@@ -1577,7 +1894,7 @@ OpenEncodingFileChannel(
if ((NULL == chan) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown encoding \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
@@ -1652,7 +1969,7 @@ LoadEncodingFile(
if ((encoding == NULL) && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid encoding file \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL);
}
Tcl_Close(NULL, chan);
@@ -1723,7 +2040,7 @@ LoadTableEncoding(
};
Tcl_DStringInit(&lineString);
- if (Tcl_Gets(chan, &lineString) == -1) {
+ if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) {
return NULL;
}
line = Tcl_DStringValue(&lineString);
@@ -1765,7 +2082,7 @@ LoadTableEncoding(
for (i = 0; i < numPages; i++) {
int ch;
const char *p;
- int expected = 3 + 16 * (16 * 4 + 1);
+ Tcl_Size expected = 3 + 16 * (16 * 4 + 1);
if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) {
return NULL;
@@ -1849,8 +2166,8 @@ LoadTableEncoding(
*/
if (dataPtr->fromUnicode[0] != NULL) {
- if (dataPtr->fromUnicode[0]['\\'] == '\0') {
- dataPtr->fromUnicode[0]['\\'] = '\\';
+ if (dataPtr->fromUnicode[0][(int)'\\'] == '\0') {
+ dataPtr->fromUnicode[0][(int)'\\'] = '\\';
}
}
}
@@ -2001,7 +2318,7 @@ LoadEscapeEncoding(
Tcl_DStringInit(&escapeData);
while (1) {
- int argc;
+ Tcl_Size argc;
const char **argv;
char *line;
Tcl_DString lineString;
@@ -2053,7 +2370,7 @@ LoadEscapeEncoding(
Tcl_DStringFree(&lineString);
}
- size = TclOffset(EscapeEncodingData, subTables)
+ size = offsetof(EscapeEncodingData, subTables)
+ Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *)ckalloc(size);
dataPtr->initLen = strlen(init);
@@ -2111,15 +2428,11 @@ LoadEscapeEncoding(
static int
BinaryProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
const char *src, /* Source string (unknown encoding). */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2158,11 +2471,11 @@ BinaryProc(
/*
*-------------------------------------------------------------------------
*
- * UtfIntToUtfExtProc --
+ * UtfToUtfProc --
*
- * Convert from UTF-8 to UTF-8. While converting null-bytes from the
- * Tcl's internal representation (0xC0, 0x80) to the official
- * representation (0x00). See UtfToUtfProc for details.
+ * Converts from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
+ * is not a no-op, because it turns a stream of improperly formed
+ * UTF-8 into a properly-formed stream.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2174,18 +2487,14 @@ BinaryProc(
*/
static int
-UtfIntToUtfExtProc(
- ClientData clientData, /* Not used. */
+UtfToUtfProc(
+ void *clientData, /* additional flags */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
- int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
- char *dst, /* Output buffer in which converted string
- * is stored. */
+ int flags, /* TCL_ENCODING_* conversion control flags. */
+ TCL_UNUSED(Tcl_EncodingState *),
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
@@ -2200,18 +2509,194 @@ UtfIntToUtfExtProc(
* correspond to the bytes stored in the
* output buffer. */
{
- return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
-}
+ const char *srcStart, *srcEnd, *srcClose;
+ const char *dstStart, *dstEnd;
+ int result, numChars, charLimit = INT_MAX;
+ int ch;
+ int profile;
+
+ result = TCL_OK;
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= 6;
+ }
+ if (flags & TCL_ENCODING_CHAR_LIMIT) {
+ charLimit = *dstCharsPtr;
+ }
+
+ dstStart = dst;
+ flags |= PTR2INT(clientData);
+ dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6);
+
+ profile = ENCODING_PROFILE_GET(flags);
+ for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) {
+ /*
+ * Copy 7bit characters, but skip null-bytes when we are in input
+ * mode, so that they get converted to \xC0\x80.
+ */
+ *dst++ = *src++;
+ } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) &&
+ (UCHAR(src[1]) == 0x80) &&
+ (!(flags & ENCODING_INPUT) || PROFILE_STRICT(profile) ||
+ PROFILE_REPLACE(profile))) {
+ /* Special sequence \xC0\x80 */
+ if ((PROFILE_STRICT(profile) || PROFILE_REPLACE(profile)) && (flags & ENCODING_INPUT)) {
+ if (PROFILE_REPLACE(profile)) {
+ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
+ src += 2;
+ } else {
+ /* PROFILE_STRICT */
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ } else {
+ /*
+ * Convert 0xC080 to real nulls when we are in output mode,
+ * irrespective of the profile.
+ */
+ *dst++ = 0;
+ src += 2;
+ }
+
+ } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
+ /*
+ * Incomplete byte sequence.
+ * Always check before using Tcl_UtfToUniChar. Not doing can so
+ * cause it run beyond the end of the buffer! If we happen such an
+ * incomplete char its bytes are made to represent themselves
+ * unless the user has explicitly asked to be told.
+ */
+
+ if (flags & ENCODING_INPUT) {
+ /* Incomplete bytes for modified UTF-8 target */
+ if (PROFILE_STRICT(profile)) {
+ result = (flags & TCL_ENCODING_CHAR_LIMIT)
+ ? TCL_CONVERT_MULTIBYTE
+ : TCL_CONVERT_SYNTAX;
+ break;
+ }
+ }
+ if (PROFILE_REPLACE(profile)) {
+ ch = UNICODE_REPLACE_CHAR;
+ ++src;
+ } else {
+ /* TCL_ENCODING_PROFILE_TCL8 */
+ char chbuf[2];
+ chbuf[0] = UCHAR(*src++); chbuf[1] = 0;
+ Tcl_UtfToUniChar(chbuf, &ch);
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ } else {
+ int low;
+ int isInvalid = 0;
+ size_t len = Tcl_UtfToUniChar(src, &ch);
+ if (flags & ENCODING_INPUT) {
+ if ((len < 2) && (ch != 0)) {
+ isInvalid = 1;
+ } else if ((ch > 0xFFFF) && !(flags & ENCODING_UTF)) {
+ isInvalid = 1;
+ }
+ if (isInvalid) {
+ if (PROFILE_STRICT(profile)) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ } else if (PROFILE_REPLACE(profile)) {
+ ch = UNICODE_REPLACE_CHAR;
+ }
+ }
+ }
+
+ const char *saveSrc = src;
+ src += len;
+ if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (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;
+ }
+ goto cesu8;
+ } else if ((ch | 0x7FF) == 0xDFFF) {
+ /*
+ * A surrogate character is detected, handle especially.
+ */
+ if (PROFILE_STRICT(profile) && (flags & ENCODING_UTF)) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ }
+ if (PROFILE_REPLACE(profile)) {
+ ch = UNICODE_REPLACE_CHAR;
+ } else {
+ low = ch;
+ len = (src <= srcEnd - 3) ? Tcl_UtfToUniChar(src, &low) : 0;
+
+ if ((!LOW_SURROGATE(low)) || (ch & 0x400)) {
+
+ if (PROFILE_STRICT(profile)) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ }
+cesu8:
+ *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF);
+ *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF);
+ *dst++ = (char)((ch | 0x80) & 0xBF);
+ continue;
+ }
+ src += len;
+ dst += Tcl_UniCharToUtf(ch, dst);
+ ch = low;
+ }
+ } else if (PROFILE_STRICT(profile) &&
+ (!(flags & ENCODING_INPUT)) &&
+ SURROGATE(ch)) {
+ result = TCL_CONVERT_UNKNOWN;
+ src = saveSrc;
+ break;
+ } else if (PROFILE_STRICT(profile) &&
+ (flags & ENCODING_INPUT) &&
+ SURROGATE(ch)) {
+ result = TCL_CONVERT_SYNTAX;
+ src = saveSrc;
+ break;
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
/*
*-------------------------------------------------------------------------
*
- * UtfExtToUtfIntProc --
+ * Utf32ToUtfProc --
*
- * Convert from UTF-8 to UTF-8 while converting null-bytes from the
- * official representation (0x00) to Tcl's internal representation (0xC0,
- * 0x80). See UtfToUtfProc for details.
+ * Convert from UTF-32 to UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2223,16 +2708,12 @@ UtfIntToUtfExtProc(
*/
static int
-UtfExtToUtfIntProc(
- ClientData clientData, /* Not used. */
- const char *src, /* Source string in UTF-8. */
+Utf32ToUtfProc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
+ const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2249,18 +2730,127 @@ UtfExtToUtfIntProc(
* correspond to the bytes stored in the
* output buffer. */
{
- return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
- srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
-}
+ const char *srcStart, *srcEnd;
+ const char *dstEnd, *dstStart;
+ int result, numChars, charLimit = INT_MAX;
+ int ch = 0, bytesLeft = srcLen % 4;
+
+ flags |= PTR2INT(clientData);
+ if (flags & TCL_ENCODING_CHAR_LIMIT) {
+ charLimit = *dstCharsPtr;
+ }
+ result = TCL_OK;
+
+ /*
+ * Check alignment with utf-32 (4 == sizeof(UTF-32))
+ */
+ if (bytesLeft != 0) {
+ /* We have a truncated code unit */
+ result = TCL_CONVERT_MULTIBYTE;
+ srcLen -= bytesLeft;
+ }
+
+ /*
+ * If last code point is a high surrogate, we cannot handle that yet,
+ * unless we are at the end.
+ */
+
+ if (!(flags & TCL_ENCODING_END) && (srcLen >= 4) &&
+ ((src[srcLen - ((flags & TCL_ENCODING_LE)?3:2)] & 0xFC) == 0xD8) &&
+ ((src[srcLen - ((flags & TCL_ENCODING_LE)?2:3)]) == 0) &&
+ ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:4)]) == 0)) {
+ result = TCL_CONVERT_MULTIBYTE;
+ srcLen-= 4;
+ }
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ int prev = ch;
+ if (flags & TCL_ENCODING_LE) {
+ ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
+ } else {
+ ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF);
+ }
+ if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) {
+ /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */
+ dst += Tcl_UniCharToUtf(-1, dst);
+ }
+
+ if ((unsigned)ch > 0x10FFFF) {
+ ch = UNICODE_REPLACE_CHAR;
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ } else if (PROFILE_STRICT(flags) && SURROGATE(ch)) {
+ result = TCL_CONVERT_SYNTAX;
+ ch = 0;
+ break;
+ } else if (PROFILE_REPLACE(flags) && SURROGATE(ch)) {
+ ch = UNICODE_REPLACE_CHAR;
+ }
+
+ /*
+ * Special case for 1-byte utf chars for speed. Make sure we work with
+ * unsigned short-size data.
+ */
+
+ if ((unsigned)ch - 1 < 0x7F) {
+ *dst++ = (ch & 0xFF);
+ } else {
+ if (!HIGH_SURROGATE(prev) && LOW_SURROGATE(ch)) {
+ *dst = 0; /* In case of lower surrogate, don't try to combine */
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+ src += 4;
+ }
+
+ if (HIGH_SURROGATE(ch)) {
+ /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */
+ dst += Tcl_UniCharToUtf(-1, dst);
+ }
+
+ if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) {
+ /* We have a code fragment left-over at the end */
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ } else {
+ /* destination is not full, so we really are at the end now */
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_SYNTAX;
+ } else {
+ /* PROFILE_REPLACE or PROFILE_TCL8 */
+ result = TCL_OK;
+ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
+ numChars++;
+ src += bytesLeft; /* Go past truncated code unit */
+ }
+ }
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
/*
*-------------------------------------------------------------------------
*
- * UtfToUtfProc --
+ * UtfToUtf32Proc --
*
- * Converts from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation
- * is not a no-op, because it turns a stream of improperly formed
- * UTF-8 into a properly-formed stream.
+ * Convert from UTF-8 to UTF-32.
*
* Results:
* Returns TCL_OK if conversion was successful.
@@ -2272,16 +2862,12 @@ UtfExtToUtfIntProc(
*/
static int
-UtfToUtfProc(
- ClientData clientData, /* Not used. */
+UtfToUtf32Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2294,37 +2880,27 @@ UtfToUtfProc(
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
- int *dstCharsPtr, /* Filled with the number of characters that
+ int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
- int pureNullMode) /* Convert embedded nulls from internal
- * representation to real null-bytes or vice
- * versa. Also combine or separate surrogate pairs */
{
- const char *srcStart, *srcEnd, *srcClose;
- const char *dstStart, *dstEnd;
- int result, numChars, charLimit = INT_MAX;
- Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
-
- if (flags & TCL_ENCODING_START) {
- *statePtr = 0;
- }
- result = TCL_OK;
+ const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
+ int result, numChars;
+ int ch, len;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
- srcClose -= 6;
- }
- if (flags & TCL_ENCODING_CHAR_LIMIT) {
- charLimit = *dstCharsPtr;
+ srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
- dstEnd = dst + dstLen - ((pureNullMode == 1) ? 4 : TCL_UTF_MAX);
+ dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+ flags |= PTR2INT(clientData);
- for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
@@ -2338,77 +2914,27 @@ UtfToUtfProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (pureNullMode == 0))) {
- /*
- * Copy 7bit characters, but skip null-bytes when we are in input
- * mode, so that they get converted to 0xC080.
- */
-
- *dst++ = *src++;
- *chPtr = 0; /* reset surrogate handling */
- } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd)
- && (UCHAR(src[1]) == 0x80) && (pureNullMode == 1)) {
- /*
- * Convert 0xC080 to real nulls when we are in output mode.
- */
-
- *dst++ = 0;
- *chPtr = 0; /* reset surrogate handling */
- src += 2;
- } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
- /*
- * Always check before using TclUtfToUniChar. Not doing can so
- * cause it run beyond the end of the buffer! If we happen such an
- * incomplete char its bytes are made to represent themselves
- * unless the user has explicitly asked to be told.
- */
-
- if ((flags & TCL_ENCODING_STOPONERROR) && (pureNullMode == 0)) {
- result = TCL_CONVERT_MULTIBYTE;
- break;
- }
- *chPtr = UCHAR(*src);
- src += 1;
- dst += Tcl_UniCharToUtf(*chPtr, dst);
- } else {
- size_t len = TclUtfToUniChar(src, chPtr);
- if ((len < 2) && (*chPtr != 0) && (flags & TCL_ENCODING_STOPONERROR)
- && ((*chPtr & ~0x7FF) != 0xD800) && (pureNullMode == 0)) {
- result = TCL_CONVERT_SYNTAX;
+ len = Tcl_UtfToUniChar(src, &ch);
+ if (SURROGATE(ch)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
break;
}
- src += len;
- if ((*chPtr & ~0x7FF) == 0xD800) {
- Tcl_UniChar low;
- /* A surrogate character is detected, handle especially */
-#if TCL_UTF_MAX <= 4
- if ((len < 3) && ((src[3 - len] & 0xC0) != 0x80)) {
- /* It's invalid. See [ed29806ba] */
- *chPtr = UCHAR(src[-1]);
- dst += Tcl_UniCharToUtf(*chPtr, dst);
- continue;
+ if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
}
-#endif
- low = *chPtr;
- len = (src <= srcEnd-3) ? Tcl_UtfToUniChar(src, &low) : 0;
- if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) {
- *dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
- *dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
- *dst++ = (char) ((*chPtr | 0x80) & 0xBF);
- *chPtr = 0; /* reset surrogate handling */
- continue;
- } else if ((TCL_UTF_MAX > 3) || (pureNullMode == 1)) {
- int full = (((*chPtr & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000;
- *dst++ = (char) (((full >> 18) | 0xF0) & 0xF7);
- *dst++ = (char) (((full >> 12) | 0x80) & 0xBF);
- *dst++ = (char) (((full >> 6) | 0x80) & 0xBF);
- *dst++ = (char) ((full | 0x80) & 0xBF);
- *chPtr = 0; /* reset surrogate handling */
- src += len;
- continue;
- }
- }
- dst += Tcl_UniCharToUtf(*chPtr, dst);
+ }
+ src += len;
+ if (flags & TCL_ENCODING_LE) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = ((ch >> 8) & 0xFF);
+ *dst++ = ((ch >> 16) & 0xFF);
+ *dst++ = ((ch >> 24) & 0xFF);
+ } else {
+ *dst++ = ((ch >> 24) & 0xFF);
+ *dst++ = ((ch >> 16) & 0xFF);
+ *dst++ = ((ch >> 8) & 0xFF);
+ *dst++ = (ch & 0xFF);
}
}
@@ -2421,7 +2947,7 @@ UtfToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UnicodeToUtfProc --
+ * Utf16ToUtfProc --
*
* Convert from UTF-16 to UTF-8.
*
@@ -2435,16 +2961,12 @@ UtfToUtfProc(
*/
static int
-UnicodeToUtfProc(
- ClientData clientData, /* != NULL means LE, == NUL means BE */
+Utf16ToUtfProc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2464,8 +2986,9 @@ UnicodeToUtfProc(
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart;
int result, numChars, charLimit = INT_MAX;
- unsigned short ch;
+ unsigned short ch = 0;
+ flags |= PTR2INT(clientData);
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
@@ -2480,18 +3003,16 @@ UnicodeToUtfProc(
srcLen--;
}
-#if TCL_UTF_MAX > 3
/*
* If last code point is a high surrogate, we cannot handle that yet,
* unless we are at the end.
*/
if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) &&
- ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) {
+ ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
-#endif
srcStart = src;
srcEnd = src + srcLen;
@@ -2505,37 +3026,76 @@ UnicodeToUtfProc(
break;
}
- if (clientData) {
+ unsigned short prev = ch;
+ if (flags & TCL_ENCODING_LE) {
ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
}
+ if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_SYNTAX;
+ src -= 2; /* Go back to beginning of high surrogate */
+ dst--; /* Also undo writing a single byte too much */
+ numChars--;
+ break;
+ }
+ /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */
+ dst += Tcl_UniCharToUtf(-1, dst);
+ }
/*
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data.
*/
- if (ch && ch < 0x80) {
+ if ((unsigned)ch - 1 < 0x7F) {
*dst++ = (ch & 0xFF);
+ } else if (HIGH_SURROGATE(prev) || HIGH_SURROGATE(ch)) {
+ dst += Tcl_UniCharToUtf(ch, dst);
+ } else if (LOW_SURROGATE(ch) && PROFILE_STRICT(flags)) {
+ /* Lo surrogate not preceded by Hi surrogate */
+ result = TCL_CONVERT_SYNTAX;
+ break;
} else {
+ *dst = 0; /* In case of lower surrogate, don't try to combine */
dst += Tcl_UniCharToUtf(ch, dst);
}
src += sizeof(unsigned short);
}
+ if (HIGH_SURROGATE(ch)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_SYNTAX;
+ src -= 2;
+ dst--;
+ numChars--;
+ } else {
+ /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */
+ dst += Tcl_UniCharToUtf(-1, dst);
+ }
+ }
+
+ /*
+ * If we had a truncated code unit at the end AND this is the last
+ * fragment AND profile is not "strict", stick FFFD in its place.
+ */
if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) {
- /* We have a single byte left-over at the end */
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
- /* destination is not full, so we really are at the end now */
- result = TCL_OK;
- dst += Tcl_UniCharToUtf(0xFFFD, dst);
- numChars++;
- src++;
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_SYNTAX;
+ } else {
+ /* PROFILE_REPLACE or PROFILE_TCL8 */
+ result = TCL_OK;
+ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
+ numChars++;
+ src++; /* Go past truncated code unit */
+ }
}
}
+
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
@@ -2545,7 +3105,7 @@ UnicodeToUtfProc(
/*
*-------------------------------------------------------------------------
*
- * UtfToUnicodeProc --
+ * UtfToUtf16Proc --
*
* Convert from UTF-8 to UTF-16.
*
@@ -2559,16 +3119,12 @@ UnicodeToUtfProc(
*/
static int
-UtfToUnicodeProc(
- ClientData clientData, /* != NULL means LE, == NUL means BE */
+UtfToUtf16Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2587,11 +3143,8 @@ UtfToUnicodeProc(
{
const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
- Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr;
+ int ch, len;
- if (flags & TCL_ENCODING_START) {
- *statePtr = 0;
- }
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
@@ -2600,7 +3153,8 @@ UtfToUnicodeProc(
}
dstStart = dst;
- dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
+ dstEnd = dst + dstLen - 2; /* 2 -> sizeof a UTF-16 code unit */
+ flags |= PTR2INT(clientData);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
@@ -2617,38 +3171,140 @@ UtfToUnicodeProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- src += TclUtfToUniChar(src, chPtr);
-
- if (clientData) {
-#if TCL_UTF_MAX > 4
- if (*chPtr <= 0xFFFF) {
- *dst++ = (*chPtr & 0xFF);
- *dst++ = (*chPtr >> 8);
+ len = Tcl_UtfToUniChar(src, &ch);
+ if (SURROGATE(ch)) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
+ }
+ }
+ src += len;
+ if (flags & TCL_ENCODING_LE) {
+ if (ch <= 0xFFFF) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = (ch >> 8);
} else {
- *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
- *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
- *dst++ = (*chPtr & 0xFF);
- *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
+ *dst++ = (((ch - 0x10000) >> 10) & 0xFF);
+ *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
+ *dst++ = (ch & 0xFF);
+ *dst++ = ((ch >> 8) & 0x3) | 0xDC;
}
-#else
- *dst++ = (*chPtr & 0xFF);
- *dst++ = (*chPtr >> 8);
-#endif
} else {
-#if TCL_UTF_MAX > 4
- if (*chPtr <= 0xFFFF) {
- *dst++ = (*chPtr >> 8);
- *dst++ = (*chPtr & 0xFF);
+ if (ch <= 0xFFFF) {
+ *dst++ = (ch >> 8);
+ *dst++ = (ch & 0xFF);
} else {
- *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
- *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
- *dst++ = ((*chPtr >> 8) & 0x3) | 0xDC;
- *dst++ = (*chPtr & 0xFF);
+ *dst++ = (((ch - 0x10000) >> 18) & 0x3) | 0xD8;
+ *dst++ = (((ch - 0x10000) >> 10) & 0xFF);
+ *dst++ = ((ch >> 8) & 0x3) | 0xDC;
+ *dst++ = (ch & 0xFF);
}
-#else
- *dst++ = (*chPtr >> 8);
- *dst++ = (*chPtr & 0xFF);
-#endif
+ }
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * UtfToUcs2Proc --
+ *
+ * Convert from UTF-8 to UCS-2.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UtfToUcs2Proc(
+ void *clientData, /* additional flags, e.g. TCL_ENCODING_LE */
+ const char *src, /* Source string in UTF-8. */
+ int srcLen, /* Source string length in bytes. */
+ int flags, /* Conversion control flags. */
+ TCL_UNUSED(Tcl_EncodingState *),
+ char *dst, /* Output buffer in which converted string is
+ * stored. */
+ int dstLen, /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr, /* Filled with the number of bytes from the
+ * source string that were converted. This may
+ * be less than the original source length if
+ * there was a problem converting some source
+ * characters. */
+ int *dstWrotePtr, /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr) /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
+ int result, numChars, len;
+ Tcl_UniChar ch = 0;
+
+ flags |= PTR2INT(clientData);
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - 2; /* 2 - size of UCS code unit */
+
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ len = TclUtfToUniChar(src, &ch);
+ if (ch > 0xFFFF) {
+ if (PROFILE_STRICT(flags)) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ ch = UNICODE_REPLACE_CHAR;
+ }
+ if (PROFILE_STRICT(flags) && SURROGATE(ch)) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+
+ src += len;
+
+ /*
+ * Need to handle this in a way that won't cause misalignment by
+ * casting dst to a Tcl_UniChar. [Bug 1122671]
+ */
+
+ if (flags & TCL_ENCODING_LE) {
+ *dst++ = (ch & 0xFF);
+ *dst++ = (ch >> 8);
+ } else {
+ *dst++ = (ch >> 8);
+ *dst++ = (ch & 0xFF);
}
}
*srcReadPtr = src - srcStart;
@@ -2676,16 +3332,12 @@ UtfToUnicodeProc(
static int
TableToUtfProc(
- ClientData clientData, /* TableEncodingData that specifies
+ void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2737,9 +3389,11 @@ TableToUtfProc(
/* More data to come */
result = TCL_CONVERT_MULTIBYTE;
break;
- } else if (flags & TCL_ENCODING_STOPONERROR) {
+ } else if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
+ } else if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
} else {
ch = (Tcl_UniChar)byte;
}
@@ -2751,14 +3405,18 @@ TableToUtfProc(
}
if ((ch == 0) && (byte != 0)) {
/* Prefix+suffix pair is invalid */
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
}
if (prefixBytes[byte]) {
src--;
}
- ch = (Tcl_UniChar)byte;
+ if (PROFILE_REPLACE(flags)) {
+ ch = UNICODE_REPLACE_CHAR;
+ } else {
+ ch = (Tcl_UniChar)byte;
+ }
}
/*
@@ -2773,6 +3431,7 @@ TableToUtfProc(
src++;
}
+ assert(src <= srcEnd);
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
@@ -2798,16 +3457,12 @@ TableToUtfProc(
static int
TableFromUtfProc(
- ClientData clientData, /* TableEncodingData that specifies
+ void *clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -2858,24 +3513,18 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX > 4
/* Unicode chars > +U0FFFF cannot be represented in any table encoding */
if (ch & 0xFFFF0000) {
word = 0;
} else
-#elif TCL_UTF_MAX == 4
- if (!len) {
- word = 0;
- } else
-#endif
word = fromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
- word = dataPtr->fallback;
+ word = dataPtr->fallback; /* Both profiles REPLACE and TCL8 */
}
if (prefixBytes[(word >> 8)] != 0) {
if (dst + 1 > dstEnd) {
@@ -2920,15 +3569,11 @@ TableFromUtfProc(
static int
Iso88591ToUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -3004,15 +3649,11 @@ Iso88591ToUtfProc(
static int
Iso88591FromUtfProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
- * information used during a piecewise
- * conversion. Contents of statePtr are
- * initialized and/or reset by conversion
- * routine under control of flags argument. */
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
@@ -3063,24 +3704,16 @@ Iso88591FromUtfProc(
*/
if (ch > 0xFF
-#if TCL_UTF_MAX == 4
- || ((ch >= 0xD800) && (len < 3))
-#endif
) {
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
-#if TCL_UTF_MAX == 4
- if ((ch >= 0xD800) && (len < 3)) {
- len = 4;
- }
-#endif
/*
* Plunge on, using '?' as a fallback character.
*/
- ch = (Tcl_UniChar) '?';
+ ch = (Tcl_UniChar) '?'; /* Profiles TCL8 and REPLACE */
}
if (dst > dstEnd) {
@@ -3116,10 +3749,10 @@ Iso88591FromUtfProc(
static void
TableFreeProc(
- ClientData clientData) /* TableEncodingData that specifies
+ void *clientData) /* TableEncodingData that specifies
* encoding. */
{
- TableEncodingData *dataPtr = (TableEncodingData *) clientData;
+ TableEncodingData *dataPtr = (TableEncodingData *)clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
@@ -3151,7 +3784,7 @@ TableFreeProc(
static int
EscapeToUtfProc(
- ClientData clientData, /* EscapeEncodingData that specifies
+ void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
@@ -3177,7 +3810,7 @@ EscapeToUtfProc(
* correspond to the bytes stored in the
* output buffer. */
{
- EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData;
+ EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd;
const unsigned short *const *tableToUnicode;
const Encoding *encodingPtr;
@@ -3294,12 +3927,11 @@ EscapeToUtfProc(
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
- if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
- /*
- * Skip the unknown escape sequence.
- */
-
- src += longest;
+ if (!PROFILE_STRICT(flags)) {
+ unsigned skip = longest > left ? left : longest;
+ /* Unknown escape sequence */
+ dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
+ src += skip;
continue;
}
result = TCL_CONVERT_SYNTAX;
@@ -3365,7 +3997,7 @@ EscapeToUtfProc(
static int
EscapeFromUtfProc(
- ClientData clientData, /* EscapeEncodingData that specifies
+ void *clientData, /* EscapeEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
@@ -3469,7 +4101,7 @@ EscapeFromUtfProc(
if (word == 0) {
state = oldState;
- if (flags & TCL_ENCODING_STOPONERROR) {
+ if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
@@ -3502,8 +4134,7 @@ EscapeFromUtfProc(
result = TCL_CONVERT_NOSPACE;
break;
}
- memcpy(dst, subTablePtr->sequence,
- subTablePtr->sequenceLen);
+ memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen);
dst += subTablePtr->sequenceLen;
}
}
@@ -3577,7 +4208,7 @@ EscapeFromUtfProc(
static void
EscapeFreeProc(
- ClientData clientData) /* EscapeEncodingData that specifies
+ void *clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
@@ -3654,7 +4285,7 @@ GetTableEncoding(
/*
*---------------------------------------------------------------------------
*
- * unilen --
+ * unilen, unilen4 --
*
* A helper function for the Tcl_ExternalToUtf functions. This function
* is similar to strlen for double-byte characters: it returns the number
@@ -3681,6 +4312,19 @@ unilen(
}
return (char *) p - src;
}
+
+static size_t
+unilen4(
+ const char *src)
+{
+ unsigned int *p;
+
+ p = (unsigned int *) src;
+ while (*p != 0x00000000) {
+ p++;
+ }
+ return (char *) p - src;
+}
/*
*-------------------------------------------------------------------------
@@ -3708,11 +4352,11 @@ unilen(
static void
InitializeEncodingSearchPath(
char **valuePtr,
- int *lengthPtr,
+ TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
- int i, numDirs, numBytes;
+ Tcl_Size i, numDirs, numBytes;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
@@ -3721,7 +4365,7 @@ InitializeEncodingSearchPath(
Tcl_IncrRefCount(searchPathObj);
libPathObj = TclGetLibraryPath();
Tcl_IncrRefCount(libPathObj);
- TclListObjLength(NULL, libPathObj, &numDirs);
+ TclListObjLengthM(NULL, libPathObj, &numDirs);
for (i = 0; i < numDirs; i++) {
Tcl_Obj *directoryObj, *pathObj;
@@ -3742,7 +4386,7 @@ InitializeEncodingSearchPath(
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
+ bytes = TclGetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
*valuePtr = (char *)ckalloc(numBytes + 1);
@@ -3751,6 +4395,124 @@ InitializeEncodingSearchPath(
}
/*
+ *------------------------------------------------------------------------
+ *
+ * TclEncodingProfileParseName --
+ *
+ * Maps an encoding profile name to its integer equivalent.
+ *
+ * Results:
+ * TCL_OK on success or TCL_ERROR on failure.
+ *
+ * Side effects:
+ * Returns the profile enum value in *profilePtr
+ *
+ *------------------------------------------------------------------------
+ */
+int
+TclEncodingProfileNameToId(
+ Tcl_Interp *interp, /* For error messages. May be NULL */
+ const char *profileName, /* Name of profile */
+ int *profilePtr) /* Output */
+{
+ size_t i;
+ size_t numProfiles = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
+
+ for (i = 0; i < numProfiles; ++i) {
+ if (!strcmp(profileName, encodingProfiles[i].name)) {
+ *profilePtr = encodingProfiles[i].value;
+ return TCL_OK;
+ }
+ }
+ if (interp) {
+ Tcl_Obj *errorObj;
+ /* This code assumes at least two profiles :-) */
+ errorObj =
+ Tcl_ObjPrintf("bad profile name \"%s\": must be",
+ profileName);
+ for (i = 0; i < (numProfiles - 1); ++i) {
+ Tcl_AppendStringsToObj(
+ errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL);
+ }
+ Tcl_AppendStringsToObj(
+ errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL);
+
+ Tcl_SetObjResult(interp, errorObj);
+ Tcl_SetErrorCode(
+ interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclEncodingProfileValueToName --
+ *
+ * Maps an encoding profile value to its name.
+ *
+ * Results:
+ * Pointer to the name or NULL on failure. Caller must not make
+ * not modify the string and must make a copy to hold on to it.
+ *
+ * Side effects:
+ * None.
+ *------------------------------------------------------------------------
+ */
+const char *
+TclEncodingProfileIdToName(
+ Tcl_Interp *interp, /* For error messages. May be NULL */
+ int profileValue) /* Profile #define value */
+{
+ size_t i;
+
+ for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) {
+ if (profileValue == encodingProfiles[i].value) {
+ return encodingProfiles[i].name;
+ }
+ }
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "Internal error. Bad profile id \"%d\".",
+ profileValue));
+ Tcl_SetErrorCode(
+ interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL);
+ }
+ return NULL;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclGetEncodingProfiles --
+ *
+ * Get the list of supported encoding profiles.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The list of profile names is stored in the interpreter result.
+ *
+ *------------------------------------------------------------------------
+ */
+void
+TclGetEncodingProfiles(Tcl_Interp *interp)
+{
+ size_t i, n;
+ Tcl_Obj *objPtr;
+ n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]);
+ objPtr = Tcl_NewListObj(n, NULL);
+ for (i = 0; i < n; ++i) {
+ Tcl_ListObjAppendElement(
+ interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, TCL_INDEX_NONE));
+ }
+ Tcl_SetObjResult(interp, objPtr);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 63c8624..cdc13af 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -4,7 +4,7 @@
* Contains support for ensembles (see TIP#112), which provide simple
* mechanism for creating composite commands on top of namespaces.
*
- * Copyright (c) 2005-2013 Donal K. Fellows.
+ * Copyright © 2005-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.
@@ -21,14 +21,12 @@ 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 NsEnsembleImplementationCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NsEnsembleImplementationCmdNR(ClientData clientData,
+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(ClientData clientData);
+static void DeleteEnsembleConfig(void *clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
Tcl_Obj *fix);
@@ -72,8 +70,8 @@ enum EnsConfigOpts {
};
/*
- * This structure defines a Tcl object type that contains a reference to an
- * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
+ * ensembleCmdType is a Tcl object type that contains a reference to an
+ * ensemble subcommand, e.g. the "length" in [string length ab]. It is used
* to cache the mapping between the subcommand itself and the real command
* that implements it.
*/
@@ -86,22 +84,36 @@ static const Tcl_ObjType ensembleCmdType = {
NULL /* setFromAnyProc */
};
+#define ECRSetInternalRep(objPtr, ecRepPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (ecRepPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \
+ } while (0)
+
+#define ECRGetInternalRep(objPtr, ecRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \
+ (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
- * The internal rep for caching ensemble subcommand lookups and
- * spell corrections.
+ * The internal rep for caching ensemble subcommand lookups and spelling
+ * corrections.
*/
typedef struct {
- int epoch; /* Used to confirm when the data in this
+ Tcl_Size epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
- Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
- * hash table. */
+ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
+ * table. */
} EnsembleCmdRep;
-
static inline Tcl_Obj *
NewNsObj(
@@ -111,9 +123,8 @@ NewNsObj(
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
- } else {
- return Tcl_NewStringObj(nsPtr->fullName, -1);
}
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
}
/*
@@ -140,26 +151,27 @@ NewNsObj(
int
TclNamespaceEnsembleCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
- *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
+ *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
Tcl_Command token;
Tcl_DictSearch search;
Tcl_Obj *listObj;
const char *simpleName;
- int index, done;
+ int index;
+ int done;
- if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
+ if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tried to manipulate ensemble of deleted namespace",
-1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (void *)NULL);
}
return TCL_ERROR;
}
@@ -176,7 +188,8 @@ TclNamespaceEnsembleCmd(
switch ((enum EnsSubcmds) index) {
case ENS_CREATE: {
const char *name;
- int len, allocatedMapFlag = 0;
+ Tcl_Size len;
+ int allocatedMapFlag = 0;
/*
* Defaults
*/
@@ -221,7 +234,7 @@ TclNamespaceEnsembleCmd(
cxtPtr = nsPtr;
continue;
case CRT_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -230,7 +243,7 @@ TclNamespaceEnsembleCmd(
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_PARAM:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -260,7 +273,7 @@ TclNamespaceEnsembleCmd(
Tcl_Obj **listv;
const char *cmd;
- if (TclListObjGetElements(interp, listObj, &len,
+ if (TclListObjGetElementsM(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
@@ -276,7 +289,7 @@ TclNamespaceEnsembleCmd(
"ensemble subcommand implementations "
"must be non-empty lists", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
- "EMPTY_TARGET", NULL);
+ "EMPTY_TARGET", (void *)NULL);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -292,7 +305,7 @@ TclNamespaceEnsembleCmd(
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
@@ -302,7 +315,8 @@ TclNamespaceEnsembleCmd(
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
- Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+ Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+ &done);
} while (!done);
if (allocatedMapFlag) {
@@ -324,7 +338,7 @@ TclNamespaceEnsembleCmd(
}
continue;
case CRT_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
@@ -336,8 +350,8 @@ TclNamespaceEnsembleCmd(
}
TclGetNamespaceForQualName(interp, name, cxtPtr,
- TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
- &simpleName);
+ TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
+ &actualCxtPtr, &simpleName);
/*
* Create the ensemble. Note that this might delete another ensemble
@@ -347,8 +361,8 @@ TclNamespaceEnsembleCmd(
*/
token = TclCreateEnsembleInNs(interp, simpleName,
- (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
@@ -486,7 +500,8 @@ TclNamespaceEnsembleCmd(
Tcl_SetObjResult(interp, resultObj);
} else {
- int len, allocatedMapFlag = 0;
+ Tcl_Size 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 */
@@ -519,13 +534,13 @@ TclNamespaceEnsembleCmd(
}
switch ((enum EnsConfigOpts) index) {
case CONF_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_PARAM:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
paramObj = (len > 0 ? objv[1] : NULL);
@@ -547,8 +562,8 @@ TclNamespaceEnsembleCmd(
continue;
}
do {
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
+ if (TclListObjLengthM(interp, listObj, &len
+ ) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -560,7 +575,15 @@ TclNamespaceEnsembleCmd(
"ensemble subcommand implementations "
"must be non-empty lists", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
- "EMPTY_TARGET", NULL);
+ "EMPTY_TARGET", (void *)NULL);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
+ if (TclListObjGetElementsM(interp, listObj, &len,
+ &listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -573,10 +596,11 @@ TclNamespaceEnsembleCmd(
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+ Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
+ &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
@@ -599,7 +623,7 @@ TclNamespaceEnsembleCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"option -namespace is read-only", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
- NULL);
+ (void *)NULL);
goto freeMapAndError;
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
@@ -608,7 +632,7 @@ TclNamespaceEnsembleCmd(
}
continue;
case CONF_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objv[1], &len) != TCL_OK) {
goto freeMapAndError;
}
unknownObj = (len > 0 ? objv[1] : NULL);
@@ -650,15 +674,13 @@ TclNamespaceEnsembleCmd(
Tcl_Command
TclCreateEnsembleInNs(
Tcl_Interp *interp,
-
- const char *name, /* Simple name of command to create (no */
- /* namespace components). */
- Tcl_Namespace /* Name of namespace to create the command in. */
- *nameNsPtr,
- Tcl_Namespace
- *ensembleNsPtr, /* Name of the namespace for the ensemble. */
- int flags
- )
+ const char *name, /* Simple name of command to create (no
+ * namespace components). */
+ Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command
+ * in. */
+ Tcl_Namespace *ensembleNsPtr,
+ /* Name of the namespace for the ensemble. */
+ int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
@@ -666,8 +688,8 @@ TclCreateEnsembleInNs(
ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
- (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
- NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+ (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
+ NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
ckfree(ensemblePtr);
return NULL;
@@ -701,18 +723,15 @@ TclCreateEnsembleInNs(
}
return ensemblePtr->token;
-
}
-
-
+
/*
*----------------------------------------------------------------------
*
* Tcl_CreateEnsemble
*
- * Create a simple ensemble attached to the given namespace.
- *
- * Deprecated by TclCreateEnsembleInNs.
+ * Create a simple ensemble attached to the given namespace. Deprecated
+ * (internally) by TclCreateEnsembleInNs.
*
* Value
*
@@ -732,8 +751,8 @@ Tcl_CreateEnsemble(
Tcl_Namespace *namespacePtr,
int flags)
{
- Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
- *actualNsPtr;
+ Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
const char * simpleName;
if (nsPtr == NULL) {
@@ -741,11 +760,10 @@ Tcl_CreateEnsemble(
}
TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
- &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
return TclCreateEnsembleInNs(interp, simpleName,
- (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
}
-
/*
*----------------------------------------------------------------------
@@ -774,16 +792,16 @@ Tcl_SetEnsembleSubcommandList(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
return TCL_ERROR;
}
if (subcmdList != NULL) {
- int length;
+ Tcl_Size length;
- if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -848,18 +866,18 @@ Tcl_SetEnsembleParameterList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- int length;
+ Tcl_Size length;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
return TCL_ERROR;
}
if (paramList == NULL) {
length = 0;
} else {
- if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, paramList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -926,14 +944,15 @@ Tcl_SetEnsembleMappingDict(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
return TCL_ERROR;
}
if (mapDict != NULL) {
- int size, done;
+ Tcl_Size size;
+ int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
@@ -956,7 +975,7 @@ Tcl_SetEnsembleMappingDict(
"ensemble target is not a fully-qualified command",
-1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
- "UNQUALIFIED_TARGET", NULL);
+ "UNQUALIFIED_TARGET", (void *)NULL);
Tcl_DictObjDone(&search);
return TCL_ERROR;
}
@@ -1025,16 +1044,16 @@ Tcl_SetEnsembleUnknownHandler(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
return TCL_ERROR;
}
if (unknownList != NULL) {
- int length;
+ Tcl_Size length;
- if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
@@ -1091,10 +1110,10 @@ Tcl_SetEnsembleFlags(
EnsembleConfig *ensemblePtr;
int wasCompiled;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
return TCL_ERROR;
}
@@ -1167,11 +1186,11 @@ Tcl_GetEnsembleSubcommandList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1209,11 +1228,11 @@ Tcl_GetEnsembleParameterList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1251,11 +1270,11 @@ Tcl_GetEnsembleMappingDict(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1292,11 +1311,11 @@ Tcl_GetEnsembleUnknownHandler(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1333,11 +1352,11 @@ Tcl_GetEnsembleFlags(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1374,11 +1393,11 @@ Tcl_GetEnsembleNamespace(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1424,7 +1443,7 @@ Tcl_FindEnsemble(
return NULL;
}
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link chains
* rather than duplicating it.
@@ -1432,13 +1451,14 @@ Tcl_FindEnsemble(
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (cmdPtr == NULL
+ || cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
TclGetString(cmdNameObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
- TclGetString(cmdNameObj), NULL);
+ TclGetString(cmdNameObj), (void *)NULL);
}
return NULL;
}
@@ -1470,11 +1490,11 @@ Tcl_IsEnsemble(
{
Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
return 0;
}
return 1;
@@ -1515,7 +1535,8 @@ TclMakeEnsemble(
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
- int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
+ Tcl_Size i, nameCount = 0;
+ int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
@@ -1616,7 +1637,7 @@ TclMakeEnsemble(
Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
if (Tcl_HideCommand(interp, "___tmp",
Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", Tcl_GetStringResult(interp));
}
} else {
/*
@@ -1637,7 +1658,7 @@ TclMakeEnsemble(
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
- ckfree((char *) nameParts);
+ ckfree(nameParts);
}
return ensemble;
}
@@ -1645,7 +1666,7 @@ TclMakeEnsemble(
/*
*----------------------------------------------------------------------
*
- * NsEnsembleImplementationCmd --
+ * TclEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
* namespace other than the global namespace) as a command with the same
@@ -1664,9 +1685,9 @@ TclMakeEnsemble(
*----------------------------------------------------------------------
*/
-static int
-NsEnsembleImplementationCmd(
- ClientData clientData,
+int
+TclEnsembleImplementationCmd(
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1677,7 +1698,7 @@ NsEnsembleImplementationCmd(
static int
NsEnsembleImplementationCmdNR(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1693,10 +1714,10 @@ NsEnsembleImplementationCmdNR(
int reparseCount = 0; /* Number of reparses. */
Tcl_Obj *errorObj; /* Used for building error messages. */
Tcl_Obj *subObj;
- int subIdx;
+ Tcl_Size subIdx;
/*
- * Must recheck objc, since numParameters might have changed. Cf. test
+ * Must recheck objc since numParameters might have changed. See test
* namespace-53.9.
*/
@@ -1704,7 +1725,7 @@ NsEnsembleImplementationCmdNR(
subIdx = 1 + ensemblePtr->numParameters;
if (objc < subIdx + 1) {
/*
- * We don't have a subcommand argument. Make error message.
+ * No subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
@@ -1722,7 +1743,7 @@ NsEnsembleImplementationCmdNR(
return TCL_ERROR;
}
- if (ensemblePtr->nsPtr->flags & NS_DYING) {
+ if (ensemblePtr->nsPtr->flags & NS_DEAD) {
/*
* Don't know how we got here, but make things give up quickly.
*/
@@ -1730,29 +1751,27 @@ NsEnsembleImplementationCmdNR(
if (!Tcl_InterpDeleted(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"ensemble activated for deleted namespace", -1));
- Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (void *)NULL);
}
return TCL_ERROR;
}
/*
- * Determine if the table of subcommands is right. If so, we can just look
- * up in there and go straight to dispatch.
+ * If the table of subcommands is valid just lookup up the command there
+ * and go to dispatch.
*/
subObj = objv[subIdx];
if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
/*
- * Table of subcommands is still valid; therefore there might be a
- * valid cache of discovered information which we can reuse. Do the
- * check here, and if we're still valid, we can jump straight to the
- * part where we do the invocation of the subcommand.
+ * Table of subcommands is still valid so if the internal representtion
+ * is an ensembleCmd, just call it.
*/
+ EnsembleCmdRep *ensembleCmd;
- if (subObj->typePtr==&ensembleCmdType){
- EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)subObj->internalRep.twoPtrValue.ptr1;
-
+ ECRGetInternalRep(subObj, ensembleCmd);
+ if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
@@ -1769,8 +1788,8 @@ NsEnsembleImplementationCmdNR(
}
/*
- * Look in the hashtable for the subcommand name; this is the fastest way
- * of all if there is no cache in operation.
+ * Look in the hashtable for the named subcommand. This is the fastest
+ * path if there is no cache in operation.
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
@@ -1778,44 +1797,43 @@ NsEnsembleImplementationCmdNR(
if (hPtr != NULL) {
/*
- * Cache for later in the subcommand object.
+ * Cache ensemble in the subcommand object for later.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
- * Could not map, no prefixing, go to unknown/error handling.
+ * Could not map. No prefixing. Go to unknown/error handling.
*/
goto unknownOrAmbiguousSubcommand;
} else {
/*
- * If we've not already confirmed the command with the hash as part of
- * building our export table, we need to scan the sorted array for
- * matches.
+ * If the command isn't yet confirmed with the hash as part of building
+ * the export table, scan the sorted array for matches.
*/
- const char *subcmdName; /* Name of the subcommand, or unique prefix of
- * it (will be an error for a non-unique
- * prefix). */
+ const char *subcmdName; /* Name of the subcommand or unique prefix of
+ * it (a non-unique prefix produces an error).
+ */
char *fullName = NULL; /* Full name of the subcommand. */
- int stringLength, i;
- int tableLength = ensemblePtr->subcommandTable.numEntries;
+ Tcl_Size stringLength, i;
+ Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
- subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
+ subcmdName = TclGetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
- (unsigned) stringLength);
+ stringLength);
if (cmp == 0) {
if (fullName != NULL) {
/*
- * Since there's never the exact-match case to worry about
- * (hash search filters this), getting here indicates that
- * our subcommand is an ambiguous prefix of (at least) two
- * exported subcommands, which is an error case.
+ * Hash search filters out the exact-match case, so getting
+ * here indicates that the subcommand is an ambiguous
+ * prefix of at least two exported subcommands, which is an
+ * error case.
*/
goto unknownOrAmbiguousSubcommand;
@@ -1823,9 +1841,8 @@ NsEnsembleImplementationCmdNR(
fullName = ensemblePtr->subcommandArrayPtr[i];
} else if (cmp < 0) {
/*
- * Because we are searching a sorted table, we can now stop
- * searching because we have gone past anything that could
- * possibly match.
+ * The table is sorted so stop searching because a match would
+ * have been found already.
*/
break;
@@ -1833,7 +1850,7 @@ NsEnsembleImplementationCmdNR(
}
if (fullName == NULL) {
/*
- * The subcommand is not a prefix of anything, so bail out!
+ * The subcommand is not a prefix of anything. Bail out!
*/
goto unknownOrAmbiguousSubcommand;
@@ -1863,26 +1880,24 @@ NsEnsembleImplementationCmdNR(
runResultingSubcommand:
/*
- * Do the real work of execution of the subcommand by building an array of
- * objects (note that this is potentially not the same length as the
- * number of arguments to this ensemble command), populating it and then
- * feeding it back through the main command-lookup engine. In theory, we
- * could look up the command in the namespace ourselves, as we already
- * have the namespace in which it is guaranteed to exist,
+ * Execute the subcommand by populating an array of objects, which might
+ * not be the same length as the number of arguments to this ensemble
+ * command, and then handing it to the main command-lookup engine. In
+ * theory, the command could be looked up right here using the namespace in
+ * which it is guaranteed to exist,
*
* ((Q: That's not true if the -map option is used, is it?))
*
- * but we don't do that (the caching of the command object used should
- * help with that.)
+ * but don't do that because caching of the command object should help.
*/
{
- Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
+ Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
- int copyObjc, prefixObjc;
+ Tcl_Size copyObjc, prefixObjc;
- TclListObjLength(NULL, prefixObj, &prefixObjc);
+ TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclListObjCopy(NULL, prefixObj);
@@ -1900,8 +1915,8 @@ NsEnsembleImplementationCmdNR(
TclDecrRefCount(prefixObj);
/*
- * Record what arguments the script sent in so that things like
- * Tcl_WrongNumArgs can give the correct error message. Parameters
+ * Record the words of the command as given so that routines like
+ * Tcl_WrongNumArgs can produce the correct error message. Parameters
* count both as inserted and removed arguments.
*/
@@ -1916,17 +1931,16 @@ NsEnsembleImplementationCmdNR(
*/
TclSkipTailcall(interp);
- TclListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
+ TclListObjGetElementsM(NULL, copyPtr, &copyObjc, &copyObjv);
((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
}
unknownOrAmbiguousSubcommand:
/*
- * Have not been able to match the subcommand asked for with a real
- * subcommand that we export. See whether a handler has been registered
- * for dealing with this situation. Will only call (at most) once for any
- * particular ensemble invocation.
+ * The named subcommand did not match any exported command. If there is a
+ * handler registered unknown subcommands, call it, but not more than once
+ * for this call.
*/
if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
@@ -1942,15 +1956,15 @@ NsEnsembleImplementationCmdNR(
}
/*
- * We cannot determine what subcommand to hand off to, so generate a
- * (standard) failure message. Note the one odd case compared with
- * standard ensemble-like command, which is where a namespace has no
- * exported commands at all...
+ * Could not find a routine for the named subcommand so generate a standard
+ * failure message. The one odd case compared with a standard
+ * ensemble-like command is where a namespace has no exported commands at
+ * all...
*/
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(subObj), NULL);
+ TclGetString(subObj), (void *)NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown subcommand \"%s\": namespace %s does not"
@@ -1964,7 +1978,7 @@ NsEnsembleImplementationCmdNR(
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
- int i;
+ Tcl_Size i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
@@ -1979,7 +1993,7 @@ NsEnsembleImplementationCmdNR(
int
TclClearRootEnsemble(
- ClientData data[],
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -1992,8 +2006,8 @@ TclClearRootEnsemble(
*
* TclInitRewriteEnsemble --
*
- * Applies a rewrite of arguments so that an ensemble subcommand will
- * report error messages correctly for the overall command.
+ * Applies a rewrite of arguments so that an ensemble subcommand
+ * correctly reports any error messages for the overall command.
*
* Results:
* Whether this is the first rewrite applied, a value which must be
@@ -2009,8 +2023,8 @@ TclClearRootEnsemble(
int
TclInitRewriteEnsemble(
Tcl_Interp *interp,
- int numRemoved,
- int numInserted,
+ Tcl_Size numRemoved,
+ Tcl_Size numInserted,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -2022,7 +2036,7 @@ TclInitRewriteEnsemble(
iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
iPtr->ensembleRewrite.numInsertedObjs = numInserted;
} else {
- int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+ Tcl_Size numIns = iPtr->ensembleRewrite.numInsertedObjs;
if (numIns < numRemoved) {
iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
@@ -2071,7 +2085,7 @@ TclResetRewriteEnsemble(
*
* TclSpellFix --
*
- * Record a spelling correction that needs making in the generation of
+ * Records a spelling correction that needs making in the generation of
* the WrongNumArgs usage message.
*
* Results:
@@ -2085,8 +2099,8 @@ TclResetRewriteEnsemble(
static int
FreeER(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
@@ -2101,16 +2115,16 @@ void
TclSpellFix(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
- int objc,
- int badIdx,
+ Tcl_Size objc,
+ Tcl_Size badIdx,
Tcl_Obj *bad,
Tcl_Obj *fix)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *const *search;
Tcl_Obj **store;
- int idx;
- int size;
+ Tcl_Size idx;
+ Tcl_Size size;
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
iPtr->ensembleRewrite.sourceObjs = objv;
@@ -2123,7 +2137,7 @@ TclSpellFix(
*/
size = iPtr->ensembleRewrite.numRemovedObjs + objc
- - iPtr->ensembleRewrite.numInsertedObjs;
+ - iPtr->ensembleRewrite.numInsertedObjs;
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
@@ -2136,8 +2150,8 @@ TclSpellFix(
if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
/*
- * Misspelled value was inserted. We cannot directly jump to the bad
- * value, but have to search.
+ * Misspelled value was inserted. Cannot directly jump to the bad
+ * value. Must search.
*/
idx = 1;
@@ -2226,8 +2240,8 @@ Tcl_Obj *const *
TclFetchEnsembleRoot(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
- int objc,
- int *objcPtr)
+ Tcl_Size objc,
+ Tcl_Size *objcPtr)
{
Tcl_Obj *const *sourceObjs;
Interp *iPtr = (Interp *) interp;
@@ -2249,22 +2263,22 @@ TclFetchEnsembleRoot(
/*
* ----------------------------------------------------------------------
*
- * EnsmebleUnknownCallback --
+ * EnsembleUnknownCallback --
*
- * Helper for the ensemble engine that handles the processing of unknown
- * callbacks. See the user documentation of the ensemble unknown handler
- * for details; this function is only ever called when such a function is
- * defined, and is only ever called once per ensemble dispatch (i.e. if a
- * reparse still fails, this isn't called again).
+ * Helper for the ensemble engine. Calls the routine registered for
+ * "ensemble unknown" case. See the user documentation of the
+ * ensemble unknown handler for details. Only called when such a
+ * function is defined, and is only called once per ensemble dispatch.
+ * I.e. even if a reparse still fails, this isn't called again.
*
* Results:
* TCL_OK - *prefixObjPtr contains the command words to dispatch
* to.
- * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
- * TCL_ERROR - Something went wrong! Error message in interpreter.
+ * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid
+ * TCL_ERROR - Something went wrong. Error message in interpreter.
*
* Side effects:
- * Calls the Tcl interpreter, so arbitrary.
+ * Arbitrary, due to evaluation of script provided by client.
*
* ----------------------------------------------------------------------
*/
@@ -2277,28 +2291,29 @@ EnsembleUnknownCallback(
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
- int paramc, i, result, prefixObjc;
+ Tcl_Size paramc;
+ int result;
+ Tcl_Size i, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
- * Create the unknown command callback to determine what to do.
+ * 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<objc ; i++) {
+ for (i = 1 ; i < objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
- TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ TclListObjGetElementsM(NULL, unknownCmd, &paramc, &paramv);
Tcl_IncrRefCount(unknownCmd);
/*
- * Now call the unknown handler. (We don't bother NRE-enabling this; deep
- * recursing through unknown handlers is horribly perverse.) Note that it
- * is always an error for an unknown handler to delete its ensemble; don't
- * do that!
+ * 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.
*/
Tcl_Preserve(ensemblePtr);
@@ -2309,17 +2324,16 @@ EnsembleUnknownCallback(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown subcommand handler deleted its ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
- NULL);
+ (void *)NULL);
}
result = TCL_ERROR;
}
Tcl_Release(ensemblePtr);
/*
- * If we succeeded, we should either have a list of words that form the
- * command to be executed, or an empty list. In the empty-list case, the
- * ensemble is believed to be updated so we should ask the ensemble engine
- * to reparse the original command.
+ * On success the result is a list of words that form the command to be
+ * executed. If the list is empty, the ensemble should have been updated,
+ * so ask the ensemble engine to reparse the original command.
*/
if (result == TCL_OK) {
@@ -2328,13 +2342,9 @@ EnsembleUnknownCallback(
TclDecrRefCount(unknownCmd);
Tcl_ResetResult(interp);
- /*
- * Namespace is still there. Check if the result is a valid list. If
- * it is, and it is non-empty, that list is what we are using as our
- * replacement.
- */
+ /* A non-empty list is the replacement command. */
- if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
+ if (TclListObjLengthM(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
TclDecrRefCount(*prefixObjPtr);
Tcl_AddErrorInfo(interp, "\n while parsing result of "
"ensemble unknown subcommand handler");
@@ -2345,7 +2355,7 @@ EnsembleUnknownCallback(
}
/*
- * Namespace alive & empty result => reparse.
+ * Empty result => reparse.
*/
TclDecrRefCount(*prefixObjPtr);
@@ -2353,7 +2363,7 @@ EnsembleUnknownCallback(
}
/*
- * Oh no! An exceptional result. Convert to an error.
+ * Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
@@ -2378,7 +2388,7 @@ EnsembleUnknownCallback(
"ensemble unknown subcommand handler: ");
Tcl_AppendObjToErrorInfo(interp, unknownCmd);
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
- NULL);
+ (void *)NULL);
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
@@ -2393,16 +2403,16 @@ EnsembleUnknownCallback(
*
* MakeCachedEnsembleCommand --
*
- * Cache what we've computed so far; it's not nice to repeatedly copy
- * strings about. Note that to do this, we start by deleting any old
- * representation that there was (though if it was an out of date
- * ensemble rep, we can skip some of the deallocation process.)
+ * Caches what has been computed so far to minimize string copying.
+ * Starts by deleting any existing representation but reusing the existing
+ * structure if it is an ensembleCmd.
*
* Results:
- * None
+ * None.
*
* Side effects:
- * Alters the internal representation of the first object parameter.
+ * Converts the internal representation of the given object to an
+ * ensembleCmd.
*
*----------------------------------------------------------------------
*/
@@ -2416,22 +2426,19 @@ MakeCachedEnsembleCommand(
{
EnsembleCmdRep *ensembleCmd;
- if (objPtr->typePtr == &ensembleCmdType) {
- ensembleCmd = (EnsembleCmdRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ ECRGetInternalRep(objPtr, ensembleCmd);
+ if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
/*
- * Kill the old internal rep, and replace it with a brand new one of
- * our own.
+ * Replace any old internal representation with a new one.
*/
- TclFreeIntRep(objPtr);
ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &ensembleCmdType;
+ ECRSetInternalRep(objPtr, ensembleCmd);
}
/*
@@ -2453,17 +2460,16 @@ MakeCachedEnsembleCommand(
*
* DeleteEnsembleConfig --
*
- * Destroys the data structure used to represent an ensemble. This is
- * called when the ensemble's command is deleted (which happens
- * automatically if the ensemble's namespace is deleted.) Maintainers
- * should note that ensembles should be deleted by deleting their
- * commands.
+ * Destroys the data structure used to represent an ensemble. Called when
+ * the procedure for the ensemble is deleted, which happens automatically
+ * if the namespace for the ensemble is deleted. Deleting the procedure
+ * for an ensemble is the right way to initiate cleanup.
*
* Results:
* None.
*
* Side effects:
- * Memory is (eventually) deallocated.
+ * Memory is eventually deallocated.
*
*----------------------------------------------------------------------
*/
@@ -2490,15 +2496,12 @@ ClearTable(
static void
DeleteEnsembleConfig(
- ClientData clientData)
+ void *clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
- /*
- * Unlink from the ensemble chain if it has not been marked as having been
- * done already.
- */
+ /* Unlink from the ensemble chain if it not already marked as unlinked. */
if (ensemblePtr->next != ensemblePtr) {
EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
@@ -2524,7 +2527,7 @@ DeleteEnsembleConfig(
ensemblePtr->flags |= ENSEMBLE_DEAD;
/*
- * Kill the pointer-containing fields.
+ * Release the fields that contain pointers.
*/
ClearTable(ensemblePtr);
@@ -2542,10 +2545,9 @@ DeleteEnsembleConfig(
}
/*
- * Arrange for the structure to be reclaimed. Note that this is complex
- * because we have to make sure that we can react sensibly when an
- * ensemble is deleted during the process of initialising the ensemble
- * (especially the unknown callback.)
+ * Arrange for the structure to be reclaimed. This is complex because it is
+ * necessary to react sensibly when an ensemble is deleted during its
+ * initialisation, particularly in the case of an unknown callback.
*/
Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
@@ -2556,10 +2558,11 @@ DeleteEnsembleConfig(
*
* BuildEnsembleConfig --
*
- * Create the internal data structures that describe how an ensemble
- * looks, being a hash mapping from the simple command name to the Tcl list
- * that describes the implementation prefix words, and a sorted array of
- * the names to allow for reasonably efficient unambiguous prefix handling.
+ * Creates the internal data structures that describe how an ensemble
+ * looks. The structures are a hash map from the full command name to the
+ * Tcl list that describes the implementation prefix words, and a sorted
+ * array of all the full command names to allow for reasonably efficient
+ * handling of an unambiguous prefix.
*
* Results:
* None.
@@ -2567,7 +2570,7 @@ DeleteEnsembleConfig(
* Side effects:
* Reallocates and rebuilds the hash table and array stored at the
* ensemblePtr argument. For large ensembles or large namespaces, this is
- * a potentially expensive operation.
+ * may be an expensive operation.
*
*----------------------------------------------------------------------
*/
@@ -2576,10 +2579,10 @@ static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)
{
- Tcl_HashSearch search; /* Used for scanning the set of commands in
- * the namespace that backs up this
- * ensemble. */
- int i, j, isNew;
+ Tcl_HashSearch search; /* Used for scanning the commands in
+ * the namespace for this ensemble. */
+ Tcl_Size i, j;
+ int isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
@@ -2589,19 +2592,19 @@ BuildEnsembleConfig(
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
if (subList) {
- int subc;
+ Tcl_Size subc;
Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
- char *name;
+ const char *name;
/*
* There is a list of exactly what subcommands go in the table.
- * Must determine the target for each.
+ * Determine the target for each.
*/
- TclListObjGetElements(NULL, subList, &subc, &subv);
+ TclListObjGetElementsM(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
- * Strange case where explicit list of subcommands is same value
+ * Unusual case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
@@ -2625,7 +2628,9 @@ BuildEnsembleConfig(
}
}
} else {
- /* Usual case where we can freely act on the list and dict. */
+ /*
+ * Usual case where we can freely act on the list and dict.
+ */
for (i = 0; i < subc; i++) {
name = TclGetString(subv[i]);
@@ -2634,7 +2639,10 @@ BuildEnsembleConfig(
continue;
}
- /* Lookup target in the dictionary */
+ /*
+ * Lookup target in the dictionary.
+ */
+
if (mapDict) {
Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
if (target) {
@@ -2645,11 +2653,12 @@ BuildEnsembleConfig(
}
/*
- * target was not in the dictionary so map onto the namespace.
- * Note in this case that we do not guarantee that the
- * command is actually there; that is the programmer's
- * responsibility (or [::unknown] of course).
+ * Target was not in the dictionary. Map onto the namespace.
+ * In this case there is no guarantee that the command
+ * is actually there. It is the responsibility of the
+ * programmer (or [::unknown] of course) to provide the procedure.
*/
+
cmdObj = Tcl_NewStringObj(name, -1);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
@@ -2658,9 +2667,9 @@ BuildEnsembleConfig(
}
} else if (mapDict) {
/*
- * No subcmd list, but we do have a mapping dictionary so we should
- * use the keys of that. Convert the dictionary's contents into the
- * form required for the ensemble's internal hashtable.
+ * No subcmd list, but there is a mapping dictionary, so
+ * use the keys of that. Convert the contents of the dictionary into the
+ * form required for the internal hashtable of the ensemble.
*/
Tcl_DictSearch dictSearch;
@@ -2670,7 +2679,7 @@ BuildEnsembleConfig(
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
- char *name = TclGetString(keyObj);
+ const char *name = TclGetString(keyObj);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
Tcl_SetHashValue(hPtr, valueObj);
@@ -2679,24 +2688,21 @@ BuildEnsembleConfig(
}
} else {
/*
- * Discover what commands are actually exported by the namespace.
- * What we have is an array of patterns and a hash table whose keys
- * are the command names exported by the namespace (the contents do
- * not matter here.) We must find out what commands are actually
- * exported by filtering each command in the namespace against each of
- * the patterns in the export list. Note that we use an intermediate
- * hash table to make memory management easier, and because that makes
- * exact matching far easier too.
+ * Use the array of patterns and the hash table whose keys are the
+ * commands exported by the namespace. The corresponding values do not
+ * matter here. Filter the commands in the namespace against the
+ * patterns in the export list to find out what commands are actually
+ * exported. Use an intermediate hash table to make memory management
+ * easier and to make exact matching much easier.
*
- * Suggestion for future enhancement: compute the unique prefixes and
- * place them in the hash too, which should make for even faster
- * matching.
+ * Suggestion for future enhancement: Compute the unique prefixes and
+ * place them in the hash too for even faster matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- char *nsCmdName = (char *) /* Name of command in namespace. */
- Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
+ char *nsCmdName = /* Name of command in namespace. */
+ (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
@@ -2716,7 +2722,7 @@ BuildEnsembleConfig(
Tcl_AppendStringsToObj(cmdObj,
ensemblePtr->nsPtr->fullName,
(ensemblePtr->nsPtr->parentPtr ? "::" : ""),
- nsCmdName, NULL);
+ nsCmdName, (void *)NULL);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
@@ -2733,24 +2739,24 @@ BuildEnsembleConfig(
}
/*
- * Create a sorted array of all subcommands in the ensemble; hash tables
+ * Create a sorted array of all subcommands in the ensemble. Hash tables
* are all very well for a quick look for an exact match, but they can't
- * determine things like whether a string is a prefix of another (not
- * without lots of preparation anyway) and they're no good for when we're
- * generating the error message either.
+ * determine things like whether a string is a prefix of another, at least
+ * not without a lot of preparation, and they're not useful for generating
+ * the error message either.
*
- * We do this by filling an array with the names (we use the hash keys
- * directly to save a copy, since any time we change the array we change
- * the hash too, and vice versa) and running quicksort over the array.
+ * Do this by filling an array with the names: Use the hash keys
+ * directly to save a copy since any time we change the array we change
+ * the hash too, and vice versa, and run quicksort over the array.
*/
- ensemblePtr->subcommandArrayPtr = (char **)
- ckalloc(sizeof(char *) * hash->numEntries);
+ ensemblePtr->subcommandArrayPtr =
+ (char **)ckalloc(sizeof(char *) * hash->numEntries);
/*
- * Fill array from both ends as this makes us less likely to end up with
- * performance problems in qsort(), which is good. Note that doing this
- * makes this code much more opaque, but the naive alternatve:
+ * Fill the array from both ends as this reduces the likelihood of
+ * performance problems in qsort(). This makes this code much more opaque,
+ * but the naive alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
* hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
@@ -2758,11 +2764,11 @@ BuildEnsembleConfig(
* }
*
* can produce long runs of precisely ordered table entries when the
- * commands in the namespace are declared in a sorted fashion (an ordering
- * some people like) and the hashing functions (or the command names
- * themselves) are fairly unfortunate. By filling from both ends, it
- * requires active malice (and probably a debugger) to get qsort() to have
- * awful runtime behaviour.
+ * commands in the namespace are declared in a sorted fashion, which is an
+ * ordering some people like, and the hashing functions or the command
+ * names themselves are fairly unfortunate. Filling from both ends means
+ * that it requires active malice, and probably a debugger, to get qsort()
+ * to have awful runtime behaviour.
*/
i = 0;
@@ -2778,7 +2784,7 @@ BuildEnsembleConfig(
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
- qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
+ qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
@@ -2788,8 +2794,7 @@ BuildEnsembleConfig(
*
* NsEnsembleStringOrder --
*
- * Helper function to compare two pointers to two strings for use with
- * qsort().
+ * Helper to for uset with sort() that compares two string pointers.
*
* Results:
* -1 if the first string is smaller, 1 if the second string is smaller,
@@ -2832,14 +2837,14 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
+ ECRGetInternalRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
- objPtr->typePtr = NULL;
}
/*
@@ -2865,11 +2870,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
- copyPtr->typePtr = &ensembleCmdType;
- copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
+ ECRGetInternalRep(objPtr, ensembleCmd);
+ ECRSetInternalRep(copyPtr, ensembleCopy);
+
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
@@ -2916,14 +2922,15 @@ TclCompileEnsemble(
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
- int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int result, flags = 0, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
- unsigned numBytes;
+ Tcl_Size i, len;
+ TCL_HASH_TYPE numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
- if (parsePtr->numWords < depth + 1) {
+ if (parsePtr->numWords <= depth) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -2988,15 +2995,15 @@ TclCompileEnsemble(
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
- int sclen;
+ Tcl_Size sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
- if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, listObj, &len, &elems) != TCL_OK) {
goto failed;
}
for (i=0 ; i<len ; i++) {
- str = Tcl_GetStringFromObj(elems[i], &sclen);
+ str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
@@ -3044,7 +3051,7 @@ TclCompileEnsemble(
* No map, so check the dictionary directly.
*/
- TclNewStringObj(subcmdObj, word, (int) numBytes);
+ TclNewStringObj(subcmdObj, word, numBytes);
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
if (result == TCL_OK && targetCmdObj != NULL) {
/*
@@ -3112,7 +3119,7 @@ TclCompileEnsemble(
doneMapLookup:
Tcl_ListObjAppendElement(NULL, replaced, replacement);
- if (TclListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
} else if (len != 1) {
/*
@@ -3166,7 +3173,7 @@ TclCompileEnsemble(
}
/*
- * Now we've done the mapping process, can now actually try to compile.
+ * Now that the mapping process is done we actually try to compile.
* If there is a subcommand compiler and that successfully produces code,
* we'll use that. Otherwise, we fall back to generating opcodes to do the
* invoke at runtime.
@@ -3183,7 +3190,7 @@ TclCompileEnsemble(
* Throw out any line information generated by the failed compile attempt.
*/
- while (mapPtr->nuloc - 1 > eclIndex) {
+ while (mapPtr->nuloc > eclIndex + 1) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
@@ -3245,19 +3252,20 @@ int
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- int depth,
+ Tcl_Size depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
- int result, i;
+ int result;
+ Tcl_Size i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
- unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
- int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
- int savedExceptArrayNext = envPtr->exceptArrayNext;
+ Tcl_Size savedStackDepth = envPtr->currStackDepth;
+ TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ Tcl_Size savedAuxDataArrayNext = envPtr->auxDataArrayNext;
+ Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
- int savedExceptDepth = envPtr->exceptDepth;
+ Tcl_Size savedExceptDepth = envPtr->exceptDepth;
#endif
if (cmdPtr->compileProc == NULL) {
@@ -3266,9 +3274,9 @@ TclAttemptCompileProc(
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
- * This will be wrong, but it will not matter, and it will put the
- * tokens for the arguments in the right place without the needed to
- * allocate a synthetic Tcl_Parse struct, or copy tokens around.
+ * This will be wrong but it will not matter, and it will put the
+ * tokens for the arguments in the right place without the need to
+ * allocate a synthetic Tcl_Parse struct or copy tokens around.
*/
for (i = 0; i < depth - 1; i++) {
@@ -3385,8 +3393,9 @@ CompileToInvokedCommand(
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
- char *bytes;
- int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ const char *bytes;
+ int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ Tcl_Size i, numWords, length;
/*
* Push the words of the command. Take care; the command words may be
@@ -3394,19 +3403,19 @@ CompileToInvokedCommand(
* difference. Hence the call to TclContinuationsEnterDerived...
*/
- TclListObjGetElements(NULL, replacements, &numWords, &words);
+ TclListObjGetElementsM(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
- if (i > 0 && i < numWords+1) {
- bytes = Tcl_GetStringFromObj(words[i-1], &length);
+ if (i > 0 && i <= numWords) {
+ bytes = TclGetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- int literal = TclRegisterNewLiteral(envPtr,
- tokPtr[1].start, tokPtr[1].size);
+ int literal = TclRegisterLiteral(envPtr,
+ tokPtr[1].start, tokPtr[1].size, 0);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
@@ -3427,11 +3436,11 @@ CompileToInvokedCommand(
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 7d0c61c..ef5cfb7 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -6,8 +6,8 @@
* is primarily responsible for keeping the "env" arrays in sync with the
* system environment variables.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 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.
@@ -19,10 +19,10 @@ TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
-# define tenviron2utfdstr(str, dsPtr) \
- Tcl_WinTCharToUtf((TCHAR *)str, -1, dsPtr)
-# define utf2tenvirondstr(str, dsPtr) \
- (const WCHAR *)Tcl_WinUtfToTChar(str, -1, dsPtr)
+# define tenviron2utfdstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(str), -1, (dsPtr)))
+# define utf2tenvirondstr(str, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (const WCHAR *)Tcl_UtfToChar16DString((str), -1, (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
@@ -42,7 +42,7 @@ size_t TclEnvEpoch = 0; /* Epoch of the tcl environment
* (if changed with tcl-env). */
static struct {
- int cacheSize; /* Number of env strings in cache. */
+ Tcl_Size cacheSize; /* Number of env strings in cache. */
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
@@ -50,7 +50,7 @@ static struct {
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
- int ourEnvironSize; /* Non-zero means that the environ array was
+ Tcl_Size ourEnvironSize; /* Non-zero means that the environ array was
* malloced and has this many total entries
* allocated to it (not all may be in use at
* once). Zero means that the environment
@@ -64,7 +64,7 @@ static struct {
* Declarations for local functions defined in this file:
*/
-static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
+static char * EnvTraceProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static void ReplaceString(const char *oldStr, char *newStr);
MODULE_SCOPE void TclSetEnv(const char *name, const char *value);
@@ -160,6 +160,10 @@ TclSetupEnv(
char *p2;
p1 = tenviron2utfdstr(tenviron[i], &envString);
+ if (p1 == NULL) {
+ /* Ignore what cannot be decoded (should not happen) */
+ continue;
+ }
p2 = (char *)strchr(p1, '=');
if (p2 == NULL) {
/*
@@ -253,8 +257,8 @@ TclSetEnv(
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
- unsigned nameLength, valueLength;
- int index, length;
+ Tcl_Size nameLength, valueLength;
+ Tcl_Size index, length;
char *p, *oldValue;
const techar *p2;
@@ -267,7 +271,7 @@ TclSetEnv(
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
- if (index == -1) {
+ if (index == TCL_INDEX_NONE) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
@@ -302,8 +306,8 @@ TclSetEnv(
*/
oldEnv = tenviron2utfdstr(tenviron[index], &envString);
- if (strcmp(value, oldEnv + (length + 1)) == 0) {
- Tcl_DStringFree(&envString);
+ if (oldEnv == NULL || strcmp(value, oldEnv + (length + 1)) == 0) {
+ Tcl_DStringFree(&envString); /* OK even if oldEnv is NULL */
Tcl_MutexUnlock(&envMutex);
return;
}
@@ -325,6 +329,12 @@ TclSetEnv(
p[nameLength] = '=';
memcpy(p+nameLength+1, value, valueLength+1);
p2 = utf2tenvirondstr(p, &envString);
+ if (p2 == NULL) {
+ /* No way to signal error from here :-( but should not happen */
+ ckfree(p);
+ Tcl_MutexUnlock(&envMutex);
+ return;
+ }
/*
* Copy the native string to heap memory.
@@ -351,7 +361,7 @@ TclSetEnv(
* string in the cache.
*/
- if ((index != -1) && (tenviron[index] == (techar *)p)) {
+ if ((index != TCL_INDEX_NONE) && (tenviron[index] == (techar *)p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
@@ -415,7 +425,7 @@ Tcl_PutEnv(
* name and value parts, and call TclSetEnv to do all of the real work.
*/
- name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
+ name = Tcl_ExternalToUtfDString(NULL, assignment, TCL_INDEX_NONE, &nameString);
value = (char *)strchr(name, '=');
if ((value != NULL) && (value != name)) {
@@ -462,7 +472,7 @@ TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
- int length, index;
+ Tcl_Size length, index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
@@ -511,7 +521,11 @@ TclUnsetEnv(
string[length] = '\0';
#endif /* _WIN32 */
- utf2tenvirondstr(string, &envString);
+ if (utf2tenvirondstr(string, &envString) == NULL) {
+ /* Should not happen except memory alloc fail. */
+ Tcl_MutexUnlock(&envMutex);
+ return;
+ }
string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL);
memcpy(string, Tcl_DStringValue(&envString),
Tcl_DStringLength(&envString) + tNTL);
@@ -577,7 +591,7 @@ TclGetEnv(
* value of the environment variable is
* stored. */
{
- int length, index;
+ Tcl_Size length, index;
const char *result;
Tcl_MutexLock(&envMutex);
@@ -587,16 +601,18 @@ TclGetEnv(
Tcl_DString envStr;
result = tenviron2utfdstr(tenviron[index], &envStr);
- result += length;
- if (*result == '=') {
- result++;
- Tcl_DStringInit(valuePtr);
- Tcl_DStringAppend(valuePtr, result, -1);
- result = Tcl_DStringValue(valuePtr);
- } else {
- result = NULL;
+ if (result) {
+ result += length;
+ if (*result == '=') {
+ result++;
+ Tcl_DStringInit(valuePtr);
+ Tcl_DStringAppend(valuePtr, result, -1);
+ result = Tcl_DStringValue(valuePtr);
+ } else {
+ result = NULL;
+ }
+ Tcl_DStringFree(&envStr);
}
- Tcl_DStringFree(&envStr);
}
Tcl_MutexUnlock(&envMutex);
return result;
@@ -625,7 +641,7 @@ TclGetEnv(
static char *
EnvTraceProc(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
@@ -712,7 +728,7 @@ ReplaceString(
const char *oldStr, /* Old environment string. */
char *newStr) /* New environment string. */
{
- int i;
+ Tcl_Size i;
/*
* Check to see if the old value was allocated by Tcl. If so, it needs to
@@ -791,7 +807,7 @@ TclFinalizeEnvironment(void)
if (env.cache) {
#ifdef PURIFY
- int i;
+ Tcl_Size i;
for (i = 0; i < env.cacheSize; i++) {
ckfree(env.cache[i]);
}
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 35136e1..ef87c47 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -5,15 +5,16 @@
* background errors, exit handlers, and the "vwait" and "update" command
* functions.
*
- * Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Zoran Vasiljevic.
+ * Copyright © 1990-1994 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2004 Zoran Vasiljevic.
*
* 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 "tclUuid.h"
/*
* The data structure below is used to report background errors. One such
@@ -49,13 +50,26 @@ typedef struct {
} ErrAssocData;
/*
+ * For each "vwait" event source a structure of the following type
+ * is used:
+ */
+
+typedef struct {
+ int *donePtr; /* Pointer to flag to signal or NULL. */
+ int sequence; /* Order of occurrence. */
+ int mask; /* 0, or TCL_READABLE/TCL_WRITABLE. */
+ Tcl_Obj *sourceObj; /* Name of the event source, either a
+ * variable name or channel name. */
+} VwaitItem;
+
+/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
- ClientData clientData; /* One word of information to pass to proc. */
+ void *clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
@@ -83,6 +97,8 @@ static int inExit = 0;
static int subsystemsInitialized = 0;
+static const char ENCODING_ERROR[] = "\n\t(encoding error in stderr)";
+
/*
* This variable contains the application wide exit handler. It will be called
* by Tcl_Exit instead of the C-runtime exit if this variable is set to a
@@ -100,22 +116,25 @@ typedef struct ThreadSpecificData {
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-#ifdef TCL_THREADS
+#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
- ClientData clientData; /* The one argument to Main() */
+ void *clientData; /* The one argument to Main() */
} ThreadClientData;
-static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
+static Tcl_ThreadCreateType NewThreadProc(void *clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
-static void BgErrorDeleteProc(ClientData clientData,
+static void BgErrorDeleteProc(void *clientData,
Tcl_Interp *interp);
-static void HandleBgErrors(ClientData clientData);
-static char * VwaitVarProc(ClientData clientData,
+static void HandleBgErrors(void *clientData);
+static void VwaitChannelReadProc(void *clientData, int mask);
+static void VwaitChannelWriteProc(void *clientData, int mask);
+static void VwaitTimeoutProc(void *clientData);
+static char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
@@ -139,6 +158,8 @@ static void FinalizeThread(int quick);
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef Tcl_BackgroundError
void
Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
@@ -146,6 +167,7 @@ Tcl_BackgroundError(
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
+#endif /* TCL_NO_DEPRECATED */
void
Tcl_BackgroundException(
@@ -198,7 +220,7 @@ Tcl_BackgroundException(
static void
HandleBgErrors(
- ClientData clientData) /* Pointer to ErrAssocData structure. */
+ void *clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
@@ -214,7 +236,8 @@ HandleBgErrors(
Tcl_Preserve(assocPtr);
Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
- int code, prefixObjc;
+ int code;
+ Tcl_Size prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
@@ -226,7 +249,7 @@ HandleBgErrors(
errPtr = assocPtr->firstBgPtr;
- TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
+ TclListObjGetElementsM(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
@@ -273,9 +296,13 @@ HandleBgErrors(
Tcl_WriteChars(errChannel,
"error in background error handler:\n", -1);
if (valuePtr) {
- Tcl_WriteObj(errChannel, valuePtr);
+ if (Tcl_WriteObj(errChannel, valuePtr) < 0) {
+ Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
+ }
} else {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
+ }
}
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_Flush(errChannel);
@@ -308,7 +335,7 @@ HandleBgErrors(
int
TclDefaultBgErrorHandlerObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -334,7 +361,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (result != TCL_OK || valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
@@ -347,7 +374,7 @@ TclDefaultBgErrorHandlerObjCmd(
if (result != TCL_OK || valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
@@ -462,18 +489,22 @@ TclDefaultBgErrorHandlerObjCmd(
if (Tcl_FindCommand(interp, "bgerror", NULL,
TCL_GLOBAL_ONLY) == NULL) {
Tcl_RestoreInterpState(interp, saved);
- Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
- "errorInfo", NULL, TCL_GLOBAL_ONLY));
+ if (Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
+ "errorInfo", NULL, TCL_GLOBAL_ONLY)) < 0) {
+ Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_DiscardInterpState(saved);
- Tcl_WriteChars(errChannel,
- "bgerror failed to handle background error.\n",-1);
- Tcl_WriteChars(errChannel, " Original error: ", -1);
- Tcl_WriteObj(errChannel, tempObjv[1]);
- Tcl_WriteChars(errChannel, "\n", -1);
- Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
- Tcl_WriteObj(errChannel, resultPtr);
+ Tcl_WriteChars(errChannel, "bgerror failed to handle"
+ " background error.\n Original error: ", -1);
+ if (Tcl_WriteObj(errChannel, tempObjv[1]) < 0) {
+ Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
+ }
+ Tcl_WriteChars(errChannel, "\n Error in bgerror: ", -1);
+ if (Tcl_WriteObj(errChannel, resultPtr) < 0) {
+ Tcl_WriteChars(errChannel, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_DecrRefCount(resultPtr);
@@ -593,8 +624,8 @@ TclGetBgErrorHandler(
static void
BgErrorDeleteProc(
- ClientData clientData, /* Pointer to ErrAssocData structure. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ void *clientData, /* Pointer to ErrAssocData structure. */
+ TCL_UNUSED(Tcl_Interp *))
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
@@ -632,7 +663,7 @@ BgErrorDeleteProc(
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
@@ -665,7 +696,7 @@ Tcl_CreateExitHandler(
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
@@ -698,7 +729,7 @@ TclCreateLateExitHandler(
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
@@ -741,7 +772,7 @@ Tcl_DeleteExitHandler(
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
@@ -784,7 +815,7 @@ TclDeleteLateExitHandler(
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -817,7 +848,7 @@ Tcl_CreateThreadExitHandler(
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
- ClientData clientData) /* Arbitrary value to pass to proc. */
+ void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -999,7 +1030,7 @@ Tcl_Exit(
/*
*-------------------------------------------------------------------------
*
- * TclInitSubsystems --
+ * Tcl_InitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
@@ -1013,7 +1044,7 @@ Tcl_Exit(
* down another.
*
* Results:
- * The full Tcl version.
+ * The full Tcl version with build information.
*
* Side effects:
* Varied, see the respective initialization routines.
@@ -1023,18 +1054,88 @@ Tcl_Exit(
MODULE_SCOPE const TclStubs tclStubs;
+#ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+#endif
+
static const struct {
const TclStubs *stubs;
const char version[256];
} stubInfo = {
- &tclStubs, {TCL_PATCH_LEVEL}
-};
+ &tclStubs, {TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID)
+#if defined(__clang__) && defined(__clang_major__)
+ ".clang-" STRINGIFY(__clang_major__)
+#if __clang_minor__ < 10
+ "0"
+#endif
+ STRINGIFY(__clang_minor__)
+#endif
+#ifdef TCL_COMPILE_DEBUG
+ ".compiledebug"
+#endif
+#ifdef TCL_COMPILE_STATS
+ ".compilestats"
+#endif
+#if defined(__cplusplus) && !defined(__OBJC__)
+ ".cplusplus"
+#endif
+#ifndef NDEBUG
+ ".debug"
+#endif
+#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
+ ".gcc-" STRINGIFY(__GNUC__)
+#if __GNUC_MINOR__ < 10
+ "0"
+#endif
+ STRINGIFY(__GNUC_MINOR__)
+#endif
+#ifdef __INTEL_COMPILER
+ ".icc-" STRINGIFY(__INTEL_COMPILER)
+#endif
+#if (defined(_WIN32) || (ULONG_MAX == 0xffffffffUL)) && !defined(_WIN64)
+ ".ilp32"
+#endif
+#ifdef TCL_MEM_DEBUG
+ ".memdebug"
+#endif
+#if defined(_MSC_VER)
+ ".msvc-" STRINGIFY(_MSC_VER)
+#endif
+#ifdef USE_NMAKE
+ ".nmake"
+#endif
+#ifdef TCL_NO_DEPRECATED
+ ".no-deprecate"
+#endif
+#if !TCL_THREADS
+ ".no-thread"
+#endif
+#ifndef TCL_CFG_OPTIMIZED
+ ".no-optimize"
+#endif
+#ifdef __OBJC__
+ ".objective-c"
+#if defined(__cplusplus)
+ "plusplus"
+#endif
+#endif
+#ifdef TCL_CFG_PROFILED
+ ".profile"
+#endif
+#ifdef PURIFY
+ ".purify"
+#endif
+#ifdef STATIC_BUILD
+ ".static"
+#endif
+}};
const char *
-TclInitSubsystems(void)
+Tcl_InitSubsystems(void)
{
if (inExit != 0) {
- Tcl_Panic("TclInitSubsystems called while exiting");
+ Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -1057,6 +1158,9 @@ TclInitSubsystems(void)
#if defined(USE_TCLALLOC) && USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
+ TclInitThreadAlloc(); /* Setup thread allocator caches */
+#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
@@ -1232,7 +1336,7 @@ Tcl_Finalize(void)
* Close down the thread-specific object allocator.
*/
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
@@ -1402,78 +1506,435 @@ TclInThreadExit(void)
int
Tcl_VwaitObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int done, foundEvent;
- const char *nameString;
+ int i, done = 0, timedOut = 0, foundEvent, any = 1, timeout = 0;
+ int numItems = 0, extended = 0, result, mode, mask = TCL_ALL_EVENTS;
+ Tcl_InterpState saved = NULL;
+ Tcl_TimerToken timer = NULL;
+ Tcl_Time before, after;
+ Tcl_Channel chan;
+ Tcl_WideInt diff = -1;
+ VwaitItem localItems[32], *vwaitItems = localItems;
+ static const char *const vWaitOptionStrings[] = {
+ "-all", "-extended", "-nofileevents", "-noidleevents",
+ "-notimerevents", "-nowindowevents", "-readable",
+ "-timeout", "-variable", "-writable", "--", NULL
+ };
+ enum vWaitOptions {
+ OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS,
+ OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE,
+ OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST
+ } index;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name");
- return TCL_ERROR;
+ if ((objc == 2) && (strcmp(TclGetString(objv[1]), "--") != 0)) {
+ /*
+ * Legacy "vwait" syntax, skip option handling.
+ */
+ i = 1;
+ goto endOfOptionLoop;
}
- nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done) != TCL_OK) {
- return TCL_ERROR;
- };
- done = 0;
+
+ if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
+ vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1));
+ }
+
+ for (i = 1; i < objc; i++) {
+ const char *name;
+
+ name = TclGetString(objv[i]);
+ if (name[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0,
+ &index) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case OPT_ALL:
+ any = 0;
+ break;
+ case OPT_EXTD:
+ extended = 1;
+ break;
+ case OPT_NO_FEVTS:
+ mask &= ~TCL_FILE_EVENTS;
+ break;
+ case OPT_NO_IEVTS:
+ mask &= ~TCL_IDLE_EVENTS;
+ break;
+ case OPT_NO_TEVTS:
+ mask &= ~TCL_TIMER_EVENTS;
+ break;
+ case OPT_NO_WEVTS:
+ mask &= ~TCL_WINDOW_EVENTS;
+ break;
+ case OPT_TIMEOUT:
+ if (++i >= objc) {
+ needArg:
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "argument required for \"%s\"", vWaitOptionStrings[index]));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (timeout < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timeout must be positive", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ break;
+ case OPT_LAST:
+ i++;
+ goto endOfOptionLoop;
+ case OPT_VARIABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_READABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for reading",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_READABLE,
+ VwaitChannelReadProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_READABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_WRITABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for writing",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_WRITABLE,
+ VwaitChannelWriteProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_WRITABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ }
+ }
+
+ endOfOptionLoop:
+ if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
+ TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't wait: would block forever", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timer events disabled with timeout specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ for (result = TCL_OK; i < objc; i++) {
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ break;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ }
+ if (result != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if (!(mask & TCL_FILE_EVENTS)) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "file events disabled with channel(s) specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ if (timeout > 0) {
+ vwaitItems[numItems].donePtr = &timedOut;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = NULL;
+ timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc,
+ &vwaitItems[numItems]);
+ Tcl_GetTime(&before);
+ } else {
+ timeout = 0;
+ }
+
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * "vwait" is equivalent to "update",
+ * "vwait -nofileevents -notimerevents -nowindowevents"
+ * is equivalent to "update idletasks"
+ */
+ any = 1;
+ mask |= TCL_DONT_WAIT;
+ }
+
foundEvent = 1;
- while (!done && foundEvent) {
- foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ while (!timedOut && foundEvent &&
+ ((!any && (done < numItems)) || (any && !done))) {
+ foundEvent = Tcl_DoOneEvent(mask);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", (void *)NULL);
break;
}
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * Behavior like "update": clear interpreter's result because
+ * event handlers could have executed commands.
+ */
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ goto done;
+ }
}
- Tcl_UntraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done);
if (!foundEvent) {
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't wait for variable \"%s\": would wait forever",
- nameString));
- Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ?
+ "can't wait: would wait forever" :
+ "can't wait for variable(s)/channel(s): would wait forever",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL);
+ result = TCL_ERROR;
+ goto done;
}
- if (!done) {
+
+ if (!done && !timedOut) {
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
*/
+ result = TCL_ERROR;
+ goto done;
+ }
- return TCL_ERROR;
+ result = TCL_OK;
+ if (timeout <= 0) {
+ /*
+ * Clear out the interpreter's result, since it may have been set
+ * by event handlers.
+ */
+ Tcl_ResetResult(interp);
+ goto done;
}
/*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
+ * When timeout was specified, report milliseconds left or -1 on timeout.
*/
+ if (timedOut) {
+ diff = -1;
+ } else {
+ Tcl_GetTime(&after);
+ diff = after.sec * 1000 + after.usec / 1000;
+ diff -= before.sec * 1000 + before.usec / 1000;
+ diff = timeout - diff;
+ if (diff < 0) {
+ diff = 0;
+ }
+ }
- Tcl_ResetResult(interp);
- return TCL_OK;
+ done:
+ if ((timeout > 0) && (timer != NULL)) {
+ Tcl_DeleteTimerHandler(timer);
+ }
+ if (result != TCL_OK) {
+ saved = Tcl_SaveInterpState(interp, result);
+ }
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelReadProc,
+ &vwaitItems[i]);
+ }
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelWriteProc,
+ &vwaitItems[i]);
+ }
+ } else {
+ Tcl_UntraceVar2(interp, TclGetString(vwaitItems[i].sourceObj),
+ NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[i]);
+ }
+ }
+
+ if (result == TCL_OK) {
+ if (extended) {
+ int k;
+ Tcl_Obj *listObj, *keyObj;
+
+ TclNewObj(listObj);
+ for (k = 0; k < done; k++) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].sequence != k) {
+ continue;
+ }
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ TclNewLiteralStringObj(keyObj, "readable");
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ TclNewLiteralStringObj(keyObj, "writable");
+ } else {
+ TclNewLiteralStringObj(keyObj, "variable");
+ }
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ vwaitItems[i].sourceObj);
+ }
+ }
+ if (timeout > 0) {
+ TclNewLiteralStringObj(keyObj, "timeleft");
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ Tcl_NewWideIntObj(diff));
+ }
+ Tcl_SetObjResult(interp, listObj);
+ } else if (timeout > 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(diff));
+ }
+ } else {
+ result = Tcl_RestoreInterpState(interp, saved);
+ }
+ if (vwaitItems != localItems) {
+ ckfree(vwaitItems);
+ }
+ return result;
+}
+
+static void
+VwaitChannelReadProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_READABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_READABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitChannelWriteProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_WRITABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_WRITABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitTimeoutProc(
+ void *clientData) /* Pointer to vwait info record. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->donePtr[0] = 1;
+ itemPtr->donePtr = NULL;
+ }
}
static char *
VwaitVarProc(
- ClientData clientData, /* Pointer to integer to set to 1. */
+ void *clientData, /* Pointer to vwait info record. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
- int flags) /* Information about what happened. */
+ TCL_UNUSED(int) /*flags*/) /* Information about what happened. */
{
- int *donePtr = (int *)clientData;
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
- *donePtr = 1;
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
@@ -1498,15 +1959,15 @@ VwaitVarProc(
int
Tcl_UpdateObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static const char *const updateOptions[] = {"idletasks", NULL};
enum updateOptionsEnum {OPT_IDLETASKS};
+ int optionIndex;
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
@@ -1517,7 +1978,7 @@ Tcl_UpdateObjCmd(
}
switch ((enum updateOptionsEnum) optionIndex) {
case OPT_IDLETASKS:
- flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
@@ -1547,7 +2008,7 @@ Tcl_UpdateObjCmd(
return TCL_OK;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1566,10 +2027,10 @@ Tcl_UpdateObjCmd(
static Tcl_ThreadCreateType
NewThreadProc(
- ClientData clientData)
+ void *clientData)
{
ThreadClientData *cdPtr = (ThreadClientData *)clientData;
- ClientData threadClientData;
+ void *threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
@@ -1605,12 +2066,12 @@ int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
- ClientData clientData, /* The one argument to Main() */
- int stackSize, /* Size of stack for the new thread */
+ void *clientData, /* The one argument to Main() */
+ TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData));
int result;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5950b86..fd955f5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3,13 +3,13 @@
*
* This file contains procedures that execute byte-compiled Tcl commands.
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2002-2010 Miguel Sofer.
- * Copyright (c) 2005-2007 Donal K. Fellows.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
- * Copyright (c) 2006-2008 Joe Mistachkin. All rights reserved.
+ * Copyright © 1996-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2002-2010 Miguel Sofer.
+ * Copyright © 2005-2007 Donal K. Fellows.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,7 +18,7 @@
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
@@ -34,14 +34,14 @@
#endif
/*
- * A mask (should be 2**n-1) that is used to work out when the bytecode engine
- * should call Tcl_AsyncReady() to see whether there is a signal that needs
- * handling.
+ * A counter that is used to work out when the bytecode engine should call
+ * Tcl_AsyncReady() to see whether there is a signal that needs handling, and
+ * other expensive periodic operations.
*/
-#ifndef ASYNC_CHECK_COUNT_MASK
-# define ASYNC_CHECK_COUNT_MASK 63
-#endif /* !ASYNC_CHECK_COUNT_MASK */
+#ifndef ASYNC_CHECK_COUNT
+# define ASYNC_CHECK_COUNT 64
+#endif /* !ASYNC_CHECK_COUNT */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -97,9 +97,9 @@ static const char *const resultStrings[] = {
*/
#ifdef TCL_COMPILE_STATS
-long tclObjsAlloced = 0;
-long tclObjsFreed = 0;
-long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+size_t tclObjsAlloced = 0;
+size_t tclObjsFreed = 0;
+size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
@@ -166,14 +166,13 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
* Minimal data required to fully reconstruct the execution state.
*/
-typedef struct TEBCdata {
+typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
- ptrdiff_t *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. */
- void *stack[1]; /* Start of the actual combined catch and obj
+ Tcl_Obj **catchTop; /* These fields are used on return TO this */
+ Tcl_Obj *auxObjList; /* level: they record the state when a new */
+ CmdFrame cmdFrame; /* 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;
@@ -202,7 +201,7 @@ typedef struct TEBCdata {
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
- auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1; \
+ auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \
Tcl_DecrRefCount(tmpPtr); \
} while (0)
@@ -211,7 +210,7 @@ typedef struct TEBCdata {
*/
#define VarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static inline Var *
VarHashCreateVar(
@@ -424,7 +423,7 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
-#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
+#define CURR_DEPTH (tosPtr - initTosPtr)
#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
@@ -437,9 +436,9 @@ VarHashCreateVar(
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned) (pc - codePtr->codeStart), \
+ fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
@@ -453,9 +452,9 @@ VarHashCreateVar(
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned) (pc - codePtr->codeStart), \
+ fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \
+ CURR_DEPTH, \
+ (pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
@@ -502,61 +501,26 @@ VarHashCreateVar(
/*
* Macro used in this file to save a function call for common uses of
- * TclGetNumberFromObj(). The ANSI C "prototype" is:
+ * Tcl_GetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- * ClientData *ptrPtr, int *tPtr);
+ * void **ptrPtr, int *tPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
-#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
- ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
- ? (*(tPtr) = TCL_NUMBER_NAN) \
- : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
- (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
- TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclWideIntType) \
- ? (*(tPtr) = TCL_NUMBER_WIDE, \
- *(ptrPtr) = (ClientData) \
+ ((TclHasInternalRep((objPtr), &tclIntType)) \
+ ? (*(tPtr) = TCL_NUMBER_INT, \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
- ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
+ TclHasInternalRep((objPtr), &tclDoubleType) \
+ ? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
- TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
-
-/*
- * Macro used in this file to save a function call for common uses of
- * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
- *
- * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- * int *intPtr);
- */
-
-#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- ((((objPtr)->typePtr == &tclIntType) \
- || ((objPtr)->typePtr == &tclBooleanType)) \
- ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
+ ? TCL_ERROR : \
+ Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -586,40 +550,6 @@ VarHashCreateVar(
* Auxiliary tables used to compute powers of small integers.
*/
-#if (LONG_MAX == 0x7FFFFFFF)
-
-/*
- * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
- * signed integer.
- */
-
-static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
-static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
-
-/*
- * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
- * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
- * powers of i+3; Exp32Value[i] gives the corresponding powers.
- */
-
-static const unsigned short Exp32Index[] = {
- 0, 11, 18, 23, 26, 29, 31, 32, 33
-};
-static const size_t Exp32IndexSize =
- sizeof(Exp32Index) / sizeof(unsigned short);
-static const long Exp32Value[] = {
- 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
- 129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
- 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
- 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
- 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
- 1000000000
-};
-static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
-#endif /* LONG_MAX == 0x7FFFFFFF -- 32 bit machine */
-
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
-
/*
* Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
* Tcl_WideInt.
@@ -723,7 +653,6 @@ static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)371293*371293*371293*13*13
};
static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
-#endif /* (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG) */
/*
* Markers for ExecuteExtendedBinaryMathOp.
@@ -732,30 +661,27 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1)
#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2)
#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3)
+#define OUT_OF_MEMORY ((Tcl_Obj *) -4)
/*
* Declarations for local procedures to this file:
*/
#ifdef TCL_COMPILE_STATS
-static int EvalStatsCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc EvalStatsCmd;
#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, int stackTop,
+ 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);
-MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
- Tcl_Obj *value2Ptr);
static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp,
int opcode, Tcl_Obj **constants,
Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr);
@@ -765,9 +691,9 @@ 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, int *lengthPtr,
- const unsigned char **pcBeg, int *cmdIdxPtr);
-static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
+ ByteCode *codePtr, Tcl_Size *lengthPtr,
+ const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr);
+static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, TCL_HASH_TYPE growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj *opndPtr);
@@ -775,8 +701,8 @@ 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? */
-static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
-static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
+static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords);
+static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords);
static Tcl_NRPostProc CopyCallback;
static Tcl_NRPostProc ExprObjCallback;
static Tcl_NRPostProc FinalizeOONext;
@@ -830,20 +756,22 @@ ReleaseDictIterator(
{
Tcl_DictSearch *searchPtr;
Tcl_Obj *dictPtr;
+ const Tcl_ObjInternalRep *irPtr;
+
+ irPtr = TclFetchInternalRep(objPtr, &dictIteratorType);
+ assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
- searchPtr = (Tcl_DictSearch *)objPtr->internalRep.twoPtrValue.ptr1;
+ searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
- dictPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr2;
+ dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
-
- objPtr->typePtr = NULL;
}
/*
@@ -867,6 +795,7 @@ ReleaseDictIterator(
*----------------------------------------------------------------------
*/
+#if defined(TCL_COMPILE_STATS) || defined(TCL_COMPILE_DEBUG)
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
@@ -874,7 +803,7 @@ InitByteCodeExecution(
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
- if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
+ if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
@@ -883,6 +812,15 @@ InitByteCodeExecution(
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
+
+#else
+
+static void
+InitByteCodeExecution(
+ TCL_UNUSED(Tcl_Interp *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -910,17 +848,17 @@ ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
- int size) /* The initial stack size, in number of words
+ TCL_HASH_TYPE size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
- ExecStack *esPtr = (ExecStack *)ckalloc(TclOffset(ExecStack, stackWords)
+ ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords)
+ size * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
- TclNewBooleanObj(eePtr->constants[0], 0);
+ TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
- TclNewBooleanObj(eePtr->constants[1], 1);
+ TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
eePtr->callbackPtr = NULL;
@@ -1092,15 +1030,15 @@ static Tcl_Obj **
GrowEvaluationStack(
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
- int growth, /* How much larger than the current used
+ TCL_HASH_TYPE growth, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
- int newBytes, newElems, currElems;
- int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
+ TCL_HASH_TYPE newBytes;
+ Tcl_Size newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
- int moveWords = 0;
+ Tcl_Size moveWords = 0;
if (move) {
if (!markerPtr) {
@@ -1180,7 +1118,7 @@ GrowEvaluationStack(
newElems = needed;
#endif
- newBytes = TclOffset(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
+ newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = (ExecStack *)ckalloc(newBytes);
@@ -1243,7 +1181,7 @@ GrowEvaluationStack(
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
- int numWords)
+ TCL_HASH_TYPE numWords)
{
/*
* Note that GrowEvaluationStack sets a marker in the stack. This marker
@@ -1261,7 +1199,7 @@ StackAllocWords(
static Tcl_Obj **
StackReallocWords(
Tcl_Interp *interp,
- int numWords)
+ TCL_HASH_TYPE numWords)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
@@ -1282,7 +1220,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1340,32 +1278,32 @@ TclStackFree(
void *
TclStackAlloc(
Tcl_Interp *interp,
- int numBytes)
+ TCL_HASH_TYPE numBytes)
{
Interp *iPtr = (Interp *) interp;
- int numWords;
+ TCL_HASH_TYPE numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- return (void *) ckalloc(numBytes);
+ return ckalloc(numBytes);
}
numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
- return (void *) StackAllocWords(interp, numWords);
+ return StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
Tcl_Interp *interp,
void *ptr,
- int numBytes)
+ TCL_HASH_TYPE numBytes)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;
- int numWords;
+ TCL_HASH_TYPE numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- return (void *) ckrealloc((char *) ptr, numBytes);
+ return ckrealloc((char *)ptr, numBytes);
}
eePtr = iPtr->execEnvPtr;
@@ -1407,7 +1345,7 @@ int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- Tcl_Obj *objPtr, /* Points to Tcl object containing expression
+ Tcl_Obj *objPtr, /* Points to Tcl object containing expression
* to evaluate. */
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
@@ -1424,8 +1362,8 @@ Tcl_ExprObj(
static int
CopyCallback(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0];
@@ -1482,7 +1420,7 @@ Tcl_NRExprObj(
static int
ExprObjCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1506,11 +1444,9 @@ ExprObjCallback(
*
* Results:
* A (ByteCode *) is returned pointing to the resulting ByteCode.
- * The caller must manage its refCount and arrange for a call to
- * TclCleanupByteCode() when the last reference disappears.
*
* Side effects:
- * The Tcl_ObjType of objPtr is changed to the "bytecode" type,
+ * The Tcl_ObjType of objPtr is changed to the "exprcode" type,
* and the ByteCode is kept in the internal rep (along with context
* data for checking validity) for faster operations the next time
* CompileExprObj is called on the same value.
@@ -1534,24 +1470,28 @@ CompileExprObj(
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &exprCodeType) {
+
+ ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);
+
+ if (codePtr != NULL) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
- FreeExprCodeInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL);
+ codePtr = NULL;
}
}
- if (objPtr->typePtr != &exprCodeType) {
+
+ if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
- int length;
+ Tcl_Size length;
const char *string = TclGetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
@@ -1563,7 +1503,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -1574,10 +1514,8 @@ CompileExprObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1621,8 +1559,8 @@ CompileExprObj(
static void
DupExprCodeInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj *))
{
return;
}
@@ -1649,12 +1587,11 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+ ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr);
+ assert(codePtr != NULL);
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
@@ -1690,7 +1627,8 @@ TclCompileObj(
* compilation). Otherwise, check that it is "fresh" enough.
*/
- if (objPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
@@ -1708,7 +1646,6 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1775,9 +1712,9 @@ TclCompileObj(
return codePtr;
}
- eclPtr = Tcl_GetHashValue(hePtr);
+ eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
redo = 0;
- ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxCopyPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
@@ -1836,7 +1773,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1870,9 +1807,10 @@ TclIncrObj(
Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr)
{
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
int type1, type2;
mp_int value, incr;
+ mp_err err;
if (Tcl_IsShared(valuePtr)) {
Tcl_Panic("%s called with shared object", "TclIncrObj");
@@ -1895,37 +1833,6 @@ TclIncrObj(
return TCL_ERROR;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- long augend = *((const long *) ptr1);
- long addend = *((const long *) ptr2);
- long sum = (long)((unsigned long)augend + (unsigned long)addend);
-
- /*
- * Overflow when (augend and sum have different sign) and (augend and
- * addend have the same sign). This is encapsulated in the Overflowing
- * macro.
- */
-
- if (!Overflowing(augend, addend, sum)) {
- TclSetLongObj(valuePtr, sum);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- {
- Tcl_WideInt w1 = (Tcl_WideInt) augend;
- Tcl_WideInt w2 = (Tcl_WideInt) addend;
-
- /*
- * We know the sum value is outside the long range, so we use the
- * macro form that doesn't range test again.
- */
-
- TclSetWideIntObj(valuePtr, w1 + w2);
- return TCL_OK;
- }
-#endif
- }
-
if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
/*
* Produce error message (reparse?!)
@@ -1943,12 +1850,11 @@ TclIncrObj(
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
Tcl_WideInt w1, w2, sum;
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, incrPtr, &w2);
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
/*
@@ -1956,16 +1862,18 @@ TclIncrObj(
*/
if (!Overflowing(w1, w2, sum)) {
- Tcl_SetWideIntObj(valuePtr, sum);
+ TclSetIntObj(valuePtr, sum);
return TCL_OK;
}
}
-#endif
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
- mp_add(&value, &incr, &value);
+ err = mp_add(&value, &incr, &value);
mp_clear(&incr);
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
Tcl_SetBignumObj(valuePtr, &value);
return TCL_OK;
}
@@ -1994,10 +1902,10 @@ ArgumentBCEnter(
ByteCode *codePtr,
TEBCdata *tdPtr,
const unsigned char *pc,
- int objc,
+ Tcl_Size objc,
Tcl_Obj **objv)
{
- int cmd;
+ Tcl_Size cmd;
if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
@@ -2024,8 +1932,8 @@ ArgumentBCEnter(
*----------------------------------------------------------------------
*/
#define bcFramePtr (&TD->cmdFrame)
-#define initCatchTop ((ptrdiff_t *) (TD->stack-1))
-#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
+#define initCatchTop (TD->stack-1)
+#define initTosPtr (initCatchTop+codePtr->maxExceptDepth)
#define esPtr (iPtr->execEnvPtr->execStackPtr)
int
@@ -2035,12 +1943,12 @@ TclNRExecuteByteCode(
{
Interp *iPtr = (Interp *) interp;
TEBCdata *TD;
- int size = sizeof(TEBCdata) - 1
+ TCL_HASH_TYPE size = sizeof(TEBCdata) - 1
+ (codePtr->maxStackDepth + codePtr->maxExceptDepth)
* sizeof(void *);
- int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
+ TCL_HASH_TYPE numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- codePtr->refCount++;
+ TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
@@ -2096,7 +2004,7 @@ TclNRExecuteByteCode(
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
- /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags));
+ /* cleanup */ NULL, INT2PTR(iPtr->evalFlags));
/*
* Reset discard result flag - because it is applicable for this call only,
@@ -2109,7 +2017,7 @@ TclNRExecuteByteCode(
static int
TEBCresume(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2136,8 +2044,14 @@ TEBCresume(
* sporadically: no special need for speed.
*/
- int instructionCount = 0; /* Counter that is used to work out when to
- * call Tcl_AsyncReady() */
+ unsigned interruptCounter = 1;
+ /* Counter that is used to work out when to
+ * call Tcl_AsyncReady(). This must be 1
+ * initially so that we call the async-check
+ * stanza early, otherwise there are command
+ * sequences that can make the interpreter
+ * busy-loop without an opportunity to
+ * recognise an interrupt. */
const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
int traceInstructions; /* Whether we are doing instruction-level
@@ -2155,7 +2069,7 @@ TEBCresume(
* used too frequently
*/
- TEBCdata *TD = data[0];
+ TEBCdata *TD = (TEBCdata *)data[0];
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
@@ -2167,7 +2081,7 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
- const unsigned char *pc = data[1];
+ const unsigned char *pc = (const unsigned char *)data[1];
/* The current program counter. */
unsigned char inst; /* The currently running instruction */
@@ -2189,8 +2103,8 @@ TEBCresume(
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
- int objc = 0;
- int opnd, length, pcAdjustment;
+ Tcl_Size length, objc = 0;
+ int opnd, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
@@ -2206,7 +2120,7 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
- fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
+ fprintf(stdout, " Starting stack top=%" TCL_T_MODIFIER "d\n", CURR_DEPTH);
fflush(stdout);
}
#endif
@@ -2265,7 +2179,7 @@ TEBCresume(
* instruction.
*/
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
+ TRACE_WITH_OBJ(("%" TCL_SIZE_MODIFIER "d => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
/*
@@ -2357,10 +2271,11 @@ TEBCresume(
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
+ * ASYNC_CHECK_COUNT instructions.
*/
- if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
+ if ((--interruptCounter) == 0) {
+ interruptCounter = ASYNC_CHECK_COUNT;
DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
result = Tcl_AsyncInvoke(interp, result);
@@ -2409,7 +2324,7 @@ TEBCresume(
CHECK_STACK();
if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
+ fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
@@ -2508,7 +2423,7 @@ TEBCresume(
{
CoroutineData *corPtr;
- int yieldParameter;
+ void *yieldParameter;
case INST_YIELD:
corPtr = iPtr->execEnvPtr->corPtr;
@@ -2519,7 +2434,7 @@ TEBCresume(
"yield can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -2529,14 +2444,14 @@ TEBCresume(
if (traceInstructions) {
TRACE_APPEND(("YIELD...\n"));
} else {
- fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (pc - codePtr->codeStart),
Tcl_GetString(OBJ_AT_TOS));
}
fflush(stdout);
}
#endif
- yieldParameter = 0;
+ yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/
Tcl_SetObjResult(interp, OBJ_AT_TOS);
goto doYield;
@@ -2550,7 +2465,7 @@ TEBCresume(
"yieldto can only be called in a coroutine", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -2561,7 +2476,7 @@ TEBCresume(
"yieldto called in deleted namespace", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -2572,9 +2487,9 @@ TEBCresume(
TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
} else {
/* FIXME: What is the right thing to trace? */
- fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
- Tcl_GetString(valuePtr));
+ fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding to [%.30s]\n",
+ iPtr->numLevels, (pc - codePtr->codeStart),
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2586,11 +2501,12 @@ TEBCresume(
* 'yieldParameter').
*/
- Tcl_IncrRefCount(valuePtr);
iPtr->execEnvPtr = corPtr->callerEEPtr;
+ Tcl_IncrRefCount(valuePtr);
TclSetTailcall(interp, valuePtr);
+ corPtr->yieldPtr = valuePtr;
iPtr->execEnvPtr = corPtr->eePtr;
- yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
+ yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/
doYield:
/* TIP #280: Record the last piece of info needed by
@@ -2608,7 +2524,7 @@ TEBCresume(
cleanup = 1;
TEBC_YIELD();
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(yieldParameter), NULL, NULL);
+ yieldParameter, NULL, NULL);
return TCL_OK;
}
@@ -2622,7 +2538,7 @@ TEBCresume(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -2734,154 +2650,19 @@ TEBCresume(
}
break;
- case INST_STR_CONCAT1: {
- int appendLen = 0;
- char *bytes, *p;
- Tcl_Obj **currPtr;
- int onlyb = 1;
+ case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
-
- /*
- * Detect only-bytearray-or-null case.
- */
-
- for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
- if (((*currPtr)->typePtr != &tclByteArrayType)
- && ((*currPtr)->bytes != tclEmptyStringRep)) {
- onlyb = 0;
- break;
- } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
- ((*currPtr)->bytes != NULL)) {
- onlyb = 0;
- break;
- }
- }
-
- /*
- * Compute the length to be appended.
- */
-
- if (onlyb) {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- Tcl_GetByteArrayFromObj(*currPtr, &length);
- appendLen += length;
- }
- }
- } else {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- appendLen += length;
- }
- }
- }
-
- if (appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
-
- /*
- * If nothing is to be appended, just return the first object by
- * dropping all the others from the stack; this saves both the
- * computation and copy of the string rep of the first object,
- * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
- */
-
- if (appendLen == 0) {
- TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
- NEXT_INST_V(2, (opnd-1), 0);
- }
-
- /*
- * If the first object is shared, we need a new obj for the result;
- * otherwise, we can reuse the first object. In any case, make sure it
- * has enough room to accommodate all the concatenated bytes. Note that
- * if it is unshared its bytes are copied by ckrealloc, so that we set
- * the loop parameters to avoid copying them again: p points to the
- * end of the already copied bytes, currPtr to the second object.
- */
-
- objResultPtr = OBJ_AT_DEPTH(opnd-1);
- if (!onlyb) {
- bytes = TclGetStringFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
- TclFreeIntRep(objResultPtr);
- objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
- objResultPtr->length = length + appendLen;
- p = TclGetString(objResultPtr) + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- p = ckalloc(length + appendLen + 1);
- TclNewObj(objResultPtr);
- objResultPtr->bytes = p;
- objResultPtr->length = length + appendLen;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- memcpy(p, bytes, length);
- p += length;
- }
- }
- *p = '\0';
- } else {
- bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (!Tcl_IsShared(objResultPtr)) {
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- TclNewObj(objResultPtr);
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
- memcpy(p, bytes, length);
- p += length;
- }
- }
+ objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
+ TCL_STRING_IN_PLACE);
+ if (objResultPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
- }
+ break;
case INST_CONCAT_STK:
/*
@@ -2893,6 +2674,7 @@ TEBCresume(
objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
+ break;
case INST_EXPAND_START:
/*
@@ -2912,7 +2694,7 @@ TEBCresume(
objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
- TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
+ TRACE(("=> mark depth as %" TCL_T_MODIFIER "d\n", CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
@@ -2930,12 +2712,13 @@ TEBCresume(
/* Ugly abuse! */
starting = 1;
#endif
- TRACE(("=> drop %d items\n", objc));
+ TRACE(("=> drop %" TCL_SIZE_MODIFIER "d items\n", objc));
NEXT_INST_V(1, objc, 0);
case INST_EXPAND_STKTOP: {
- int i;
- ptrdiff_t moved;
+ Tcl_Size i;
+ TEBCdata *newTD;
+ ptrdiff_t oldCatchTopOff, oldTosPtrOff;
/*
* Make sure that the element at stackTop is a list; if not, just
@@ -2945,7 +2728,7 @@ TEBCresume(
objPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" => ", O2S(objPtr)));
- if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, objPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -2964,19 +2747,21 @@ TEBCresume(
+ codePtr->maxStackDepth /* Beyond the original max */
- CURR_DEPTH; /* Relative to where we are */
DECACHE_STACK_INFO();
- moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- - (Tcl_Obj **) TD;
- if (moved) {
+ 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 = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+ TD = newTD;
- catchTop += moved;
- tosPtr += moved;
+ catchTop = initCatchTop + oldCatchTopOff;
+ tosPtr = initTosPtr + oldTosPtrOff;
}
}
@@ -3058,14 +2843,14 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
- int i;
+ Tcl_Size i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("%u => call ", objc));
+ TRACE(("%" TCL_SIZE_MODIFIER "d => call ", objc));
} else {
- fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", iPtr->numLevels,
+ (pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -3190,15 +2975,15 @@ TEBCresume(
cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
- int i;
+ Tcl_Size i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
+ TRACE(("%" TCL_SIZE_MODIFIER "d => call (implementation %s) ", objc, O2S(objPtr)));
} else {
fprintf(stdout,
- "%d: (%u) invoking (using implementation %s) ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking (using implementation %s) ",
+ iPtr->numLevels, (pc - codePtr->codeStart),
O2S(objPtr));
}
for (i = 0; i < objc; i++) {
@@ -3240,7 +3025,7 @@ TEBCresume(
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL);
@@ -3400,7 +3185,8 @@ TEBCresume(
*/
{
- int storeFlags, len;
+ int storeFlags;
+ Tcl_Size len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3651,7 +3437,7 @@ TEBCresume(
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3677,7 +3463,7 @@ TEBCresume(
}
TRACE(("%u \"%.30s\" \"%.30s\" => ",
opnd, O2S(part2Ptr), O2S(valuePtr)));
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3719,7 +3505,7 @@ TEBCresume(
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
- if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
+ if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -3730,7 +3516,7 @@ TEBCresume(
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
- if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
+ if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3740,7 +3526,7 @@ TEBCresume(
lappendList:
opnd = -1;
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv)
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3778,7 +3564,7 @@ TEBCresume(
if (!objResultPtr) {
valueToAssign = valuePtr;
- } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
+ } else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
@@ -3788,7 +3574,7 @@ TEBCresume(
} else {
valueToAssign = objResultPtr;
}
- if (Tcl_ListObjReplace(interp, valueToAssign, len, 0,
+ if (TclListObjAppendElements(interp, valueToAssign,
objc, objv) != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(valueToAssign);
@@ -3797,10 +3583,8 @@ TEBCresume(
}
}
DECACHE_STACK_INFO();
- Tcl_IncrRefCount(valueToAssign);
objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd);
- TclDecrRefCount(valueToAssign);
CACHE_STACK_INFO();
if (!objResultPtr) {
errorInLappendListPtr:
@@ -3826,9 +3610,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
-#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3922,14 +3704,14 @@ TEBCresume(
}
if (TclIsVarDirectModifyable(varPtr)) {
- ClientData ptr;
+ void *ptr;
int type;
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
- if (type == TCL_NUMBER_LONG) {
- long augend = *((const long *)ptr);
- long sum = (long)((unsigned long)augend + (unsigned long)increment);
+ if (type == TCL_NUMBER_INT) {
+ Tcl_WideInt augend = *((const Tcl_WideInt *)ptr);
+ Tcl_WideInt sum = (Tcl_WideInt)((Tcl_WideUInt)augend + (Tcl_WideUInt)increment);
/*
* Overflow when (augend and sum have different sign) and
@@ -3941,70 +3723,35 @@ TEBCresume(
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
- TclNewLongObj(objResultPtr, sum);
+ TclNewIntObj(objResultPtr, sum);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
- TclSetLongObj(objPtr, sum);
+ TclSetIntObj(objPtr, sum);
}
goto doneIncr;
}
-#ifndef TCL_WIDE_INT_IS_LONG
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
- objResultPtr = Tcl_NewWideIntObj(w+increment);
+ TclNewIntObj(objResultPtr, w + increment);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
/*
- * We know the sum value is outside the long range;
+ * We know the sum value is outside the Tcl_WideInt range;
* use macro form that doesn't range test again.
*/
- TclSetWideIntObj(objPtr, w+increment);
+ TclSetIntObj(objPtr, w+increment);
}
goto doneIncr;
-#endif
- } /* end if (type == TCL_NUMBER_LONG) */
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt sum;
-
- w = *((const Tcl_WideInt *) ptr);
- sum = (Tcl_WideInt)((Tcl_WideUInt)w + (Tcl_WideUInt)increment);
-
- /*
- * Check for overflow.
- */
-
- if (!Overflowing(w, increment, sum)) {
- TRACE(("%u %ld => ", opnd, increment));
- if (Tcl_IsShared(objPtr)) {
- objPtr->refCount--; /* We know it's shared. */
- objResultPtr = Tcl_NewWideIntObj(sum);
- Tcl_IncrRefCount(objResultPtr);
- varPtr->value.objPtr = objResultPtr;
- } else {
- objResultPtr = objPtr;
-
- /*
- * We *do not* know the sum value is outside the
- * long range (wide + long can yield long); use
- * the function call that checks range.
- */
-
- Tcl_SetWideIntObj(objPtr, sum);
- }
- goto doneIncr;
- }
- }
-#endif
+ } /* end if (type == TCL_NUMBER_INT) */
}
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -4014,7 +3761,7 @@ TEBCresume(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
TRACE_ERROR(interp);
@@ -4028,7 +3775,7 @@ TEBCresume(
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
@@ -4039,7 +3786,7 @@ TEBCresume(
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
+ TRACE(("%u %s => ", opnd, TclGetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -4408,15 +4155,12 @@ TEBCresume(
TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
"variable isn't array", opnd);
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL);
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr,
- TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_APPEND(("done\n"));
} else {
@@ -4560,15 +4304,15 @@ TEBCresume(
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned)(pc + opnd - codePtr->codeStart)));
+ TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd,
+ (size_t)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
break;
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned)(pc + opnd - codePtr->codeStart)));
+ TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd,
+ (size_t)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
{
@@ -4610,8 +4354,8 @@ TEBCresume(
#ifdef TCL_COMPILE_DEBUG
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
- TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr),
+ (size_t)(pc + jmpOffset[1] - codePtr->codeStart)));
} else {
TRACE_APPEND(("%.20s true\n", O2S(valuePtr)));
}
@@ -4619,8 +4363,8 @@ TEBCresume(
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
TRACE_APPEND(("%.20s false\n", O2S(valuePtr)));
} else {
- TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
- (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
+ TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr),
+ (size_t)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -4644,8 +4388,8 @@ TEBCresume(
if (hPtr != NULL) {
int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
- TRACE_APPEND(("found in table, new pc %u\n",
- (unsigned)(pc - codePtr->codeStart + jumpOffset)));
+ TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n",
+ (size_t)(pc - codePtr->codeStart + jumpOffset)));
NEXT_INST_F(jumpOffset, 1, 0);
} else {
TRACE_APPEND(("not found in table\n"));
@@ -4721,7 +4465,7 @@ TEBCresume(
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
- if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
@@ -4757,7 +4501,7 @@ TEBCresume(
TRACE_ERROR(interp);
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
- TclGetString(OBJ_AT_TOS), NULL);
+ TclGetString(OBJ_AT_TOS), (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -4781,21 +4525,27 @@ TEBCresume(
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
if (cmd == NULL) {
+ goto instOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+
+ TclNewObj(objResultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
+ if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(objResultPtr);
+ instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(OBJ_AT_TOS), NULL);
+ TclGetString(OBJ_AT_TOS), (void *)NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
- origCmd = TclGetOriginalCommand(cmd);
- if (origCmd == NULL) {
- origCmd = cmd;
- }
- TclNewObj(objResultPtr);
- Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
@@ -4809,7 +4559,7 @@ TEBCresume(
Object *oPtr;
CallFrame *framePtr;
CallContext *contextPtr;
- int skip, newDepth;
+ Tcl_Size skip, newDepth;
case INST_TCLOO_SELF:
framePtr = iPtr->varFramePtr;
@@ -4820,11 +4570,11 @@ TEBCresume(
"self may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
@@ -4848,11 +4598,11 @@ TEBCresume(
"nextto may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
@@ -4861,7 +4611,7 @@ TEBCresume(
} else {
Class *classPtr = oPtr->classPtr;
struct MInvoke *miPtr;
- int i;
+ Tcl_Size i;
const char *methodType;
if (classPtr == NULL) {
@@ -4869,7 +4619,7 @@ TEBCresume(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(valuePtr)));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -4884,9 +4634,9 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
+ fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ",
iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
+ (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -4910,7 +4660,7 @@ TEBCresume(
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
- for (i=contextPtr->index ; i>=0 ; i--) {
+ for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
miPtr = contextPtr->callPtr->chain + i;
if (miPtr->isFilter
|| miPtr->mPtr->declaringClassPtr != classPtr) {
@@ -4921,7 +4671,7 @@ TEBCresume(
methodType, TclGetString(valuePtr)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -4929,7 +4679,7 @@ TEBCresume(
"%s has no non-filter implementation by \"%s\"",
methodType, TclGetString(valuePtr)));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
@@ -4947,11 +4697,11 @@ TEBCresume(
"next may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
@@ -4976,7 +4726,7 @@ TEBCresume(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
#ifdef TCL_COMPILE_DEBUG
@@ -4986,8 +4736,8 @@ TEBCresume(
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
} else {
- fprintf(stdout, "%d: (%u) invoking ",
- iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+ fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ",
+ iPtr->numLevels, (size_t)(pc - codePtr->codeStart));
}
for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
@@ -5079,8 +4829,8 @@ TEBCresume(
*/
{
- int index, numIndices, fromIdx, toIdx;
- int nocase, match, length2, cflags, s1len, s2len;
+ int numIndices, nocase, match, cflags;
+ Tcl_Size length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
@@ -5096,12 +4846,12 @@ TEBCresume(
case INST_LIST_LENGTH:
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
- if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, OBJ_AT_TOS, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TclNewIntObj(objResultPtr, length);
- TRACE_APPEND(("%d\n", length));
+ TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
@@ -5109,21 +4859,50 @@ TEBCresume(
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+ if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
+ if (objResultPtr == NULL) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ Tcl_IncrRefCount(objResultPtr); // reference held here
+ goto lindexDone;
+ }
+
/*
* Extract the desired list element.
*/
- if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
- && (value2Ptr->typePtr != &tclListType)
- && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
- &index) == TCL_OK)) {
- TclDecrRefCount(value2Ptr);
- tosPtr--;
- pcAdjustment = 1;
- goto lindexFastPath;
+ 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) {
+ TclDecrRefCount(value2Ptr);
+ tosPtr--;
+ pcAdjustment = 1;
+ goto lindexFastPath;
+ }
+ Tcl_ResetResult(interp);
}
+ DECACHE_STACK_INFO();
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+ CACHE_STACK_INFO();
+
+ lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -5147,12 +4926,35 @@ TEBCresume(
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+
+ /* Decode end-offset index values. */
+
+ index = TclIndexDecode(opnd, length-1);
+
+ /* Compute value @ index */
+ if (index >= 0 && index < length) {
+ objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
+ if (objResultPtr == NULL) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ } else {
+ TclNewObj(objResultPtr);
+ }
+ pcAdjustment = 5;
+ goto lindexFastPath2;
+ }
+
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5169,6 +4971,8 @@ TEBCresume(
TclNewObj(objResultPtr);
}
+ lindexFastPath2:
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -5287,11 +5091,11 @@ TEBCresume(
TclGetInt4AtPtr(pc+5)));
/*
- * Get the contents of the list, making sure that it really is a list
+ * Get the length of the list, making sure that it really is a list
* in the process.
*/
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjLengthM(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -5319,17 +5123,11 @@ TEBCresume(
/* Decode index value operands. */
- /*
- assert ( toIdx != TCL_INDEX_AFTER);
- *
- * Extra safety for legacy bytecodes:
- */
- if (toIdx == TCL_INDEX_AFTER) {
- toIdx = TCL_INDEX_END;
- }
-
- if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
- goto emptyList;
+ if (toIdx == TCL_INDEX_NONE) {
+ emptyList:
+ TclNewObj(objResultPtr);
+ TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
+ NEXT_INST_F(9, 1, 1);
}
toIdx = TclIndexDecode(toIdx, objc - 1);
if (toIdx < 0) {
@@ -5338,38 +5136,26 @@ TEBCresume(
toIdx = objc - 1;
}
- assert ( toIdx >= 0 && toIdx < objc);
+ assert (toIdx >= 0 && toIdx < objc);
/*
- assert ( fromIdx != TCL_INDEX_BEFORE );
+ assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (fromIdx == TCL_INDEX_BEFORE) {
+ if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, objc - 1);
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (fromIdx <= toIdx) {
- /* Construct the subsequence list */
- /* unshared optimization */
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
- } else {
- if (toIdx != objc - 1) {
- Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
- 0, NULL);
- }
- Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
- TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
- NEXT_INST_F(9, 0, 0);
- }
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx);
} else {
- emptyList:
- TclNewObj(objResultPtr);
+ objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx);
+ }
+ if (objResultPtr == NULL) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
@@ -5382,21 +5168,25 @@ TEBCresume(
s1 = TclGetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
- if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
match = 0;
if (length > 0) {
- int i = 0;
+ Tcl_Size i = 0;
Tcl_Obj *o;
-
+ int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType);
/*
* An empty list doesn't match anything.
*/
do {
- Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
+ if (isArithSeries) {
+ o = TclArithSeriesObjIndex(NULL, value2Ptr, i);
+ } else {
+ Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
+ }
if (o != NULL) {
s2 = TclGetStringFromObj(o, &s2len);
} else {
@@ -5406,6 +5196,9 @@ TEBCresume(
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
+ if (isArithSeries) {
+ TclDecrRefCount(o);
+ }
i++;
} while (i < length && match == 0);
}
@@ -5447,15 +5240,108 @@ TEBCresume(
NEXT_INST_F(1, 1, 0);
}
- /*
- * End of INST_LIST and related instructions.
- * -----------------------------------------------------------------
- * Start of string-related instructions.
- */
+ case INST_LREPLACE4:
+ {
+ TCL_HASH_TYPE numToDelete, numNewElems;
+ int end_indicator;
+ int haveSecondIndex, flags;
+ Tcl_Obj *fromIdxObj, *toIdxObj;
+ opnd = TclGetInt4AtPtr(pc + 1);
+ flags = TclGetInt1AtPtr(pc + 5);
+
+ /* Stack: ... listobj index1 ?index2? new1 ... newN */
+ valuePtr = OBJ_AT_DEPTH(opnd-1);
+
+ /* haveSecondIndex==0 => pure insert */
+ haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0;
+ numNewElems = opnd - 2 - haveSecondIndex;
+
+ /* end_indicator==1 => "end" is last element's index, 0=>index beyond */
+ end_indicator = (flags & TCL_LREPLACE4_END_IS_LAST) != 0;
+ fromIdxObj = OBJ_AT_DEPTH(opnd - 2);
+ toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(opnd - 3) : NULL;
+ if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+
+ DECACHE_STACK_INFO();
+
+ if (TclGetIntForIndexM(
+ interp, fromIdxObj, length - end_indicator, &fromIdx)
+ != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (fromIdx == TCL_INDEX_NONE) {
+ fromIdx = 0;
+ } else if (fromIdx > length) {
+ fromIdx = length;
+ }
+ numToDelete = 0;
+ if (toIdxObj) {
+ if (TclGetIntForIndexM(
+ interp, toIdxObj, length - end_indicator, &toIdx)
+ != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (toIdx > length) {
+ toIdx = length;
+ }
+ if (toIdx >= fromIdx) {
+ numToDelete = (unsigned)toIdx - (unsigned)fromIdx + 1; /* See [3d3124d01d] */
+ }
+ }
+
+ CACHE_STACK_INFO();
+
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjReplace(interp,
+ objResultPtr,
+ fromIdx,
+ numToDelete,
+ numNewElems,
+ &OBJ_AT_DEPTH(numNewElems - 1))
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ Tcl_DecrRefCount(objResultPtr);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_V(6, opnd, 1);
+ } else {
+ if (Tcl_ListObjReplace(interp,
+ valuePtr,
+ fromIdx,
+ numToDelete,
+ numNewElems,
+ &OBJ_AT_DEPTH(numNewElems - 1))
+ != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_V(6, opnd - 1, 0);
+ }
+ }
+
+ /*
+ * End of INST_LIST and related instructions.
+ * -----------------------------------------------------------------
+ * Start of string-related instructions.
+ */
case INST_STR_EQ:
case INST_STR_NEQ: /* String (in)equality check */
case INST_STR_CMP: /* String compare. */
+ case INST_STR_LT:
+ case INST_STR_GT:
+ case INST_STR_LE:
+ case INST_STR_GE:
stringCompare:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
@@ -5486,15 +5372,19 @@ TEBCresume(
match = (match != 0);
break;
case INST_LT:
+ case INST_STR_LT:
match = (match < 0);
break;
case INST_GT:
+ case INST_STR_GT:
match = (match > 0);
break;
case INST_LE:
+ case INST_STR_LE:
match = (match <= 0);
break;
case INST_GE:
+ case INST_STR_GE:
match = (match >= 0);
break;
}
@@ -5506,9 +5396,9 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
- TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
+ TRACE(("\"%.20s\" => %" TCL_SIZE_MODIFIER "d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
@@ -5524,7 +5414,7 @@ TEBCresume(
} else {
length = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5541,7 +5431,7 @@ TEBCresume(
} else {
length = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5558,7 +5448,7 @@ TEBCresume(
} else {
length = Tcl_UtfToTitle(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
- TclFreeIntRep(valuePtr);
+ TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5572,11 +5462,14 @@ TEBCresume(
* Get char length to calculate what 'end' means.
*/
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
if ((index < 0) || (index >= length)) {
TclNewObj(objResultPtr);
@@ -5587,11 +5480,23 @@ TEBCresume(
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
- char buf[8] = "";
- int ch = TclGetUCS4(valuePtr, index);
+ char buf[4] = "";
+ int ch = TclGetUniChar(valuePtr, index);
- length = TclUCS4ToUtf(ch, buf);
- objResultPtr = Tcl_NewStringObj(buf, length);
+ /*
+ * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
+ * but creating the object as a string seems to be faster in
+ * practical use.
+ */
+ if (ch == -1) {
+ TclNewObj(objResultPtr);
+ } else {
+ length = Tcl_UniCharToUtf(ch, buf);
+ if ((ch >= 0xD800) && (length < 3)) {
+ length += Tcl_UniCharToUtf(-1, buf + length);
+ }
+ objResultPtr = Tcl_NewStringObj(buf, length);
+ }
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
@@ -5600,25 +5505,27 @@ TEBCresume(
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
- length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
+ length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1;
+
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
- &fromIdx) != TCL_OK
- || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ &fromIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (toIdx >= length) {
- toIdx = length;
- }
- if (toIdx >= fromIdx) {
- objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
- } else {
+ if (toIdx < 0) {
TclNewObj(objResultPtr);
+ } else {
+ objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(1, 3, 1);
@@ -5627,7 +5534,7 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
- length = Tcl_GetCharLength(valuePtr);
+ length = TclGetCharLength(valuePtr);
TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
/* Every range of an empty value is an empty value */
@@ -5639,73 +5546,54 @@ TEBCresume(
/* Decode index operands. */
/*
- assert ( toIdx != TCL_INDEX_BEFORE );
- assert ( toIdx != TCL_INDEX_AFTER);
- *
- * Extra safety for legacy bytecodes:
- */
- if (toIdx == TCL_INDEX_BEFORE) {
- goto emptyRange;
- }
- if (toIdx == TCL_INDEX_AFTER) {
- toIdx = TCL_INDEX_END;
- }
-
- toIdx = TclIndexDecode(toIdx, length - 1);
- if (toIdx < 0) {
- goto emptyRange;
- } else if (toIdx >= length) {
- toIdx = length - 1;
- }
-
- assert ( toIdx >= 0 && toIdx < length );
-
- /*
- assert ( fromIdx != TCL_INDEX_BEFORE );
- assert ( fromIdx != TCL_INDEX_AFTER);
+ assert ( toIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
- if (fromIdx == TCL_INDEX_BEFORE) {
- fromIdx = TCL_INDEX_START;
- }
- if (fromIdx == TCL_INDEX_AFTER) {
- goto emptyRange;
- }
-
- fromIdx = TclIndexDecode(fromIdx, length - 1);
- if (fromIdx < 0) {
- fromIdx = 0;
- }
-
- if (fromIdx <= toIdx) {
- objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
- } else {
- emptyRange:
+ if (toIdx == TCL_INDEX_NONE) {
TclNewObj(objResultPtr);
+ } else {
+ toIdx = TclIndexDecode(toIdx, length - 1);
+ /*
+ assert ( fromIdx != TCL_INDEX_NONE );
+ *
+ * Extra safety for legacy bytecodes:
+ */
+ if (fromIdx == TCL_INDEX_NONE) {
+ fromIdx = TCL_INDEX_START;
+ }
+ fromIdx = TclIndexDecode(fromIdx, length - 1);
+ if (toIdx < 0) {
+ TclNewObj(objResultPtr);
+ } else {
+ objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx);
+ }
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
{
Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
- int length3, endIdx;
+ Tcl_Size length3, endIdx;
Tcl_Obj *value3Ptr;
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
- endIdx = Tcl_GetCharLength(valuePtr) - 1;
+ endIdx = TclGetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
+ DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
&toIdx) != TCL_OK) {
+ CACHE_STACK_INFO();
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
goto gotError;
}
+ CACHE_STACK_INFO();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
@@ -5727,89 +5615,16 @@ TEBCresume(
toIdx = endIdx;
}
- if (fromIdx == 0 && toIdx == endIdx) {
+ if ((fromIdx == 0) && (toIdx == endIdx)) {
TclDecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = value3Ptr;
TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
NEXT_INST_F(1, 0, 0);
}
- length3 = Tcl_GetCharLength(value3Ptr);
-
- /*
- * See if we can splice in place. This happens when the number of
- * characters being replaced is the same as the number of characters
- * in the string to be inserted.
- */
-
- if (length3 - 1 == toIdx - fromIdx) {
- unsigned char *bytes1, *bytes2;
-
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_DuplicateObj(valuePtr);
- } else {
- objResultPtr = valuePtr;
- }
- if (TclIsPureByteArray(objResultPtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- }
- Tcl_InvalidateStringRep(objResultPtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- if (objResultPtr == valuePtr) {
- NEXT_INST_F(1, 0, 0);
- } else {
- NEXT_INST_F(1, 1, 1);
- }
- }
-
- /*
- * Get the Unicode representation; this is where we guarantee to lose
- * bytearrays.
- */
-
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
- length--;
-
- /*
- * Remove substring using copying.
- */
+ objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
+ toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
- objResultPtr = NULL;
- if (fromIdx > 0) {
- objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
- }
- if (length3 > 0) {
- if (objResultPtr) {
- Tcl_AppendObjToObj(objResultPtr, value3Ptr);
- } else if (Tcl_IsShared(value3Ptr)) {
- objResultPtr = Tcl_DuplicateObj(value3Ptr);
- } else {
- objResultPtr = value3Ptr;
- }
- }
- if (toIdx < length) {
- if (objResultPtr) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
- length - toIdx);
- } else {
- objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
- length - toIdx);
- }
- }
- if (objResultPtr == NULL) {
- /* This has to be the case [string replace $s 0 end {}] */
- /* which has result {} which is same as value3Ptr. */
- objResultPtr = value3Ptr;
- }
if (objResultPtr == value3Ptr) {
/* See [Bug 82e7f67325] */
TclDecrRefCount(OBJ_AT_TOS);
@@ -5832,12 +5647,12 @@ TEBCresume(
objResultPtr = value3Ptr;
goto doneStringMap;
}
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ ustring1 = TclGetUnicodeFromObj(valuePtr, &length);
if (length == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
}
- ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2);
if (length2 > length || length2 == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
@@ -5849,26 +5664,26 @@ TEBCresume(
}
goto doneStringMap;
}
- ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
+ ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3);
- objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ objResultPtr = TclNewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + length;
for (; ustring1 < end; ustring1++) {
if ((*ustring1 == *ustring2) &&
/* Fix bug [69218ab7b]: restrict max compare length. */
- (end-ustring1 >= length2) && (length2==1 ||
+ ((end-ustring1) >= length2) && (length2==1 ||
memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
== 0)) {
if (p != ustring1) {
- Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
+ TclAppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
- Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
+ TclAppendUnicodeToObj(objResultPtr, ustring3, length3);
}
}
if (p != ustring1) {
@@ -5876,7 +5691,7 @@ TEBCresume(
* Put the rest of the unmapped chars onto result.
*/
- Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+ TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p);
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
@@ -5884,45 +5699,17 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- end = ustring1 + length - length2 + 1;
- for (p=ustring1 ; p<end ; p++) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
- TRACE(("%.20s %.20s => %d\n",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
-
- TRACE(("%.20s %.20s => %d\n",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+ objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
- TclNewIntObj(objResultPtr, match);
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -5930,13 +5717,13 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
O2S(valuePtr)));
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ ustring1 = TclGetUnicodeFromObj(valuePtr, &length);
match = 1;
if (length > 0) {
int ch;
end = ustring1 + length;
for (p=ustring1 ; p<end ; ) {
- p += TclUniCharToUCS4(p, &ch);
+ ch = *p++;
if (!tclStringClassTable[opnd].comparator(ch)) {
match = 0;
break;
@@ -5957,12 +5744,12 @@ TEBCresume(
* both.
*/
- if ((valuePtr->typePtr == &tclStringType)
- || (value2Ptr->typePtr == &tclStringType)) {
+ if (TclHasInternalRep(valuePtr, &tclUniCharStringType)
+ || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
Tcl_UniChar *ustring1, *ustring2;
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
- ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ ustring1 = TclGetUnicodeFromObj(valuePtr, &length);
+ ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length, ustring2, length2,
nocase);
} else if (TclIsPureByteArray(valuePtr) && !nocase) {
@@ -5991,7 +5778,7 @@ TEBCresume(
{
const char *string1, *string2;
- int trim1, trim2;
+ Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
@@ -6090,38 +5877,13 @@ TEBCresume(
*/
{
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
int type1, type2;
- long l1 = 0, l2, lResult;
+ Tcl_WideInt w1, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
- } else if (type1 == TCL_NUMBER_LONG) {
- /* value is between LONG_MIN and LONG_MAX */
- /* [string is integer] is -UINT_MAX to UINT_MAX range */
- int i;
-
- if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if (type1 == TCL_NUMBER_WIDE) {
- /* value is between WIDE_MIN and WIDE_MAX */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
- int i;
- if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
- type1 = TCL_NUMBER_LONG;
- }
-#endif
- } else if (type1 == TCL_NUMBER_BIG) {
- /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
- Tcl_WideInt w;
-
- if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
- }
}
TclNewIntObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
@@ -6166,10 +5928,10 @@ TEBCresume(
compare = MP_EQ;
goto convertComparison;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
- compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
+ compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
} else {
compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
}
@@ -6245,17 +6007,17 @@ TEBCresume(
* Check for common, simple case.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_MOD:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto divideByZero;
- } else if ((l2 == 1) || (l2 == -1)) {
+ } else if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -6264,7 +6026,7 @@ TEBCresume(
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
@@ -6274,37 +6036,37 @@ TEBCresume(
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
} else {
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if ((lResult < 0 || (lResult == 0 &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- (lResult * l2 != l1)) {
- lResult -= 1;
+ if ((wResult < 0 || (wResult == 0 &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ (wResult * w2 != w1)) {
+ wResult -= 1;
}
- lResult = (long)((unsigned long)l1 -
- (unsigned long)l2*(unsigned long)lResult);
- goto longResultOfArithmetic;
+ wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 -
+ (Tcl_WideUInt)w2*(Tcl_WideUInt)wResult);
+ goto wideResultOfArithmetic;
}
break;
case INST_RSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
@@ -6314,16 +6076,16 @@ TEBCresume(
* Quickly force large right shifts to 0 or -1.
*/
- if (l2 >= (long)(CHAR_BIT*sizeof(l1))) {
+ if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(w1))) {
/*
* We assume that INT_MAX is much larger than the
- * number of bits in a long. This is a pretty safe
+ * number of bits in a Tcl_WideInt. This is a pretty safe
* assumption, given that the former is usually around
- * 4e9 and the latter 32 or 64...
+ * 4e9 and the latter 64...
*/
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (l1 > 0L) {
+ if (w1 > 0L) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
@@ -6333,32 +6095,32 @@ TEBCresume(
}
/*
- * Handle shifts within the native long range.
+ * Handle shifts within the native Tcl_WideInt range.
*/
- lResult = l1 >> ((int) l2);
- goto longResultOfArithmetic;
+ wResult = w1 >> ((int) w2);
+ goto wideResultOfArithmetic;
}
break;
case INST_LSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
- NULL);
+ (void *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l2 > (long) INT_MAX) {
+ } else if (w2 > INT_MAX) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1))
* in an mp_int, but since we're using mp_mul_2d() to do
@@ -6371,22 +6133,22 @@ TEBCresume(
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- "integer value too large to represent", NULL);
+ "integer value too large to represent", (void *)NULL);
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else {
- int shift = (int) l2;
+ int shift = (int) w2;
/*
- * Handle shifts within the native long range.
+ * Handle shifts within the native Tcl_WideInt range.
*/
- if (((size_t) shift < CHAR_BIT*sizeof(l1))
- && !((l1>0 ? l1 : ~l1) &
- -(1UL<<(CHAR_BIT*sizeof(l1) - 1 - shift)))) {
- lResult = (unsigned long)l1 << shift;
- goto longResultOfArithmetic;
+ if (((size_t)shift < CHAR_BIT*sizeof(w1))
+ && !((w1>0 ? w1 : ~w1) &
+ -((Tcl_WideUInt)1<<(CHAR_BIT*sizeof(w1) - 1 - shift)))) {
+ wResult = (Tcl_WideUInt)w1 << shift;
+ goto wideResultOfArithmetic;
}
}
@@ -6398,23 +6160,14 @@ TEBCresume(
break;
case INST_BITAND:
- lResult = l1 & l2;
- goto longResultOfArithmetic;
+ wResult = w1 & w2;
+ goto wideResultOfArithmetic;
case INST_BITOR:
- lResult = l1 | l2;
- goto longResultOfArithmetic;
+ wResult = w1 | w2;
+ goto wideResultOfArithmetic;
case INST_BITXOR:
- lResult = l1 ^ l2;
- longResultOfArithmetic:
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
+ wResult = w1 ^ w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6493,22 +6246,17 @@ TEBCresume(
#endif
/*
- * Handle (long,long) arithmetic as best we can without going out to
+ * Handle Tcl_WideInt arithmetic as best we can without going out to
* an external function.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- Tcl_WideInt w1, w2, wResult;
-
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_ADD:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -6516,14 +6264,10 @@ TEBCresume(
if (Overflowing(w1, w2, wResult)) {
goto overflow;
}
-#endif
goto wideResultOfArithmetic;
case INST_SUB:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2);
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Must check for overflow. The macro tests for overflows in
* sums by looking at the sign bits. As we have a subtraction
@@ -6537,54 +6281,53 @@ TEBCresume(
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
-#endif
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
+ TclNewIntObj(objResultPtr, wResult);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
- Tcl_SetWideIntObj(valuePtr, wResult);
+ TclSetIntObj(valuePtr, wResult);
TRACE(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
break;
case INST_DIV:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- } else if ((l1 == LONG_MIN) && (l2 == -1)) {
+ } else if ((w1 == WIDE_MIN) && (w2 == -1)) {
/*
- * Can't represent (-LONG_MIN) as a long.
+ * Can't represent (-WIDE_MIN) as a Tcl_WideInt.
*/
goto overflow;
}
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if (((lResult < 0) || ((lResult == 0) &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- ((lResult * l2) != l1)) {
- lResult -= 1;
+ if (((wResult < 0) || ((wResult == 0) &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ ((wResult * w2) != w1)) {
+ wResult -= 1;
}
- goto longResultOfArithmetic;
+ goto wideResultOfArithmetic;
case INST_MULT:
- if (((sizeof(long) >= 2*sizeof(int))
- && (l1 <= INT_MAX) && (l1 >= INT_MIN)
- && (l2 <= INT_MAX) && (l2 >= INT_MIN))
- || ((sizeof(long) >= 2*sizeof(short))
- && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN)
- && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) {
- lResult = l1 * l2;
- goto longResultOfArithmetic;
+ if (((sizeof(Tcl_WideInt) >= 2*sizeof(int))
+ && (w1 <= INT_MAX) && (w1 >= INT_MIN)
+ && (w2 <= INT_MAX) && (w2 >= INT_MIN))
+ || ((sizeof(Tcl_WideInt) >= 2*sizeof(short))
+ && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN)
+ && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) {
+ wResult = w1 * w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6606,6 +6349,9 @@ TEBCresume(
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
TRACE_ERROR(interp);
goto gotError;
+ } else if (objResultPtr == OUT_OF_MEMORY) {
+ TRACE_APPEND(("OUT OF MEMORY\n"));
+ goto outOfMemory;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
@@ -6651,14 +6397,14 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *) ptr1);
+ if (type1 == TCL_NUMBER_INT) {
+ w1 = *((const Tcl_WideInt *) ptr1);
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, ~l1);
+ TclNewIntObj(objResultPtr, ~w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, ~l1);
+ TclSetIntObj(valuePtr, ~w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6689,15 +6435,15 @@ TEBCresume(
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
break;
- case TCL_NUMBER_LONG:
- l1 = *((const long *) ptr1);
- if (l1 != LONG_MIN) {
+ case TCL_NUMBER_INT:
+ w1 = *((const Tcl_WideInt *) ptr1);
+ if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, -l1);
+ TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, -l1);
+ TclSetIntObj(valuePtr, -w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6806,7 +6552,7 @@ TEBCresume(
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
- if (valuePtr->typePtr == &tclBooleanType) {
+ if (TclHasInternalRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
@@ -6843,7 +6589,8 @@ TEBCresume(
Var *iterVarPtr, *listVarPtr;
Tcl_Obj *oldValuePtr, *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterNum, listTmpIndex, listLen, numVars;
+ int numLists, listTmpIndex, listLen, numVars;
+ size_t iterNum;
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
@@ -6854,16 +6601,16 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
- TclNewLongObj(iterVarPtr->value.objPtr, -1);
+ TclNewIntObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
- TclSetLongObj(oldValuePtr, -1);
+ TclSetIntObj(oldValuePtr, -1);
}
TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
@@ -6888,7 +6635,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
@@ -6897,8 +6644,8 @@ TEBCresume(
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
- iterNum = valuePtr->internalRep.longValue + 1;
- TclSetLongObj(valuePtr, iterNum);
+ iterNum = (size_t)valuePtr->internalRep.wideValue + 1;
+ TclSetIntObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should stop the
@@ -6913,12 +6660,12 @@ TEBCresume(
listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
- if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
- if (listLen > iterNum * numVars) {
+ if ((size_t)listLen > iterNum * numVars) {
continueLoop = 1;
}
listTmpIndex++;
@@ -6940,8 +6687,9 @@ TEBCresume(
numVars = varListPtr->numVars;
listVarPtr = LOCAL(listTmpIndex);
- listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ /* Do not use TclListObjCopy here - shimmers arithseries to list */
+ listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr);
+ TclListObjGetElementsM(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
@@ -6984,7 +6732,7 @@ TEBCresume(
listTmpIndex++;
}
}
- TRACE_APPEND(("%d lists, iter %d, %s loop\n",
+ TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n",
numLists, iterNum, (continueLoop? "continue" : "exit")));
/*
@@ -7005,8 +6753,8 @@ TEBCresume(
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterMax, listLen, numVars;
- int iterTmp, iterNum, listTmpDepth;
+ Tcl_Size numLists, listLen, numVars, listTmpDepth;
+ size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
@@ -7017,7 +6765,7 @@ TEBCresume(
*/
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
@@ -7031,13 +6779,17 @@ TEBCresume(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
- objPtr = TclListObjCopy(NULL, listPtr);
+ /* Do not use TclListObjCopy here - shimmers arithseries to list */
+ objPtr = Tcl_DuplicateObj(listPtr);
+ if (!objPtr) {
+ goto gotError;
+ }
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(listPtr);
OBJ_AT_DEPTH(listTmpDepth) = objPtr;
@@ -7057,8 +6809,8 @@ TEBCresume(
*/
TclNewObj(tmpPtr);
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
- tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
+ tmpPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax;
PUSH_OBJECT(tmpPtr); /* iterCounts object */
/*
@@ -7085,13 +6837,13 @@ TEBCresume(
*/
tmpPtr = OBJ_AT_TOS;
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> "));
tmpPtr = OBJ_AT_DEPTH(1);
- iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
- iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
+ iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1;
+ iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2;
/*
* If some list still has a remaining list element iterate one more
@@ -7099,27 +6851,53 @@ TEBCresume(
*/
if (iterNum < iterMax) {
+ int status;
/*
* Set the variables and jump back to run the body
*/
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
+ tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
+ int hasAbstractList;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- TclListObjGetElements(interp, listPtr, &listLen, &elements);
+ hasAbstractList =
+ TclHasInternalRep(listPtr, &tclArithSeriesType);
+ DECACHE_STACK_INFO();
+ if (hasAbstractList) {
+ status = Tcl_ListObjLength(interp, listPtr, &listLen);
+ elements = NULL;
+ } else {
+ status = TclListObjGetElementsM(
+ interp, listPtr, &listLen, &elements);
+ }
+ if (status != TCL_OK) {
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ CACHE_STACK_INFO();
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
- valuePtr = elements[valIndex];
+ if (elements) {
+ valuePtr = elements[valIndex];
+ } else {
+ DECACHE_STACK_INFO();
+ valuePtr = TclArithSeriesObjIndex(
+ NULL, listPtr, valIndex);
+ if (valuePtr == NULL) {
+ TclNewObj(valuePtr);
+ }
+ CACHE_STACK_INFO();
+ }
}
varIndex = varListPtr->varIndexes[j];
@@ -7141,7 +6919,7 @@ TEBCresume(
if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
- TRACE_APPEND(("ERROR init. index temp %d: %.30s",
+ TRACE_APPEND(("ERROR init. index temp %" TCL_SIZE_MODIFIER "d: %.30s",
varIndex, O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
@@ -7169,7 +6947,7 @@ TEBCresume(
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> loop terminated\n"));
NEXT_INST_V(1, numLists+2, 0);
@@ -7186,9 +6964,9 @@ TEBCresume(
*/
tmpPtr = OBJ_AT_DEPTH(1);
- infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1;
+ infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
- TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
+ TRACE_APPEND(("=> appending to list at depth %" TCL_SIZE_MODIFIER "d\n", 3 + numLists));
objPtr = OBJ_AT_DEPTH(3 + numLists);
Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
@@ -7203,10 +6981,10 @@ TEBCresume(
* stack.
*/
- *(++catchTop) = CURR_DEPTH;
- TRACE(("%u => catchTop=%d, stackTop=%d\n",
- TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
- (int) CURR_DEPTH));
+ *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH);
+ TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_T_MODIFIER "d\n",
+ TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1),
+ CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
@@ -7216,7 +6994,7 @@ TEBCresume(
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_OK;
- TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
+ TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
break;
@@ -7270,7 +7048,8 @@ TEBCresume(
*/
{
- int opnd2, allocateDict, done, i, allocdict;
+ int opnd2, allocateDict, done, allocdict;
+ Tcl_Size i;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
@@ -7286,56 +7065,25 @@ TEBCresume(
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
+ break;
- case INST_DICT_GET:
case INST_DICT_EXISTS: {
- Tcl_Interp *interp2 = interp;
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
- if (*pc == INST_DICT_EXISTS) {
- interp2 = NULL;
- }
if (opnd > 1) {
- dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
- &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
- if (dictPtr == NULL) {
- if (*pc == INST_DICT_EXISTS) {
- found = 0;
- goto afterDictExists;
- }
- TRACE_WITH_OBJ((
- "ERROR tracing dictionary path into \"%.30s\": ",
- O2S(OBJ_AT_DEPTH(opnd))),
- Tcl_GetObjResult(interp));
- goto gotError;
+ dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS);
+ if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) {
+ found = 0;
+ goto afterDictExists;
}
}
- if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
+ if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
- if (*pc == INST_DICT_EXISTS) {
- found = (objResultPtr ? 1 : 0);
- goto afterDictExists;
- }
- if (!objResultPtr) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "key \"%s\" not known in dictionary",
- TclGetString(OBJ_AT_TOS)));
- DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
- TclGetString(OBJ_AT_TOS), NULL);
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
- }
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
- } else if (*pc != INST_DICT_EXISTS) {
- TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
- O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
- goto gotError;
+ found = (objResultPtr ? 1 : 0);
} else {
found = 0;
}
@@ -7351,6 +7099,68 @@ TEBCresume(
JUMP_PEEPHOLE_V(found, 5, opnd+1);
}
+ case INST_DICT_GET:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = OBJ_AT_DEPTH(opnd);
+ if (opnd > 1) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ TRACE_WITH_OBJ((
+ "ERROR tracing dictionary path into \"%.30s\": ",
+ O2S(OBJ_AT_DEPTH(opnd))),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ }
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
+ &objResultPtr) != TCL_OK) {
+ TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ if (!objResultPtr) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(OBJ_AT_TOS), (void *)NULL);
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ case INST_DICT_GET_DEF:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
+ dictPtr = OBJ_AT_DEPTH(opnd+1);
+ if (opnd > 1) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS);
+ if (dictPtr == NULL) {
+ TRACE_WITH_OBJ((
+ "ERROR tracing dictionary path into \"%.30s\": ",
+ O2S(OBJ_AT_DEPTH(opnd+1))),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ } else if (dictPtr == DICT_PATH_NON_EXISTENT) {
+ goto dictGetDefUseDefault;
+ }
+ }
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
+ &objResultPtr) != TCL_OK) {
+ TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (!objResultPtr) {
+ dictGetDefUseDefault:
+ objResultPtr = OBJ_AT_TOS;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+2, 1);
case INST_DICT_SET:
case INST_DICT_UNSET:
@@ -7395,7 +7205,7 @@ TEBCresume(
break;
}
if (valuePtr == NULL) {
- Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd));
} else {
TclNewIntObj(value2Ptr, opnd);
Tcl_IncrRefCount(value2Ptr);
@@ -7602,7 +7412,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
- searchPtr = ckalloc(sizeof(Tcl_DictSearch));
+ searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
@@ -7617,13 +7427,16 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewObj(statePtr);
- statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ {
+ Tcl_ObjInternalRep ir;
+ TclNewObj(statePtr);
+ ir.twoPtrValue.ptr1 = searchPtr;
+ ir.twoPtrValue.ptr2 = dictPtr;
+ Tcl_StoreInternalRep(statePtr, &dictIteratorType, &ir);
+ }
varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
+ if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) {
Tcl_Panic("mis-issued dictFirst!");
}
TclDecrRefCount(varPtr->value.objPtr);
@@ -7636,11 +7449,17 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
- if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
- Tcl_Panic("mis-issued dictNext!");
+ {
+ const Tcl_ObjInternalRep *irPtr;
+
+ if (statePtr &&
+ (irPtr = TclFetchInternalRep(statePtr, &dictIteratorType))) {
+ searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
+ Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
+ } else {
+ Tcl_Panic("mis-issued dictNext!");
+ }
}
- searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
- Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:
if (done) {
TclNewObj(emptyPtr);
@@ -7667,7 +7486,7 @@ TEBCresume(
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
- duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
+ duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -7684,7 +7503,7 @@ TEBCresume(
}
}
Tcl_IncrRefCount(dictPtr);
- if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
+ if (TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -7727,7 +7546,7 @@ TEBCresume(
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
- duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
+ duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -7744,7 +7563,7 @@ TEBCresume(
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
- || TclListObjGetElements(interp, OBJ_AT_TOS, &length,
+ || TclListObjGetElementsM(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -7803,7 +7622,7 @@ TEBCresume(
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -7821,7 +7640,7 @@ TEBCresume(
listPtr = OBJ_AT_TOS;
TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
@@ -7852,7 +7671,7 @@ TEBCresume(
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
- if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, listPtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -7881,30 +7700,30 @@ TEBCresume(
{ /* Read the wall clock */
Tcl_WideInt wval;
Tcl_Time now;
- switch(TclGetUInt1AtPtr(pc+1)) {
+ switch (TclGetUInt1AtPtr(pc+1)) {
case 0: /* clicks */
#ifdef TCL_WIDE_CLICKS
wval = TclpGetWideClicks();
#else
- wval = (Tcl_WideInt) TclpGetClicks();
+ wval = (Tcl_WideInt)TclpGetClicks();
#endif
break;
case 1: /* microseconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec * 1000000 + now.usec;
+ wval = (Tcl_WideInt)now.sec * 1000000 + now.usec;
break;
case 2: /* milliseconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000;
+ wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000;
break;
case 3: /* seconds */
Tcl_GetTime(&now);
- wval = (Tcl_WideInt) now.sec;
+ wval = (Tcl_WideInt)now.sec;
break;
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
- objResultPtr = Tcl_NewWideIntObj(wval);
+ TclNewIntObj(objResultPtr, wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
@@ -7973,19 +7792,19 @@ TEBCresume(
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
- TRACE_APPEND(("%s, range at %d, new pc %d\n",
+ TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
}
- if (rangePtr->continueOffset == -1) {
+ 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 %d, new pc %d\n",
+ TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
@@ -8012,7 +7831,14 @@ TEBCresume(
divideByZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
+ Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (void *)NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+
+ outOfMemory:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", (void *)NULL);
CACHE_STACK_INFO();
goto gotError;
@@ -8026,7 +7852,7 @@ TEBCresume(
"exponentiation of zero by negative power", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
- "exponentiation of zero by negative power", NULL);
+ "exponentiation of zero by negative power", (void *)NULL);
CACHE_STACK_INFO();
/*
@@ -8067,8 +7893,8 @@ TEBCresume(
while (auxObjList) {
if ((catchTop != initCatchTop)
- && (*catchTop > (ptrdiff_t)
- auxObjList->internalRep.twoPtrValue.ptr2)) {
+ && (PTR2INT(*catchTop) >
+ PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2))) {
break;
}
POP_TAUX_OBJ();
@@ -8143,16 +7969,16 @@ TEBCresume(
*/
processCatch:
- while (CURR_DEPTH > *catchTop) {
+ while (CURR_DEPTH > PTR2INT(*catchTop)) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
- fprintf(stdout, " ... found catch at %d, catchTop=%d, "
- "unwound to %ld, new pc %u\n",
- rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
- (long) *catchTop, (unsigned) rangePtr->catchOffset);
+ fprintf(stdout, " ... found catch at %" TCL_SIZE_MODIFIER "d, catchTop=%" TCL_T_MODIFIER "d, "
+ "unwound to %" TCL_T_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n",
+ rangePtr->codeOffset, (catchTop - initCatchTop - 1),
+ PTR2INT(*catchTop), rangePtr->catchOffset);
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
@@ -8188,19 +8014,17 @@ TEBCresume(
if (tosPtr < initTosPtr) {
fprintf(stderr,
- "\nTclNRExecuteByteCode: abnormal return at pc %u: "
- "stack top %d < entry stack top %d\n",
- (unsigned)(pc - codePtr->codeStart),
- (unsigned) CURR_DEPTH, (unsigned) 0);
+ "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_T_MODIFIER "d: "
+ "stack top %" TCL_T_MODIFIER "d < entry stack top %d\n",
+ (pc - codePtr->codeStart),
+ CURR_DEPTH, 0);
Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top");
}
CLANG_ASSERT(bcFramePtr);
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
@@ -8258,18 +8082,18 @@ TEBCresume(
static int
FinalizeOONext(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -8284,18 +8108,18 @@ FinalizeOONext(
static int
FinalizeOONextFilter(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -8309,47 +8133,10 @@ FinalizeOONextFilter(
}
/*
- * LongPwrSmallExpon -- , WidePwrSmallExpon --
+ * WidePwrSmallExpon --
*
- * Helpers to calculate small powers of integers whose result is long or wide.
+ * Helper to calculate small powers of integers whose result is wide.
*/
-#if (LONG_MAX == 0x7FFFFFFF)
-static inline long
-LongPwrSmallExpon(long l1, long exponent) {
-
- long lResult;
-
- lResult = l1 * l1; /* b**2 */
- switch (exponent) {
- case 2:
- break;
- case 3:
- lResult *= l1; /* b**3 */
- break;
- case 4:
- lResult *= lResult; /* b**4 */
- break;
- case 5:
- lResult *= lResult; /* b**4 */
- lResult *= l1; /* b**5 */
- break;
- case 6:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- break;
- case 7:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- lResult *= l1; /* b**7 */
- break;
- case 8:
- lResult *= lResult; /* b**4 */
- lResult *= lResult; /* b**8 */
- break;
- }
- return lResult;
-}
-#endif
static inline Tcl_WideInt
WidePwrSmallExpon(Tcl_WideInt w1, long exponent) {
@@ -8463,19 +8250,11 @@ ExecuteExtendedBinaryMathOp(
Tcl_Obj *valuePtr, /* The first operand on the stack. */
Tcl_Obj *value2Ptr) /* The second operand on the stack. */
{
-#define LONG_RESULT(l) \
- if (Tcl_IsShared(valuePtr)) { \
- TclNewLongObj(objResultPtr, (l)); \
- return objResultPtr; \
- } else { \
- Tcl_SetLongObj(valuePtr, (l)); \
- return NULL; \
- }
#define WIDE_RESULT(w) \
if (Tcl_IsShared(valuePtr)) { \
return Tcl_NewWideIntObj(w); \
} else { \
- Tcl_SetWideIntObj(valuePtr, (w)); \
+ TclSetIntObj(valuePtr, (w)); \
return NULL; \
}
#define BIG_RESULT(b) \
@@ -8495,14 +8274,14 @@ ExecuteExtendedBinaryMathOp(
}
int type1, type2;
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
double d1, d2, dResult;
- long l1, l2, lResult;
Tcl_WideInt w1, w2, wResult;
mp_int big1, big2, bigResult, bigRemainder;
Tcl_Obj *objResultPtr;
int invalid, zero;
int shift;
+ mp_err err;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
@@ -8511,13 +8290,13 @@ ExecuteExtendedBinaryMathOp(
case INST_MOD:
/* TODO: Attempts to re-use unshared operands on stack */
- l2 = 0; /* silence gcc warning */
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *)ptr2);
- if (l2 == 0) {
+ w2 = 0; /* silence gcc warning */
+ if (type2 == TCL_NUMBER_INT) {
+ w2 = *((const Tcl_WideInt *)ptr2);
+ if (w2 == 0) {
return DIVIDED_BY_ZERO;
}
- if ((l2 == 1) || (l2 == -1)) {
+ if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -8525,12 +8304,19 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *)ptr1);
- if (type2 != TCL_NUMBER_BIG) {
+
+ if (w1 == 0) {
+ /*
+ * 0 % (non-zero) always yields remainder of 0.
+ */
+
+ return constants[0];
+ }
+ if (type2 == TCL_NUMBER_INT) {
Tcl_WideInt wQuotient, wRemainder;
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+ w2 = *((const Tcl_WideInt *)ptr2);
wQuotient = w1 / w2;
/*
@@ -8538,12 +8324,12 @@ ExecuteExtendedBinaryMathOp(
* TODO: examine for logic simplification
*/
- if (((wQuotient < (Tcl_WideInt) 0)
- || ((wQuotient == (Tcl_WideInt) 0)
- && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
- || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
+ if (((wQuotient < 0)
+ || ((wQuotient == 0)
+ && ((w1 < 0 && w2 > 0)
+ || (w1 > 0 && w2 < 0))))
&& (wQuotient * w2 != w1)) {
- wQuotient -= (Tcl_WideInt) 1;
+ wQuotient -= 1;
}
wRemainder = (Tcl_WideInt)((Tcl_WideUInt)w1 -
(Tcl_WideUInt)w2*(Tcl_WideUInt)wQuotient);
@@ -8553,14 +8339,19 @@ ExecuteExtendedBinaryMathOp(
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
/* TODO: internals intrusion */
- if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) {
+ if ((w1 > ((Tcl_WideInt)0)) ^ !mp_isneg(&big2)) {
/*
* Arguments are opposite sign; remainder is sum.
*/
- TclBNInitBignumFromWideInt(&big1, w1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
+ err = mp_init_i64(&big1, w1);
+ if (err == MP_OKAY) {
+ err = mp_add(&big2, &big1, &big2);
+ mp_clear(&big1);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&big2);
}
@@ -8571,24 +8362,29 @@ ExecuteExtendedBinaryMathOp(
mp_clear(&big2);
return NULL;
}
-#endif
Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) {
+ err = mp_init_multi(&bigResult, &bigRemainder, (void *)NULL);
+ if (err == MP_OKAY) {
+ err = mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ }
+ if ((err == MP_OKAY) && !mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) {
/*
* Convert to Tcl's integer division rules.
*/
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
+ if ((mp_sub_d(&bigResult, 1, &bigResult) != MP_OKAY)
+ || (mp_add(&bigRemainder, &big2, &bigRemainder) != MP_OKAY)) {
+ return OUT_OF_MEMORY;
+ }
}
- mp_copy(&bigRemainder, &bigResult);
+ err = mp_copy(&bigRemainder, &bigResult);
mp_clear(&bigRemainder);
mp_clear(&big1);
mp_clear(&big2);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&bigResult);
case INST_LSHIFT:
@@ -8598,17 +8394,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < 0L);
+ case TCL_NUMBER_INT:
+ invalid = (*((const Tcl_WideInt *)ptr2) < 0);
break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
- break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- invalid = (mp_cmp_d(&big2, 0) == MP_LT);
+ invalid = mp_isneg(&big2);
mp_clear(&big2);
break;
default:
@@ -8625,7 +8416,7 @@ ExecuteExtendedBinaryMathOp(
* Zero shifted any number of bits is still zero.
*/
- if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
+ if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 0)) {
return constants[0];
}
@@ -8638,8 +8429,8 @@ ExecuteExtendedBinaryMathOp(
* counterparts, leading to incorrect results.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (long) INT_MAX)) {
+ if ((type2 != TCL_NUMBER_INT)
+ || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1)) in
* an mp_int, but since we're using mp_mul_2d() to do the
@@ -8651,15 +8442,15 @@ ExecuteExtendedBinaryMathOp(
"integer value too large to represent", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- shift = (int)(*((const long *)ptr2));
+ shift = (int)(*((const Tcl_WideInt *)ptr2));
/*
* Handle shifts within the native wide range.
*/
- if ((type1 != TCL_NUMBER_BIG)
+ if ((type1 == TCL_NUMBER_INT)
&& ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ w1 = *((const Tcl_WideInt *)ptr1);
if (!((w1>0 ? w1 : ~w1)
& -(((Tcl_WideUInt)1)
<< (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
@@ -8671,8 +8462,8 @@ ExecuteExtendedBinaryMathOp(
* Quickly force large right shifts to 0 or -1.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*(const long *)ptr2 > INT_MAX)) {
+ if ((type2 != TCL_NUMBER_INT)
+ || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) {
/*
* Again, technically, the value to be shifted could be an
* mp_int so huge that a right shift by (INT_MAX+1) bits could
@@ -8682,17 +8473,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
+ case TCL_NUMBER_INT:
+ zero = (*(const Tcl_WideInt *)ptr1 > 0);
break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- zero = (mp_cmp_d(&big1, 0) == MP_GT);
+ zero = !mp_isneg(&big1);
mp_clear(&big1);
break;
default:
@@ -8702,35 +8488,38 @@ ExecuteExtendedBinaryMathOp(
if (zero) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
- shift = (int)(*(const long *)ptr2);
+ shift = (int)(*(const Tcl_WideInt *)ptr2);
-#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
- if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_INT) {
w1 = *(const Tcl_WideInt *)ptr1;
if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
- if (w1 >= (Tcl_WideInt)0) {
+ if (w1 >= 0) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
WIDE_RESULT(w1 >> shift);
}
-#endif
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- mp_init(&bigResult);
- if (opcode == INST_LSHIFT) {
- mp_mul_2d(&big1, shift, &bigResult);
- } else {
- mp_signed_rsh(&big1, shift, &bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
+ if (opcode == INST_LSHIFT) {
+ err = mp_mul_2d(&big1, shift, &bigResult);
+ } else {
+ err = mp_signed_rsh(&big1, shift, &bigResult);
+ }
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
}
mp_clear(&big1);
BIG_RESULT(&bigResult);
@@ -8739,24 +8528,29 @@ ExecuteExtendedBinaryMathOp(
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
- if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
+ if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) {
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
+ err = mp_init(&bigResult);
- switch (opcode) {
- case INST_BITAND:
- mp_and(&big1, &big2, &bigResult);
- break;
+ if (err == MP_OKAY) {
+ switch (opcode) {
+ case INST_BITAND:
+ err = mp_and(&big1, &big2, &bigResult);
+ break;
- case INST_BITOR:
- mp_or(&big1, &big2, &bigResult);
- break;
+ case INST_BITOR:
+ err = mp_or(&big1, &big2, &bigResult);
+ break;
- case INST_BITXOR:
- mp_xor(&big1, &big2, &bigResult);
- break;
+ case INST_BITXOR:
+ err = mp_xor(&big1, &big2, &bigResult);
+ break;
+ }
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
}
mp_clear(&big1);
@@ -8764,46 +8558,24 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
-
- switch (opcode) {
- case INST_BITAND:
- wResult = w1 & w2;
- break;
- case INST_BITOR:
- wResult = w1 | w2;
- break;
- case INST_BITXOR:
- wResult = w1 ^ w2;
- break;
- default:
- /* Unused, here to silence compiler warning. */
- wResult = 0;
- }
- WIDE_RESULT(wResult);
- }
-#endif
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_BITAND:
- lResult = l1 & l2;
+ wResult = w1 & w2;
break;
case INST_BITOR:
- lResult = l1 | l2;
+ wResult = w1 | w2;
break;
case INST_BITXOR:
- lResult = l1 ^ l2;
+ wResult = w1 ^ w2;
break;
default:
/* Unused, here to silence compiler warning. */
- lResult = 0;
+ wResult = 0;
}
- LONG_RESULT(lResult);
+ WIDE_RESULT(wResult);
case INST_EXPON: {
int oddExponent = 0, negativeExponent = 0;
@@ -8819,96 +8591,57 @@ ExecuteExtendedBinaryMathOp(
dResult = pow(d1, d2);
goto doubleResult;
}
- l1 = l2 = 0;
w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */
- switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *) ptr2);
-#ifndef TCL_WIDE_INT_IS_LONG
- pwrLongExpon:
-#endif
- if (l2 == 0) {
+ if (type2 == TCL_NUMBER_INT) {
+ w2 = *((const Tcl_WideInt *) ptr2);
+ if (w2 == 0) {
/*
* Anything to the zero power is 1.
*/
return constants[1];
- } else if (l2 == 1) {
+ } else if (w2 == 1) {
/*
* Anything to the first power is itself
*/
return NULL;
}
- negativeExponent = (l2 < 0);
- oddExponent = (int) (l2 & 1);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- /* check it fits in long */
- l2 = (long)w2;
- if (w2 == l2) {
- type2 = TCL_NUMBER_LONG;
- goto pwrLongExpon;
- }
+
negativeExponent = (w2 < 0);
- oddExponent = (int) (w2 & (Tcl_WideInt)1);
- break;
-#endif
- case TCL_NUMBER_BIG:
+ oddExponent = (int)w2 & 1;
+ } else {
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_mod_2d(&big2, 1, &big2);
- oddExponent = !mp_iszero(&big2);
+ negativeExponent = mp_isneg(&big2);
+ err = mp_mod_2d(&big2, 1, &big2);
+ oddExponent = (err == MP_OKAY) && !mp_iszero(&big2);
mp_clear(&big2);
- break;
}
- switch (type1) {
- case TCL_NUMBER_LONG:
- l1 = *((const long *)ptr1);
-#ifndef TCL_WIDE_INT_IS_LONG
- pwrLongBase:
-#endif
- switch (l1) {
- case 0:
- /*
- * Zero to a positive power is zero.
- * Zero to a negative power is div by zero error.
- */
+ if (type1 == TCL_NUMBER_INT) {
+ w1 = *((const Tcl_WideInt *)ptr1);
- return (!negativeExponent) ? constants[0] : EXPONENT_OF_ZERO;
- case 1:
- /*
- * 1 to any power is 1.
- */
+ if (negativeExponent) {
+ switch (w1) {
+ case 0:
+ /*
+ * Zero to a negative power is div by zero error.
+ */
- return constants[1];
- case -1:
- if (!negativeExponent) {
- if (!oddExponent) {
- return constants[1];
+ return EXPONENT_OF_ZERO;
+ case -1:
+ if (oddExponent) {
+ WIDE_RESULT(-1);
}
- LONG_RESULT(-1);
- }
- /* negativeExponent */
- if (oddExponent) {
- LONG_RESULT(-1);
+ /* fallthrough */
+ case 1:
+ /*
+ * 1 to any power is 1.
+ */
+
+ return constants[1];
}
- return constants[1];
- }
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *) ptr1);
- /* check it fits in long */
- l1 = (long)w1;
- if (w1 == l1) {
- type1 = TCL_NUMBER_LONG;
- goto pwrLongBase;
}
-#endif
}
if (negativeExponent) {
@@ -8919,119 +8652,77 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
-
- if (type1 == TCL_NUMBER_BIG) {
+ if (type1 != TCL_NUMBER_INT) {
goto overflowExpon;
}
+ switch (w1) {
+ case 0:
+ /*
+ * Zero to a positive power is zero.
+ */
+
+ return constants[0];
+ case 1:
+ /*
+ * 1 to any power is 1.
+ */
+
+ return constants[1];
+ case -1:
+ if (!oddExponent) {
+ return constants[1];
+ }
+ WIDE_RESULT(-1);
+ }
+
/*
* We refuse to accept exponent arguments that exceed one mp_digit
* which means the max exponent value is 2**28-1 = 0x0FFFFFFF =
* 268435455, which fits into a signed 32 bit int which is within the
- * range of the long type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger than we
+ * range of the Tcl_WideInt type. This means any numeric Tcl_Obj value
+ * not using TCL_NUMBER_INT type must hold a value larger than we
* accept.
*/
- if (type2 != TCL_NUMBER_LONG) {
+ if (type2 != TCL_NUMBER_INT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- /* From here (up to overflowExpon) exponent is long (l2). */
+ /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */
+ assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT);
- if (type1 == TCL_NUMBER_LONG) {
- if (l1 == 2) {
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- LONG_RESULT(1L << l2);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
- WIDE_RESULT(((Tcl_WideInt) 1) << l2);
- }
-#endif
- goto overflowExpon;
- }
- if (l1 == -2) {
- int signum = oddExponent ? -1 : 1;
-
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- LONG_RESULT(signum * (1L << l2));
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
- }
-#endif
- goto overflowExpon;
- }
-#if (LONG_MAX == 0x7FFFFFFF)
- if (l2 - 2 < (long)MaxBase32Size
- && l1 <= MaxBase32[l2 - 2]
- && l1 >= -MaxBase32[l2 - 2]) {
- /*
- * Small powers of 32-bit integers.
- */
- lResult = LongPwrSmallExpon(l1, l2);
+ if (w1 == 2) {
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- LONG_RESULT(lResult);
+ if ((Tcl_WideUInt)w2 < (Tcl_WideUInt)CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(((Tcl_WideInt)1) << (int)w2);
}
+ goto overflowExpon;
+ }
+ if (w1 == -2) {
+ int signum = oddExponent ? -1 : 1;
- if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- LONG_RESULT(Exp32Value[base]);
- }
- }
- if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[-l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[-l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
+ /*
+ * Reduce small powers of 2 to shifts.
+ */
- lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
- LONG_RESULT(lResult);
- }
+ if ((Tcl_WideUInt)w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(signum * (((Tcl_WideInt)1) << (int) w2));
}
-#endif
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
- /* Code below (up to overflowExpon) works with wide-int base */
- w1 = l1;
-#endif
+ goto overflowExpon;
}
-
-#if (LONG_MAX > 0x7FFFFFFF) || !defined(TCL_WIDE_INT_IS_LONG)
-
- /* From here (up to overflowExpon) base is wide-int (w1). */
-
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
+ if (w2 - 2 < (long)MaxBase64Size
+ && w1 <= MaxBase64[w2 - 2]
+ && w1 >= -MaxBase64[w2 - 2]) {
/*
* Small powers of integers whose result is wide.
*/
- wResult = WidePwrSmallExpon(w1, l2);
+ wResult = WidePwrSmallExpon(w1, (long)w2);
WIDE_RESULT(wResult);
}
@@ -9042,9 +8733,9 @@ ExecuteExtendedBinaryMathOp(
*/
if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -9056,9 +8747,9 @@ ExecuteExtendedBinaryMathOp(
}
if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[-w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[-w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -9069,7 +8760,6 @@ ExecuteExtendedBinaryMathOp(
WIDE_RESULT(wResult);
}
}
-#endif
overflowExpon:
@@ -9081,8 +8771,13 @@ ExecuteExtendedBinaryMathOp(
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- mp_init(&bigResult);
- mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
+ err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
@@ -9135,23 +8830,21 @@ ExecuteExtendedBinaryMathOp(
* Check now for IEEE floating-point error.
*/
- if (TclIsNaN(dResult)) {
+ if (isnan(dResult)) {
TclExprFloatError(interp, dResult);
return GENERAL_ARITHMETIC_ERROR;
}
#endif
DOUBLE_RESULT(dResult);
}
- if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+ if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_ADD:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2);
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Check for overflow.
@@ -9165,9 +8858,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2);
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
+ if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT))
{
/*
* Must check for overflow. The macro tests for overflows
@@ -9187,8 +8878,7 @@ ExecuteExtendedBinaryMathOp(
break;
case INST_MULT:
- if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG)
- || (sizeof(Tcl_WideInt) < 2*sizeof(long))) {
+ if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) {
goto overflowBasic;
}
wResult = w1 * w2;
@@ -9200,10 +8890,10 @@ ExecuteExtendedBinaryMathOp(
}
/*
- * Need a bignum to represent (LLONG_MIN / -1)
+ * Need a bignum to represent (WIDE_MIN / -1)
*/
- if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ if ((w1 == WIDE_MIN) && (w2 == -1)) {
goto overflowBasic;
}
wResult = w1 / w2;
@@ -9234,38 +8924,44 @@ ExecuteExtendedBinaryMathOp(
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
+ err = mp_init(&bigResult);
+ if (err == MP_OKAY) {
switch (opcode) {
case INST_ADD:
- mp_add(&big1, &big2, &bigResult);
- break;
+ err = mp_add(&big1, &big2, &bigResult);
+ break;
case INST_SUB:
- mp_sub(&big1, &big2, &bigResult);
- break;
+ err = mp_sub(&big1, &big2, &bigResult);
+ break;
case INST_MULT:
- mp_mul(&big1, &big2, &bigResult);
- break;
+ err = mp_mul(&big1, &big2, &bigResult);
+ break;
case INST_DIV:
- if (mp_iszero(&big2)) {
- mp_clear(&big1);
- mp_clear(&big2);
- mp_clear(&bigResult);
- return DIVIDED_BY_ZERO;
- }
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- /* TODO: internals intrusion */
- if (!mp_iszero(&bigRemainder)
- && (bigRemainder.sign != big2.sign)) {
- /*
- * Convert to Tcl's integer division rules.
- */
+ if (mp_iszero(&big2)) {
+ mp_clear(&big1);
+ mp_clear(&big2);
+ mp_clear(&bigResult);
+ return DIVIDED_BY_ZERO;
+ }
+ err = mp_init(&bigRemainder);
+ if (err == MP_OKAY) {
+ err = mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ }
+ /* TODO: internals intrusion */
+ if (!mp_iszero(&bigRemainder)
+ && (bigRemainder.sign != big2.sign)) {
+ /*
+ * Convert to Tcl's integer division rules.
+ */
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
+ err = mp_sub_d(&bigResult, 1, &bigResult);
+ if (err == MP_OKAY) {
+ err = mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ }
+ mp_clear(&bigRemainder);
+ break;
}
- mp_clear(&bigRemainder);
- break;
}
mp_clear(&big1);
mp_clear(&big2);
@@ -9281,58 +8977,58 @@ ExecuteExtendedUnaryMathOp(
int opcode, /* What operation to perform. */
Tcl_Obj *valuePtr) /* The operand on the stack. */
{
- ClientData ptr = NULL;
+ void *ptr = NULL;
int type;
Tcl_WideInt w;
mp_int big;
Tcl_Obj *objResultPtr;
+ mp_err err = MP_OKAY;
(void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
switch (opcode) {
case INST_BITNOT:
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
+ if (type == TCL_NUMBER_INT) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
-#endif
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
/* ~a = - a - 1 */
- (void)mp_neg(&big, &big);
- mp_sub_d(&big, 1, &big);
+ err = mp_neg(&big, &big);
+ if (err == MP_OKAY) {
+ err = mp_sub_d(&big, 1, &big);
+ }
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&big);
case INST_UMINUS:
switch (type) {
case TCL_NUMBER_DOUBLE:
DOUBLE_RESULT(-(*((const double *) ptr)));
- case TCL_NUMBER_LONG:
- w = (Tcl_WideInt) (*((const long *) ptr));
- if (w != LLONG_MIN) {
- WIDE_RESULT(-w);
- }
- TclBNInitBignumFromLong(&big, *(const long *) ptr);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w = *((const Tcl_WideInt *) ptr);
- if (w != LLONG_MIN) {
+ if (w != WIDE_MIN) {
WIDE_RESULT(-w);
}
- TclBNInitBignumFromWideInt(&big, w);
+ err = mp_init_i64(&big, w);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
break;
-#endif
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
- (void)mp_neg(&big, &big);
+ err = mp_neg(&big, &big);
+ if (err != MP_OKAY) {
+ return OUT_OF_MEMORY;
+ }
BIG_RESULT(&big);
}
Tcl_Panic("unexpected opcode");
return NULL;
}
-#undef LONG_RESULT
#undef WIDE_RESULT
#undef BIG_RESULT
#undef DOUBLE_RESULT
@@ -9361,42 +9057,33 @@ TclCompareTwoNumbers(
Tcl_Obj *value2Ptr)
{
int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare;
- ClientData ptr1, ptr2;
+ void *ptr1, *ptr2;
mp_int big1, big2;
double d1, d2, tmp;
- long l1, l2;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
-#endif
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (type1) {
- case TCL_NUMBER_LONG:
- l1 = *((const long *)ptr1);
+ case TCL_NUMBER_INT:
+ w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- longCompare:
- return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
- w1 = (Tcl_WideInt)l1;
- goto wideCompare;
-#endif
+ wideCompare:
+ return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
- d1 = (double) l1;
+ d1 = (double) w1;
/*
- * If the double has a fractional part, or if the long can be
+ * If the double has a fractional part, or if the Tcl_WideInt can be
* converted to double without loss of precision, then compare as
* doubles.
*/
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt)d1
|| modf(d2, &tmp) != 0.0) {
goto doubleCompare;
}
@@ -9413,52 +9100,13 @@ TclCompareTwoNumbers(
* integer comparison can tell the difference.
*/
- if (d2 < (double)LONG_MIN) {
+ if (d2 < (double)WIDE_MIN) {
return MP_GT;
}
- if (d2 > (double)LONG_MAX) {
+ if (d2 > (double)WIDE_MAX) {
return MP_LT;
}
- l2 = (long) d2;
- goto longCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- return compare;
- }
- break;
-
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *)ptr1);
- switch (type2) {
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- wideCompare:
- return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- w2 = (Tcl_WideInt)l2;
- goto wideCompare;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) w1;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d2 < (double)LLONG_MIN) {
- return MP_GT;
- }
- if (d2 > (double)LLONG_MAX) {
- return MP_LT;
- }
- w2 = (Tcl_WideInt) d2;
+ w2 = (Tcl_WideInt)d2;
goto wideCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
@@ -9471,7 +9119,6 @@ TclCompareTwoNumbers(
return compare;
}
break;
-#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -9480,44 +9127,27 @@ TclCompareTwoNumbers(
d2 = *((const double *)ptr2);
doubleCompare:
return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- d2 = (double) l2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LONG_MIN) {
- return MP_LT;
- }
- if (d1 > (double)LONG_MAX) {
- return MP_GT;
- }
- l1 = (long) d1;
- goto longCompare;
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_INT:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) {
+ || w2 == (Tcl_WideInt)d2 || modf(d1, &tmp) != 0.0) {
goto doubleCompare;
}
- if (d1 < (double)LLONG_MIN) {
+ if (d1 < (double)WIDE_MIN) {
return MP_LT;
}
- if (d1 > (double)LLONG_MAX) {
+ if (d1 > (double)WIDE_MAX) {
return MP_GT;
}
- w1 = (Tcl_WideInt) d1;
+ w1 = (Tcl_WideInt)d1;
goto wideCompare;
-#endif
case TCL_NUMBER_BIG:
- if (TclIsInfinite(d1)) {
+ if (isinf(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
+ if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) {
if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
@@ -9526,7 +9156,7 @@ TclCompareTwoNumbers(
mp_clear(&big2);
return compare;
}
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
&& modf(d1, &tmp) != 0.0) {
d2 = TclBignumToDouble(&big2);
mp_clear(&big2);
@@ -9540,26 +9170,23 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
-#endif
- case TCL_NUMBER_LONG:
+ case TCL_NUMBER_INT:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
- if (TclIsInfinite(d2)) {
+ if (isinf(d2)) {
compare = (d2 > 0.0) ? MP_LT : MP_GT;
mp_clear(&big1);
return compare;
}
- if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
+ if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) {
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
}
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
&& modf(d2, &tmp) != 0.0) {
d1 = TclBignumToDouble(&big1);
mp_clear(&big1);
@@ -9609,10 +9236,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n",
+ codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
-
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
@@ -9627,13 +9253,13 @@ PrintByteCodeInfo(
0.0);
#ifdef TCL_COMPILE_STATS
- fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
+ fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n",
(unsigned long) codePtr->structureSize,
- (unsigned long) (TclOffset(ByteCode, localCachePtr)),
+ offsetof(ByteCode, localCachePtr),
codePtr->numCodeBytes,
- (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
- (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
- (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numLitObjects * sizeof(Tcl_Obj *),
+ codePtr->numExceptRanges*sizeof(ExceptionRange),
+ codePtr->numAuxDataItems * sizeof(AuxData),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
@@ -9671,44 +9297,44 @@ ValidatePcAndStackTop(
* stdout. */
const unsigned char *pc, /* Points to first byte of a bytecode
* instruction. The program counter. */
- int stackTop, /* Current stack top. Must be between
+ size_t stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
- int stackUpperBound = codePtr->maxStackDepth;
+ 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 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 (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) {
+ 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 ((unsigned) opCode > LAST_INST_OPCODE) {
- fprintf(stderr, "\nBad opcode %d at pc %lu in TclNRExecuteByteCode\n",
- (unsigned) opCode, (unsigned long)relativePc);
+ fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
+ (unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
- ((stackTop < 0) || (stackTop > stackUpperBound))) {
+ (stackTop > stackUpperBound)) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %lu in TclNRExecuteByteCode (min 0, max %i)",
- stackTop, (unsigned long)relativePc, stackUpperBound);
+ 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);
- fprintf(stderr,"%s\n", Tcl_GetString(message));
+ fprintf(stderr,"%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
@@ -9745,7 +9371,7 @@ IllegalExprOperandType(
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
- ClientData ptr;
+ void *ptr;
int type;
const unsigned char opcode = *pc;
const char *description, *op = "unknown";
@@ -9757,8 +9383,8 @@ IllegalExprOperandType(
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
- int numBytes;
- const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
+ Tcl_Size numBytes;
+ const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
@@ -9777,8 +9403,9 @@ IllegalExprOperandType(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't use %s as operand of \"%s\"", description, op));
- Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
+ "can't use %s \"%s\" as operand of \"%s\"", description,
+ TclGetString(opndPtr), op));
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (void *)NULL);
}
/*
@@ -9808,7 +9435,7 @@ IllegalExprOperandType(
Tcl_Obj *
TclGetSourceFromFrame(
CmdFrame *cfPtr,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
if (cfPtr == NULL) {
@@ -9854,7 +9481,8 @@ TclGetSrcInfoForPc(
ExtCmdLoc *eclPtr;
ECL *locPtr = NULL;
- int srcOffset, i;
+ Tcl_Size srcOffset;
+ int i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
@@ -9864,7 +9492,7 @@ TclGetSrcInfoForPc(
}
srcOffset = cfPtr->cmd - codePtr->source;
- eclPtr = Tcl_GetHashValue(hePtr);
+ eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
@@ -9900,25 +9528,25 @@ GetSrcInfoForPc(
* in codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
- int *lengthPtr, /* If non-NULL, the location where the length
+ Tcl_Size *lengthPtr, /* If non-NULL, the location where the length
* of the command's source should be stored.
* If NULL, no length is stored. */
const unsigned char **pcBeg,/* If non-NULL, the bytecode location
* where the current instruction starts.
* If NULL; no pointer is stored. */
- int *cmdIdxPtr) /* If non-NULL, the location where the index
+ Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index
* of the command containing the pc should
* be stored. */
{
- int pcOffset = (pc - codePtr->codeStart);
- int numCmds = codePtr->numCommands;
+ Tcl_Size pcOffset = pc - codePtr->codeStart;
+ Tcl_Size numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
+ Tcl_Size 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;
+ Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
+ Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */
+ Tcl_Size bestCmdIdx = -1;
/* The pc must point within the bytecode */
assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes));
@@ -10089,7 +9717,7 @@ GetExceptRangeForPc(
if (searchMode == TCL_BREAK) {
return rangePtr;
}
- if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){
+ if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){
return rangePtr;
}
}
@@ -10152,26 +9780,26 @@ TclExprFloatError(
{
const char *s;
- if ((errno == EDOM) || TclIsNaN(value)) {
+ if ((errno == EDOM) || isnan(value)) {
s = "domain error: argument not in valid range";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
- } else if ((errno == ERANGE) || TclIsInfinite(value)) {
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (void *)NULL);
+ } else if ((errno == ERANGE) || isinf(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL);
+ Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (void *)NULL);
} else {
s = "floating-point value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL);
+ Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (void *)NULL);
}
} else {
Tcl_Obj *objPtr = Tcl_ObjPrintf(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), (void *)NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
@@ -10229,7 +9857,7 @@ TclLog2(
static int
EvalStatsCmd(
- ClientData unused, /* Unused. */
+ TCL_UNUSED(void *), /* Unused. */
Tcl_Interp *interp, /* The current interpreter. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The argument strings. */
@@ -10242,10 +9870,10 @@ EvalStatsCmd(
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
- long numCurrentByteCodes, numByteCodeLits;
- long refCountSum, literalMgmtBytes, sum;
- int numSharedMultX, numSharedOnce;
- int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
+ size_t numCurrentByteCodes, numByteCodeLits;
+ size_t refCountSum, literalMgmtBytes, sum;
+ size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i;
+ int decadeHigh, length;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
@@ -10272,7 +9900,7 @@ EvalStatsCmd(
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
- * (TclOffset(ByteCode, localCachePtr));
+ * offsetof(ByteCode, localCachePtr);
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
@@ -10287,12 +9915,12 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
- "Compilation and execution statistics for interpreter %#lx\n",
- (unsigned long)(size_t)iPtr);
+ "Compilation and execution statistics for interpreter %p\n",
+ iPtr);
- Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
@@ -10304,7 +9932,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
@@ -10314,18 +9942,18 @@ EvalStatsCmd(
statsPtr->totalByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
totalLiteralBytes);
- Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
- (unsigned long) sizeof(LiteralTable),
- (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
- (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
- (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
+ Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
+ statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n",
numCurrentByteCodes);
Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
@@ -10335,11 +9963,11 @@ EvalStatsCmd(
statsPtr->currentByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
- Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
- (unsigned long) sizeof(LiteralTable),
- (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
- (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
- (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
+ Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ iPtr->literalTable.numEntries * sizeof(LiteralEntry),
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
@@ -10356,17 +9984,17 @@ EvalStatsCmd(
numSharedMultX = 0;
Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
- Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
- Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
- Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
- Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
/*
@@ -10384,10 +10012,10 @@ EvalStatsCmd(
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
- if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
+ if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
- (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ (void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
@@ -10403,20 +10031,20 @@ EvalStatsCmd(
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
- Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
tclObjsAlloced);
- Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
(tclObjsAlloced - tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_SIZE_MODIFIER "d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
- Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
@@ -10441,7 +10069,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,
Percent(literalMgmtBytes, currentLiteralBytes));
Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
@@ -10491,7 +10119,8 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
- for (i = 31; i >= 0; i--) {
+ i = 32;
+ while (i-- > 0) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10501,7 +10130,7 @@ EvalStatsCmd(
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
- Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
@@ -10523,7 +10152,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->srcCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10533,7 +10162,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
- Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
@@ -10546,7 +10175,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10556,7 +10185,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
- Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
@@ -10569,7 +10198,7 @@ EvalStatsCmd(
break;
}
}
- for (i = 31; i >= 0; i--) {
+ for (i = 31; i != (size_t)-1; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
maxSizeDecade = i;
break;
@@ -10589,7 +10218,7 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
- Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
+ Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ",
tclInstructionTable[i].name, statsPtr->instructionCount[i]);
if (statsPtr->instructionCount[i]) {
Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
@@ -10601,7 +10230,7 @@ EvalStatsCmd(
#ifdef TCL_MEM_DEBUG
Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
- TclDumpMemoryInfo((ClientData) objPtr, 1);
+ TclDumpMemoryInfo(objPtr, 1);
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
@@ -10609,7 +10238,7 @@ EvalStatsCmd(
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
- char *str = Tcl_GetStringFromObj(objv[1], &length);
+ char *str = TclGetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 56445b6..8ca0c88 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -4,7 +4,7 @@
* This file implements the generic portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright © 1996-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.
@@ -47,7 +47,7 @@ static int FileForceOption(Tcl_Interp *interp,
int
TclFileRenameCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
@@ -76,7 +76,7 @@ TclFileRenameCmd(
int
TclFileCopyCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
@@ -214,7 +214,7 @@ FileCopyRename(
int
TclFileMakeDirsCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
@@ -338,7 +338,7 @@ TclFileMakeDirsCmd(
int
TclFileDeleteCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
@@ -946,7 +946,7 @@ FileBasename(
int
TclFileAttrsCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
@@ -1006,7 +1006,7 @@ TclFileAttrsCmd(
* Use objStrings as a list object.
*/
- if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
+ if (TclListObjLengthM(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStringsAllocated = (const char **)
@@ -1080,17 +1080,14 @@ TclFileAttrsCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[0]);
- }
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
@@ -1107,23 +1104,20 @@ TclFileAttrsCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
+ Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", (void *)NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
- "option", 0, &index) != TCL_OK) {
+ "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[i]);
- }
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
- "NOVALUE", NULL);
+ "NOVALUE", (void *)NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
@@ -1168,7 +1162,7 @@ TclFileAttrsCmd(
int
TclFileLinkCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1319,7 +1313,7 @@ TclFileLinkCmd(
int
TclFileReadLinkCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1351,7 +1345,7 @@ TclFileReadLinkCmd(
/*
*---------------------------------------------------------------------------
*
- * TclFileTemporaryCmd
+ * TclFileTemporaryCmd --
*
* This function implements the "tempfile" subcommand of the "file"
* command.
@@ -1370,7 +1364,7 @@ TclFileReadLinkCmd(
int
TclFileTemporaryCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1511,6 +1505,227 @@ TclFileTemporaryCmd(
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileTempDirCmd --
+ *
+ * This function implements the "tempdir" subcommand of the "file"
+ * command.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Creates a temporary directory.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclFileTempDirCmd(
+ TCL_UNUSED(ClientData),
+ 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;
+ /* Pieces of template. Each piece is NULL if
+ * it is omitted. The platform temporary file
+ * engine might ignore some pieces. */
+
+ if (objc < 1 || objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?template?");
+ return TCL_ERROR;
+ }
+
+ if (objc > 1) {
+ int length;
+ Tcl_Obj *templateObj = objv[1];
+ const char *string = TclGetStringFromObj(templateObj, &length);
+ const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
+
+ /*
+ * Treat an empty string as if it wasn't there.
+ */
+
+ if (length == 0) {
+ goto makeTemporary;
+ }
+
+ /*
+ * The template only gives a directory if there is a directory
+ * separator in it, and only gives a base name if there's at least one
+ * character after the last directory separator.
+ */
+
+ if (strchr(string, '/') == NULL
+ && (!onWindows || strchr(string, '\\') == NULL)) {
+ /*
+ * No directory separator, so just assume we have a file name.
+ * This is a bit wrong on Windows where we could have problems
+ * with disk name prefixes... but those are much less common in
+ * naked form so we just pass through and let the OS figure it out
+ * instead.
+ */
+
+ nameBaseObj = templateObj;
+ Tcl_IncrRefCount(nameBaseObj);
+ } else if (string[length-1] != '/'
+ && (!onWindows || string[length-1] != '\\')) {
+ /*
+ * If the template has a non-terminal directory separator, split
+ * into dirname and tail.
+ */
+
+ baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
+ nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL);
+ } else {
+ /*
+ * Otherwise, there must be a terminal directory separator, so
+ * just the directory is given.
+ */
+
+ baseDirObj = templateObj;
+ Tcl_IncrRefCount(baseDirObj);
+ }
+
+ /*
+ * Only allow creation of temporary directories in the native
+ * filesystem since they are frequently used for integration with
+ * external tools or system libraries.
+ */
+
+ if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj)
+ != &tclNativeFilesystem) {
+ TclDecrRefCount(baseDirObj);
+ baseDirObj = NULL;
+ }
+ }
+
+ /*
+ * Convert empty parts of the template into unspecified parts.
+ */
+
+ if (baseDirObj && !TclGetString(baseDirObj)[0]) {
+ TclDecrRefCount(baseDirObj);
+ baseDirObj = NULL;
+ }
+ if (nameBaseObj && !TclGetString(nameBaseObj)[0]) {
+ TclDecrRefCount(nameBaseObj);
+ nameBaseObj = NULL;
+ }
+
+ /*
+ * Create and open the temporary file.
+ */
+
+ makeTemporary:
+ dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj);
+
+ /*
+ * If we created pieces of template, get rid of them now.
+ */
+
+ if (baseDirObj) {
+ TclDecrRefCount(baseDirObj);
+ }
+ if (nameBaseObj) {
+ TclDecrRefCount(nameBaseObj);
+ }
+
+ /*
+ * Deal with results.
+ */
+
+ if (dirNameObj == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "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 : TclGetString(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
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index d6dac9c..7f4f1cc 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -4,8 +4,8 @@
* This file contains routines for converting file names betwen native
* and network form.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
+ * Copyright © 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -37,6 +37,17 @@ static Tcl_Obj * SplitUnixPath(const char *path);
static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
const char *separators, Tcl_Obj *pathPtr, int flags,
char *pattern, Tcl_GlobTypeData *types);
+static int TclGlob(Tcl_Interp *interp, char *pattern,
+ Tcl_Obj *pathPrefix, int globFlags,
+ Tcl_GlobTypeData *types);
+
+/* Flag values used by TclGlob() */
+
+#ifdef TCL_NO_DEPRECATED
+# define TCL_GLOBMODE_NO_COMPLAIN 1
+# define TCL_GLOBMODE_DIR 4
+# define TCL_GLOBMODE_TAILS 8
+#endif
/*
* When there is no support for getting the block size of a file in a stat()
@@ -387,7 +398,7 @@ TclpGetNativePathType(
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
- const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = TclGetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -413,7 +424,6 @@ TclpGetNativePathType(
if (path[0] == '/') {
++path;
-#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
@@ -423,7 +433,6 @@ TclpGetNativePathType(
++path;
}
}
-#endif
if (driveNameLengthPtr != NULL) {
/*
* We need this addition in case the "//" code was used.
@@ -445,7 +454,7 @@ TclpGetNativePathType(
if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
*driveNameLengthPtr = rootEnd - path;
if (driveNameRef != NULL) {
- *driveNameRef = TclDStringToObj(&ds);
+ *driveNameRef = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(*driveNameRef);
}
}
@@ -493,11 +502,11 @@ TclpNativeSplitPath(
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
- resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
+ resultPtr = SplitUnixPath(TclGetString(pathPtr));
break;
case TCL_PLATFORM_WINDOWS:
- resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
+ resultPtr = SplitWinPath(TclGetString(pathPtr));
break;
}
@@ -506,7 +515,7 @@ TclpNativeSplitPath(
*/
if (lenPtr != NULL) {
- TclListObjLength(NULL, resultPtr, lenPtr);
+ TclListObjLengthM(NULL, resultPtr, lenPtr);
}
return resultPtr;
}
@@ -536,6 +545,7 @@ TclpNativeSplitPath(
*----------------------------------------------------------------------
*/
+#undef Tcl_SplitPath
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
@@ -567,7 +577,7 @@ Tcl_SplitPath(
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- Tcl_GetStringFromObj(eltPtr, &len);
+ TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
@@ -587,7 +597,7 @@ Tcl_SplitPath(
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- str = Tcl_GetStringFromObj(eltPtr, &len);
+ str = TclGetStringFromObj(eltPtr, &len);
memcpy(p, str, len + 1);
p += len+1;
}
@@ -644,7 +654,6 @@ SplitUnixPath(
if (*path == '/') {
Tcl_Obj *rootElt;
++path;
-#if defined(__CYGWIN__) || defined(__QNX__)
/*
* Check for "//" network path prefix
*/
@@ -654,7 +663,6 @@ SplitUnixPath(
++path;
}
}
-#endif
rootElt = Tcl_NewStringObj(origPath, path - origPath);
Tcl_ListObjAppendElement(NULL, result, rootElt);
while (*path == '/') {
@@ -726,7 +734,7 @@ SplitWinPath(
*/
if (p != path) {
- Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
+ Tcl_ListObjAppendElement(NULL, result, Tcl_DStringToObj(&buf));
}
Tcl_DStringFree(&buf);
@@ -838,7 +846,7 @@ TclpNativeJoinPath(
const char *p;
const char *start;
- start = Tcl_GetStringFromObj(prefix, &length);
+ start = TclGetStringFromObj(prefix, &length);
/*
* Remove the ./ from tilde prefixed elements, and drive-letter prefixed
@@ -866,7 +874,7 @@ TclpNativeJoinPath(
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -902,7 +910,7 @@ TclpNativeJoinPath(
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- Tcl_GetStringFromObj(prefix, &length);
+ TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
@@ -911,7 +919,7 @@ TclpNativeJoinPath(
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
- dest = Tcl_GetString(prefix) + length;
+ dest = TclGetString(prefix) + length;
for (; *p != '\0'; p++) {
if ((*p == '/') || (*p == '\\')) {
while ((p[1] == '/') || (p[1] == '\\')) {
@@ -985,7 +993,7 @@ Tcl_JoinPath(
* Store the result.
*/
- resultStr = Tcl_GetStringFromObj(resultObj, &len);
+ resultStr = TclGetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
@@ -1164,7 +1172,7 @@ DoTildeSubst(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment "
"variable to expand path", -1));
- Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", (void *)NULL);
}
return NULL;
}
@@ -1175,7 +1183,7 @@ DoTildeSubst(
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", user));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, (void *)NULL);
}
return NULL;
}
@@ -1201,7 +1209,7 @@ DoTildeSubst(
int
Tcl_GlobObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1222,7 +1230,6 @@ Tcl_GlobObjCmd(
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
- (void)dummy;
globFlags = 0;
join = 0;
@@ -1231,7 +1238,7 @@ Tcl_GlobObjCmd(
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
- string = Tcl_GetStringFromObj(objv[i], &length);
+ string = TclGetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal an
@@ -1258,7 +1265,7 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
@@ -1268,7 +1275,7 @@ Tcl_GlobObjCmd(
: "\"-directory\" cannot be used with \"-path\"",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
- "BADOPTIONCOMBINATION", NULL);
+ "BADOPTIONCOMBINATION", (void *)NULL);
return TCL_ERROR;
}
dir = PATH_DIR;
@@ -1286,7 +1293,7 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
@@ -1296,7 +1303,7 @@ Tcl_GlobObjCmd(
: "\"-path\" cannot be used with \"-dictionary\"",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
- "BADOPTIONCOMBINATION", NULL);
+ "BADOPTIONCOMBINATION", (void *)NULL);
return TCL_ERROR;
}
dir = PATH_GENERAL;
@@ -1307,11 +1314,11 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
- if (TclListObjLength(interp, typePtr, &length) != TCL_OK) {
+ if (TclListObjLengthM(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
@@ -1328,7 +1335,7 @@ Tcl_GlobObjCmd(
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
- "BADOPTIONCOMBINATION", NULL);
+ "BADOPTIONCOMBINATION", (void *)NULL);
return TCL_ERROR;
}
@@ -1345,7 +1352,7 @@ Tcl_GlobObjCmd(
if (dir == PATH_GENERAL) {
int pathlength;
const char *last;
- const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
+ const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
@@ -1392,11 +1399,15 @@ Tcl_GlobObjCmd(
* We must ensure that we haven't cut off too much, and turned
* a valid path like '/' or 'C:/' into an incorrect path like
* '' or 'C:'. The way we do this is to add a separator if
- * there are none presently in the prefix.
+ * there are none presently in the prefix. Similar treatment
+ * for the zipfs volume.
*/
- if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
+ const char *temp = Tcl_GetString(pathOrDir);
+ if (strpbrk(temp, "\\/") == NULL) {
Tcl_AppendToObj(pathOrDir, last-1, 1);
+ } else if (!strcmp(temp, "//zipfs:")) {
+ Tcl_AppendToObj(pathOrDir, "/", 1);
}
}
@@ -1433,7 +1444,7 @@ Tcl_GlobObjCmd(
* platform.
*/
- TclListObjLength(interp, typePtr, &length);
+ TclListObjLengthM(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
@@ -1448,7 +1459,7 @@ Tcl_GlobObjCmd(
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
- str = Tcl_GetStringFromObj(look, &len);
+ str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
@@ -1503,7 +1514,7 @@ Tcl_GlobObjCmd(
} else {
Tcl_Obj *item;
- if ((TclListObjLength(NULL, look, &len) == TCL_OK)
+ if ((TclListObjLengthM(NULL, look, &len) == TCL_OK)
&& (len == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", Tcl_GetString(item))) {
@@ -1537,7 +1548,7 @@ Tcl_GlobObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument to \"-types\": %s",
Tcl_GetString(look)));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
@@ -1547,7 +1558,7 @@ Tcl_GlobObjCmd(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL);
join = 0;
goto endOfGlob;
}
@@ -1610,7 +1621,7 @@ Tcl_GlobObjCmd(
}
if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
- if (TclListObjLength(interp, Tcl_GetObjResult(interp),
+ if (TclListObjLengthM(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/*
* This should never happen. Maybe we should be more dramatic.
@@ -1639,7 +1650,7 @@ Tcl_GlobObjCmd(
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
- NULL);
+ (void *)NULL);
result = TCL_ERROR;
}
}
@@ -1692,7 +1703,7 @@ Tcl_GlobObjCmd(
*----------------------------------------------------------------------
*/
-int
+static int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
* appending list of matching file names. */
@@ -1760,7 +1771,7 @@ TclGlob(
if (head != Tcl_DStringValue(&buffer)) {
Tcl_DStringAppend(&buffer, head, -1);
}
- pathPrefix = TclDStringToObj(&buffer);
+ pathPrefix = Tcl_DStringToObj(&buffer);
Tcl_IncrRefCount(pathPrefix);
globFlags |= TCL_GLOBMODE_DIR;
if (c != '\0') {
@@ -1867,11 +1878,7 @@ TclGlob(
separators = "/\\";
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (pathPrefix == NULL && tail[0] == '/'
-#if defined(__CYGWIN__) || defined(__QNX__)
- && tail[1] != '/'
-#endif
- ) {
+ if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') {
pathPrefix = Tcl_NewStringObj(tail, 1);
tail++;
Tcl_IncrRefCount(pathPrefix);
@@ -1982,7 +1989,7 @@ TclGlob(
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
- pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
+ pre = TclGetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
@@ -1997,10 +2004,10 @@ TclGlob(
}
}
- TclListObjGetElements(NULL, filenamesObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
- const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
+ const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
@@ -2209,14 +2216,14 @@ DoGlob(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched open-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched close-brace in file name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
}
@@ -2324,13 +2331,13 @@ DoGlob(
int subdirc, i, repair = -1;
Tcl_Obj **subdirv;
- result = TclListObjGetElements(interp, subdirsPtr,
+ result = TclListObjGetElementsM(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
if (pathPtr == NULL && Tcl_GetString(subdirv[i])[0] == '~') {
- TclListObjLength(NULL, matchesObj, &repair);
+ TclListObjLengthM(NULL, matchesObj, &repair);
copy = subdirv[i];
subdirv[i] = Tcl_NewStringObj("./", 2);
Tcl_AppendObjToObj(subdirv[i], copy);
@@ -2343,14 +2350,14 @@ DoGlob(
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
- TclListObjLength(NULL, matchesObj, &end);
+ TclListObjLengthM(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
int numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
- bytes = Tcl_GetStringFromObj(fixme, &numBytes);
+ bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
@@ -2388,7 +2395,7 @@ DoGlob(
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
- (void) Tcl_GetStringFromObj(pathPtr, &length);
+ (void) TclGetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
@@ -2422,7 +2429,7 @@ DoGlob(
*/
if (pathPtr == NULL) {
- joinedPtr = TclDStringToObj(&append);
+ joinedPtr = Tcl_DStringToObj(&append);
} else if (flags) {
joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
@@ -2434,7 +2441,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
@@ -2471,7 +2478,7 @@ DoGlob(
*/
int len;
- const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
+ const char *joined = TclGetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
@@ -2536,21 +2543,21 @@ unsigned
Tcl_GetFSDeviceFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_dev;
+ return statPtr->st_dev;
}
unsigned
Tcl_GetFSInodeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_ino;
+ return statPtr->st_ino;
}
unsigned
Tcl_GetModeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (unsigned) statPtr->st_mode;
+ return statPtr->st_mode;
}
int
@@ -2581,61 +2588,66 @@ Tcl_GetDeviceTypeFromStat(
return (int) statPtr->st_rdev;
}
-Tcl_WideInt
+long long
Tcl_GetAccessTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_atime;
+ return (long long) statPtr->st_atime;
}
-Tcl_WideInt
+long long
Tcl_GetModificationTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_mtime;
+ return (long long) statPtr->st_mtime;
}
-Tcl_WideInt
+long long
Tcl_GetChangeTimeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideInt) statPtr->st_ctime;
+ return (long long) statPtr->st_ctime;
}
-Tcl_WideUInt
+unsigned long long
Tcl_GetSizeFromStat(
const Tcl_StatBuf *statPtr)
{
- return (Tcl_WideUInt) statPtr->st_size;
+ return (unsigned long long) statPtr->st_size;
}
-Tcl_WideUInt
+unsigned long long
Tcl_GetBlocksFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
- return (Tcl_WideUInt) statPtr->st_blocks;
+ return (unsigned long long) statPtr->st_blocks;
#else
unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
- return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
+ return ((unsigned long long) statPtr->st_size + blksize - 1) / blksize;
#endif
}
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
-#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
- return (unsigned) statPtr->st_blksize;
+ return statPtr->st_blksize;
+}
#else
+unsigned
+Tcl_GetBlockSizeFromStat(
+ TCL_UNUSED(const Tcl_StatBuf *))
+{
/*
* Not a great guess, but will do...
*/
return GUESSED_BLOCK_SIZE;
-#endif
}
+#endif
/*
* Local Variables:
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index e5dcffb..503b204 100644
--- a/generic/tclFileSystem.h
+++ b/generic/tclFileSystem.h
@@ -30,7 +30,7 @@ MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp,
MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr);
MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr,
- const Tcl_Filesystem *fsPtr, ClientData clientData);
+ const Tcl_Filesystem *fsPtr, void *clientData);
MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
MODULE_SCOPE size_t TclFSEpoch(void);
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 2f06cff..bb3f8f1 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -5,8 +5,8 @@
* integers or floating-point numbers or booleans, doing syntax checking
* along the way.
*
- * Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1990-1993 The Regents of the University of California.
+ * Copyright © 1994-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.
@@ -53,7 +53,7 @@ Tcl_GetInt(
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- TclFreeIntRep(&obj);
+ TclFreeInternalRep(&obj);
return code;
}
@@ -97,7 +97,7 @@ Tcl_GetDouble(
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
- TclFreeIntRep(&obj);
+ TclFreeInternalRep(&obj);
return code;
}
@@ -110,7 +110,7 @@ Tcl_GetDouble(
* string.
*
* Results:
- * The return value is normally TCL_OK; in this case *intPtr will be set
+ * The return value is normally TCL_OK; in this case *charPtr will be set
* to the 0/1 value equivalent to src. If src is improperly formed then
* TCL_ERROR is returned and an error message will be left in the
* interp's result.
@@ -121,17 +121,23 @@ Tcl_GetDouble(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetBool
+#undef Tcl_GetBoolFromObj
int
-Tcl_GetBoolean(
+Tcl_GetBool(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
const char *src, /* String containing one of the boolean values
* 1, 0, true, false, yes, no, on, off. */
- int *intPtr) /* Place to store converted result, which will
+ int flags,
+ char *charPtr) /* Place to store converted result, which will
* be 0 or 1. */
{
Tcl_Obj obj;
int code;
+ if ((src == NULL) || (*src == '\0')) {
+ return Tcl_GetBoolFromObj(interp, NULL, flags, charPtr);
+ }
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
@@ -142,10 +148,22 @@ Tcl_GetBoolean(
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
- *intPtr = obj.internalRep.longValue;
+ Tcl_GetBoolFromObj(NULL, &obj, flags, charPtr);
}
return code;
}
+
+#undef Tcl_GetBoolean
+int
+Tcl_GetBoolean(
+ Tcl_Interp *interp, /* Interpreter used for error reporting. */
+ const char *src, /* String containing one of the boolean values
+ * 1, 0, true, false, yes, no, on, off. */
+ int *intPtr) /* Place to store converted result, which will
+ * be 0 or 1. */
+{
+ return Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr);
+}
/*
* Local Variables:
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index ac9bf1c..5a79cf2 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -959,7 +959,7 @@ TclDatelex(
int
TclClockOldscanObjCmd(
- void *dummy, /* Unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
@@ -969,7 +969,6 @@ TclClockOldscanObjCmd(
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
- (void)dummy;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -977,7 +976,7 @@ TclClockOldscanObjCmd(
return TCL_ERROR;
}
- yyInput = Tcl_GetString( objv[1] );
+ yyInput = TclGetString( objv[1] );
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
@@ -1076,7 +1075,8 @@ TclClockOldscanObjCmd(
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int)
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
- Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
+ TclNewObj(resultElement);
+ Tcl_ListObjAppendElement(interp, result, resultElement);
}
TclNewObj(resultElement);
diff --git a/generic/tclHash.c b/generic/tclHash.c
index f4b0a47..ea1b20e 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -4,8 +4,8 @@
* Implementation of in-memory hash tables for Tcl and Tcl-based
* applications.
*
- * Copyright (c) 1991-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
+ * Copyright © 1991-1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -43,20 +43,7 @@
static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
-
-/*
- * Prototypes for the one word hash key methods. Not actually declared because
- * this is a critical path that is implemented in the core hash table access
- * function.
- */
-
-#if 0
-static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr,
- void *keyPtr);
-static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr);
-#endif
+static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the string hash key methods.
@@ -65,7 +52,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr);
static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr,
void *keyPtr);
static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr);
-static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
+static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Function prototypes for static functions in this file:
@@ -232,7 +219,7 @@ Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key) /* Key to use to find matching entry. */
{
- return (*((tablePtr)->findProc))(tablePtr, key);
+ return (*((tablePtr)->findProc))(tablePtr, (const char *)key);
}
static Tcl_HashEntry *
@@ -273,7 +260,7 @@ Tcl_CreateHashEntry(
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
- return (*((tablePtr)->createProc))(tablePtr, key, newPtr);
+ return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
}
static Tcl_HashEntry *
@@ -286,8 +273,7 @@ CreateHashEntry(
{
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
- unsigned int hash;
- int index;
+ TCL_HASH_TYPE hash, index;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
@@ -321,11 +307,9 @@ CreateHashEntry(
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
|| compareKeysProc((void *) key, hPtr)
@@ -339,11 +323,9 @@ CreateHashEntry(
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
-#if TCL_HASH_KEY_STORE_HASH
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
-#endif
if (key == hPtr->key.oneWordValue) {
if (newPtr) {
*newPtr = 0;
@@ -365,21 +347,15 @@ CreateHashEntry(
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
- hPtr = ckalloc(sizeof(Tcl_HashEntry));
+ hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
- hPtr->clientData = 0;
+ Tcl_SetHashValue(hPtr, NULL);
}
hPtr->tablePtr = tablePtr;
-#if TCL_HASH_KEY_STORE_HASH
hPtr->hash = UINT2PTR(hash);
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
tablePtr->numEntries++;
/*
@@ -419,9 +395,7 @@ Tcl_DeleteHashEntry(
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
-#if TCL_HASH_KEY_STORE_HASH
- int index;
-#endif
+ TCL_HASH_TYPE index;
tablePtr = entryPtr->tablePtr;
@@ -436,18 +410,14 @@ Tcl_DeleteHashEntry(
typePtr = &tclArrayHashKeyType;
}
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash));
+ index = RANDOM_INDEX(tablePtr, PTR2UINT(entryPtr->hash));
} else {
index = PTR2UINT(entryPtr->hash) & tablePtr->mask;
}
bucketPtr = &tablePtr->buckets[index];
-#else
- bucketPtr = entryPtr->bucketPtr;
-#endif
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
@@ -643,7 +613,8 @@ Tcl_HashStats(
Tcl_HashTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
- int count[NUM_COUNTERS], overflow, i, j;
+ int i;
+ TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j;
double average, tmp;
Tcl_HashEntry *hPtr;
char *result, *p;
@@ -677,16 +648,16 @@ Tcl_HashStats(
* Print out the histogram and a few other pieces of information.
*/
- result = ckalloc((NUM_COUNTERS * 60) + 300);
- snprintf(result, 60, "%d entries in table, %d buckets\n",
+ result = (char *)ckalloc((NUM_COUNTERS * 60) + 300);
+ snprintf(result, 60, "%u entries in table, %u buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
- snprintf(p, 60, "number of buckets with %d entries: %d\n",
+ snprintf(p, 60, "number of buckets with %u entries: %u\n",
i, count[i]);
p += strlen(p);
}
- snprintf(p, 60, "number of buckets with %d or more entries: %d\n",
+ snprintf(p, 60, "number of buckets with %u or more entries: %u\n",
NUM_COUNTERS, overflow);
p += strlen(p);
snprintf(p, 60, "average search distance for entry: %.1f", average);
@@ -712,27 +683,19 @@ Tcl_HashStats(
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key to store in the hash table entry. */
+ void *keyPtr) /* Key to store in the hash table entry. */
{
- int *array = (int *) keyPtr;
- int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
- int count;
- unsigned int size;
+ TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int);
+ TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count;
- count = tablePtr->keyType;
-
- size = TclOffset(Tcl_HashEntry, key) + count*sizeof(int);
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
- hPtr = ckalloc(size);
+ hPtr = (Tcl_HashEntry *)ckalloc(size);
- for (iPtr1 = array, iPtr2 = hPtr->key.words;
- count > 0; count--, iPtr1++, iPtr2++) {
- *iPtr2 = *iPtr1;
- }
- hPtr->clientData = 0;
+ memcpy(hPtr->key.string, keyPtr, count);
+ Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
@@ -756,23 +719,12 @@ AllocArrayEntry(
static int
CompareArrayKeys(
- void *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- const int *iPtr1 = (const int *) keyPtr;
- const int *iPtr2 = (const int *) hPtr->key.words;
- Tcl_HashTable *tablePtr = hPtr->tablePtr;
- int count;
+ size_t count = hPtr->tablePtr->keyType * sizeof(int);
- for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
- if (count == 0) {
- return 1;
- }
- if (*iPtr1 != *iPtr2) {
- break;
- }
- }
- return 0;
+ return !memcmp(keyPtr, hPtr->key.string, count);
}
/*
@@ -793,13 +745,13 @@ CompareArrayKeys(
*----------------------------------------------------------------------
*/
-static unsigned int
+static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key from which to compute hash value. */
+ void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
- unsigned int result;
+ TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
@@ -827,21 +779,21 @@ HashArrayKey(
static Tcl_HashEntry *
AllocStringEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key to store in the hash table entry. */
+ TCL_UNUSED(Tcl_HashTable *),
+ void *keyPtr) /* Key to store in the hash table entry. */
{
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
- unsigned int size, allocsize;
+ size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
- hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize);
- memset(hPtr, 0, TclOffset(Tcl_HashEntry, key) + allocsize);
+ hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize);
+ memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize);
memcpy(hPtr->key.string, string, size);
- hPtr->clientData = 0;
+ Tcl_SetHashValue(hPtr, NULL);
return hPtr;
}
@@ -864,13 +816,10 @@ AllocStringEntry(
static int
CompareStringKeys(
- void *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- const char *p1 = (const char *) keyPtr;
- const char *p2 = (const char *) hPtr->key.string;
-
- return !strcmp(p1, p2);
+ return !strcmp((char *)keyPtr, hPtr->key.string);
}
/*
@@ -890,13 +839,13 @@ CompareStringKeys(
*----------------------------------------------------------------------
*/
-static unsigned
+static TCL_HASH_TYPE
HashStringKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
- void *keyPtr) /* Key from which to compute hash value. */
+ TCL_UNUSED(Tcl_HashTable *),
+ void *keyPtr) /* Key from which to compute hash value. */
{
- const char *string = keyPtr;
- unsigned int result;
+ const char *string = (const char *)keyPtr;
+ TCL_HASH_TYPE result;
char c;
/*
@@ -944,7 +893,7 @@ HashStringKey(
*
* BogusFind --
*
- * This function is invoked when an Tcl_FindHashEntry is called on a
+ * This function is invoked when Tcl_FindHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -956,11 +905,10 @@ HashStringKey(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static Tcl_HashEntry *
BogusFind(
- Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key) /* Key to use to find matching entry. */
+ TCL_UNUSED(Tcl_HashTable *),
+ TCL_UNUSED(const char *))
{
Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry");
return NULL;
@@ -971,7 +919,7 @@ BogusFind(
*
* BogusCreate --
*
- * This function is invoked when an Tcl_CreateHashEntry is called on a
+ * This function is invoked when Tcl_CreateHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -983,14 +931,11 @@ BogusFind(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static Tcl_HashEntry *
BogusCreate(
- Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
- const char *key, /* Key to use to find or create matching
- * entry. */
- int *newPtr) /* Store info here telling whether a new entry
- * was created. */
+ TCL_UNUSED(Tcl_HashTable *),
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(int *))
{
Tcl_Panic("called %s on deleted table", "Tcl_CreateHashEntry");
return NULL;
@@ -1018,14 +963,14 @@ static void
RebuildTable(
Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
- int count, index, oldSize = tablePtr->numBuckets;
+ TCL_HASH_TYPE count, index, oldSize = tablePtr->numBuckets;
Tcl_HashEntry **oldBuckets = tablePtr->buckets;
Tcl_HashEntry **oldChainPtr, **newChainPtr;
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
/* Avoid outgrowing capability of the memory allocators */
- if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
+ if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) {
tablePtr->rebuildSize = INT_MAX;
return;
}
@@ -1048,18 +993,20 @@ RebuildTable(
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
- tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
- (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
+ tablePtr->buckets = (Tcl_HashEntry **)TclpSysAlloc(
+ tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0);
} else {
tablePtr->buckets =
- ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
+ (Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
}
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
- tablePtr->downShift -= 2;
+ if (tablePtr->downShift > 1) {
+ tablePtr->downShift -= 2;
+ }
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
@@ -1069,35 +1016,14 @@ RebuildTable(
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
-#if TCL_HASH_KEY_STORE_HASH
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash));
+ index = RANDOM_INDEX(tablePtr, PTR2UINT(hPtr->hash));
} else {
index = PTR2UINT(hPtr->hash) & tablePtr->mask;
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
-#else
- void *key = Tcl_GetHashKey(tablePtr, hPtr);
-
- if (typePtr->hashKeyProc) {
- unsigned int hash;
-
- hash = typePtr->hashKeyProc(tablePtr, key);
- if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
- index = RANDOM_INDEX(tablePtr, hash);
- } else {
- index = hash & tablePtr->mask;
- }
- } else {
- index = RANDOM_INDEX(tablePtr, key);
- }
-
- hPtr->bucketPtr = &tablePtr->buckets[index];
- hPtr->nextPtr = *hPtr->bucketPtr;
- *hPtr->bucketPtr = hPtr;
-#endif
}
}
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index 0782629..f7d9ec8 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -6,8 +6,8 @@
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*
- * Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1990-1993 The Regents of the University of California.
+ * Copyright © 1994-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.
@@ -63,15 +63,14 @@ Tcl_RecordAndEval(
* current procedure. */
{
Tcl_Obj *cmdPtr;
- int length = strlen(cmd);
int result;
- if (length > 0) {
+ if (cmd[0]) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
- cmdPtr = Tcl_NewStringObj(cmd, length);
+ cmdPtr = Tcl_NewStringObj(cmd, -1);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
@@ -132,14 +131,14 @@ Tcl_RecordAndEvalObj(
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
- Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
+ (HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
- histObjsPtr = ckalloc(sizeof(HistoryObjs));
+ histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
@@ -213,9 +212,9 @@ Tcl_RecordAndEvalObj(
static void
DeleteHistoryObjs(
ClientData clientData,
- Tcl_Interp *interp)
+ TCL_UNUSED(Tcl_Interp *))
{
- HistoryObjs *histObjsPtr = clientData;
+ HistoryObjs *histObjsPtr = (HistoryObjs *)clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 0f79f1e..3b36457 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4,8 +4,8 @@
* This file provides the generic portions (those that are the same on
* all platforms and for all channel types) of Tcl's IO facilities.
*
- * Copyright (c) 1998-2000 Ajuba Solutions
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
* Contributions from Don Porter, NIST, 2014. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution of
@@ -28,7 +28,7 @@ typedef struct ChannelHandler {
int mask; /* Mask of desired events. */
Tcl_ChannelProc *proc; /* Procedure to call in the type of
* Tcl_CreateChannelHandler. */
- ClientData clientData; /* Argument to pass to procedure. */
+ void *clientData; /* Argument to pass to procedure. */
struct ChannelHandler *nextPtr;
/* Next one in list of registered handlers. */
} ChannelHandler;
@@ -102,7 +102,7 @@ typedef struct CopyState {
Tcl_WideInt total; /* Total bytes transferred (written). */
Tcl_Interp *interp; /* Interp that started the copy. */
Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
- int bufSize; /* Size of appended buffer. */
+ Tcl_Size bufSize; /* Size of appended buffer. */
char buffer[TCLFLEXARRAY]; /* Copy buffer, this must be the last
* field. */
} CopyState;
@@ -116,7 +116,7 @@ typedef struct CopyState {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
NextChannelHandler *nestedHandlerPtr;
/* This variable holds the list of nested
* Tcl_NotifyChannel invocations. */
@@ -125,12 +125,12 @@ typedef struct ThreadSpecificData {
* ChannelState exists per set of stacked
* channels. */
Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */
- int stdinInitialized;
Tcl_Channel stdoutChannel; /* Static variable for the stdout channel. */
- int stdoutInitialized;
Tcl_Channel stderrChannel; /* Static variable for the stderr channel. */
- int stderrInitialized;
Tcl_Encoding binaryEncoding;
+ int stdinInitialized;
+ int stdoutInitialized;
+ int stderrInitialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -142,7 +142,7 @@ static Tcl_ThreadDataKey dataKey;
typedef struct CloseCallback {
Tcl_CloseProc *proc; /* The procedure to call. */
- ClientData clientData; /* Arbitrary one-word data to pass
+ void *clientData; /* Arbitrary one-word data to pass
* to the callback. */
struct CloseCallback *nextPtr; /* For chaining close callbacks. */
} CloseCallback;
@@ -151,12 +151,12 @@ typedef struct CloseCallback {
* Static functions in this file:
*/
-static ChannelBuffer * AllocChannelBuffer(int length);
+static ChannelBuffer * AllocChannelBuffer(Tcl_Size 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 void ChannelTimerProc(void *clientData);
static int ChanRead(Channel *chanPtr, char *dst, int dstSize);
static int CheckChannelErrors(ChannelState *statePtr,
int direction);
@@ -165,6 +165,7 @@ static int CheckForDeadChannel(Tcl_Interp *interp,
static void CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void CleanupChannelHandlers(Tcl_Interp *interp,
Channel *chanPtr);
+static void CleanupTimerHandler(ChannelState *statePtr);
static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
int errorCode);
static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
@@ -172,18 +173,19 @@ static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void CommonGetsCleanup(Channel *chanPtr);
static int CopyData(CopyState *csPtr, int mask);
+static void DeleteTimerHandler(ChannelState *statePtr);
static int MoveBytes(CopyState *csPtr);
static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj);
static void MBError(CopyState *csPtr, int mask, int errorCode);
static int MBRead(CopyState *csPtr);
static int MBWrite(CopyState *csPtr);
-static void MBEvent(ClientData clientData, int mask);
+static void MBEvent(void *clientData, int mask);
-static void CopyEventProc(ClientData clientData, int mask);
+static void CopyEventProc(void *clientData, int mask);
static void CreateScriptRecord(Tcl_Interp *interp,
Channel *chanPtr, int mask, Tcl_Obj *scriptPtr);
-static void DeleteChannelTable(ClientData clientData,
+static void DeleteChannelTable(void *clientData,
Tcl_Interp *interp);
static void DeleteScriptRecord(Tcl_Interp *interp,
Channel *chanPtr, int mask);
@@ -191,17 +193,17 @@ static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
static void DiscardInputQueued(ChannelState *statePtr,
int discardSavedBuffers);
static void DiscardOutputQueued(ChannelState *chanPtr);
-static int DoRead(Channel *chanPtr, char *dst, int bytesToRead,
+static Tcl_Size DoRead(Channel *chanPtr, char *dst, Tcl_Size bytesToRead,
int allowShortReads);
-static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead,
- int appendFlag);
+static Tcl_Size DoReadChars(Channel *chan, Tcl_Obj *objPtr, Tcl_Size toRead,
+ int allowShortReads, int appendFlag);
static int FilterInputBytes(Channel *chanPtr,
GetsState *statePtr);
static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr,
int calledFromAsyncFlush);
static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr);
static Tcl_Encoding GetBinaryEncoding(void);
-static void FreeBinaryEncoding(ClientData clientData);
+static Tcl_ExitProc FreeBinaryEncoding;
static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp);
static int GetInput(Channel *chanPtr);
static void PeekAhead(Channel *chanPtr, char **dstEndPtr,
@@ -219,8 +221,8 @@ static void StopCopy(CopyState *csPtr);
static void TranslateInputEOL(ChannelState *statePtr, char *dst,
const char *src, int *dstLenPtr, int *srcLenPtr);
static void UpdateInterest(Channel *chanPtr);
-static int Write(Channel *chanPtr, const char *src,
- int srcLen, Tcl_Encoding encoding);
+static Tcl_Size Write(Channel *chanPtr, const char *src,
+ Tcl_Size srcLen, Tcl_Encoding encoding);
static Tcl_Obj * FixLevelCode(Tcl_Obj *msg);
static void SpliceChannel(Tcl_Channel chan);
static void CutChannel(Tcl_Channel chan);
@@ -237,7 +239,7 @@ static int WillRead(Channel *chanPtr);
* short description of what the macro does.
*
* --------------------------------------------------------------------------
- * int BytesLeft(ChannelBuffer *bufPtr)
+ * Tcl_Size BytesLeft(ChannelBuffer *bufPtr)
*
* Returns the number of bytes of data remaining in the buffer.
*
@@ -319,9 +321,9 @@ static int WillRead(Channel *chanPtr);
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
- int epoch; /* The epoch of the channel when the lookup
+ size_t epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
- int refCount; /* Share this struct among many Tcl_Obj. */
+ size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -335,6 +337,22 @@ static const Tcl_ObjType chanObjType = {
NULL /* setFromAnyProc */
};
+#define ChanSetInternalRep(objPtr, resPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (resPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (resPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \
+ } while (0)
+
+#define ChanGetInternalRep(objPtr, resPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &chanObjType); \
+ (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
@@ -358,11 +376,12 @@ ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
+#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) {
return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp);
- } else {
- return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
+#endif
+ return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
/*
@@ -380,9 +399,9 @@ ChanClose(
* calling Tcl_GetErrno().
*
* Side effects:
- * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set
- * as appropriate. On EOF, the inputEncodingFlags are set to perform
- * ending operations on decoding.
+ * The CHANNEL_ENCODING_ERROR, CHANNEL_BLOCKED and CHANNEL_EOF flags
+ * of the channel state are set as appropriate. On EOF, the
+ * inputEncodingFlags are set to perform ending operations on decoding.
*
* TODO - Is this really the right place for that?
*
@@ -429,7 +448,16 @@ ChanRead(
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
- if (bytesRead > 0) {
+ if (bytesRead < 0) {
+ if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
+ SetFlag(chanPtr->state, CHANNEL_BLOCKED);
+ result = EAGAIN;
+ }
+ Tcl_SetErrno(result);
+ } else if (bytesRead == 0) {
+ SetFlag(chanPtr->state, CHANNEL_EOF);
+ chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
+ } else {
/*
* If we get a short read, signal up that we may be BLOCKED. We should
* avoid calling the driver because on some platforms we will block in
@@ -440,15 +468,6 @@ ChanRead(
if (bytesRead < dstSize) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
}
- } else if (bytesRead == 0) {
- SetFlag(chanPtr->state, CHANNEL_EOF);
- chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
- } else if (bytesRead < 0) {
- if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
- SetFlag(chanPtr->state, CHANNEL_BLOCKED);
- result = EAGAIN;
- }
- Tcl_SetErrno(result);
}
return bytesRead;
}
@@ -465,18 +484,23 @@ ChanSeek(
* type and non-NULL.
*/
- if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) {
- return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
- offset, mode, errnoPtr);
- }
+ if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
+#ifndef TCL_NO_DEPRECATED
+ if (offset<LONG_MIN || offset>LONG_MAX) {
+ *errnoPtr = EOVERFLOW;
+ return TCL_INDEX_NONE;
+ }
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
- *errnoPtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
+ offset, mode, errnoPtr);
+#else
+ *errnoPtr = EINVAL;
+ return TCL_INDEX_NONE;
+#endif
}
- return Tcl_LongAsWide(Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
- Tcl_WideAsLong(offset), mode, errnoPtr));
+ return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
+ offset, mode, errnoPtr);
}
static inline void
@@ -825,7 +849,7 @@ Tcl_CreateCloseHandler(
* callback. */
Tcl_CloseProc *proc, /* The callback routine to call when the
* channel will be closed. */
- ClientData clientData) /* Arbitrary data to pass to the close
+ void *clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
@@ -863,7 +887,7 @@ Tcl_DeleteCloseHandler(
* callback. */
Tcl_CloseProc *proc, /* The procedure for the callback to
* remove. */
- ClientData clientData) /* The callback data for the callback to
+ void *clientData) /* The callback data for the callback to
* remove. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
@@ -962,7 +986,7 @@ GetChannelTable(
static void
DeleteChannelTable(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
Tcl_HashTable *hTblPtr; /* The hash table. */
@@ -1492,23 +1516,22 @@ TclGetChannelFromObj(
* channel was opened? Will contain an OR'ed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
- (void)flags;
if (interp == NULL) {
return TCL_ERROR;
}
- if (objPtr->typePtr == &chanObjType) {
+ ChanGetInternalRep(objPtr, resPtr);
+ if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
- resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1;
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
@@ -1525,26 +1548,25 @@ TclGetChannelFromObj(
if (chan == NULL) {
if (resPtr) {
- FreeChannelInternalRep(objPtr);
+ Tcl_StoreInternalRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
- /* Re-use the ResolvedCmdName struct */
- Tcl_Release((ClientData) resPtr->statePtr);
+ /*
+ * Re-use the ResolvedCmdName struct.
+ */
+ Tcl_Release((void *) resPtr->statePtr);
} else {
- TclFreeIntRep(objPtr);
-
resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr;
- objPtr->typePtr = &chanObjType;
+ resPtr->refCount = 0;
+ ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
- Tcl_Preserve((ClientData) statePtr);
+ Tcl_Preserve((void *) statePtr);
resPtr->interp = interp;
resPtr->epoch = statePtr->epoch;
@@ -1578,7 +1600,7 @@ Tcl_Channel
Tcl_CreateChannel(
const Tcl_ChannelType *typePtr, /* The channel type record. */
const char *chanName, /* Name of channel to record. */
- ClientData instanceData, /* Instance specific data. */
+ void *instanceData, /* Instance specific data. */
int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
{
@@ -1601,9 +1623,18 @@ Tcl_CreateChannel(
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
+#ifndef TCL_NO_DEPRECATED
if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) {
Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName);
}
+#else
+ if (Tcl_ChannelVersion(typePtr) < TCL_CHANNEL_VERSION_5) {
+ Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName);
+ }
+ if (typePtr->close2Proc == NULL) {
+ Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName);
+ }
+#endif
if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) {
Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName);
}
@@ -1613,9 +1644,11 @@ Tcl_CreateChannel(
if (NULL == typePtr->watchProc) {
Tcl_Panic("channel type %s must define watchProc", typePtr->typeName);
}
- if ((NULL!=typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
+#ifndef TCL_NO_DEPRECATED
+ if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName);
}
+#endif
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
@@ -1650,6 +1683,7 @@ Tcl_CreateChannel(
}
statePtr->channelName = tmp;
statePtr->flags = mask;
+ statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
@@ -1668,8 +1702,12 @@ Tcl_CreateChannel(
}
statePtr->inputEncodingState = NULL;
statePtr->inputEncodingFlags = TCL_ENCODING_START;
+ ENCODING_PROFILE_SET(statePtr->inputEncodingFlags,
+ TCL_ENCODING_PROFILE_TCL8);
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
+ ENCODING_PROFILE_SET(statePtr->outputEncodingFlags,
+ TCL_ENCODING_PROFILE_TCL8);
/*
* Set the channel up initially in AUTO input translation mode to accept
@@ -1800,7 +1838,7 @@ Tcl_StackChannel(
const Tcl_ChannelType *typePtr,
/* The channel type record for the new
* channel. */
- ClientData instanceData, /* Instance specific data for the new
+ void *instanceData, /* Instance specific data for the new
* channel. */
int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
@@ -2136,8 +2174,11 @@ Tcl_UnstackChannel(
/*
* Close and free the channel driver state.
+ * TIP #220: This is done with maximum privileges (as created).
*/
+ ResetFlag(statePtr, TCL_READABLE|TCL_WRITABLE);
+ SetFlag(statePtr, statePtr->maxPerms);
result = ChanClose(chanPtr, interp);
ChannelFree(chanPtr);
@@ -2256,7 +2297,7 @@ Tcl_GetTopChannel(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetChannelInstanceData(
Tcl_Channel chan) /* Channel for which to return client data. */
{
@@ -2395,10 +2436,10 @@ int
Tcl_GetChannelHandle(
Tcl_Channel chan, /* The channel to get file from. */
int direction, /* TCL_WRITABLE or TCL_READABLE. */
- ClientData *handlePtr) /* Where to store handle */
+ void **handlePtr) /* Where to store handle */
{
Channel *chanPtr; /* The actual channel. */
- ClientData handle;
+ void *handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
@@ -2417,6 +2458,54 @@ Tcl_GetChannelHandle(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RemoveChannelMode --
+ *
+ * Remove either read or write privileges from the channel.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May change the access mode of the channel.
+ * May leave an error message in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RemoveChannelMode(
+ Tcl_Interp* interp, /* The interp for an error message. Allowed to be NULL. */
+ Tcl_Channel chan, /* The channel which is modified. */
+ int mode) /* The access mode to drop from the channel */
+{
+ const char* emsg;
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of actual channel. */
+
+ if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
+ emsg = "Illegal mode value.";
+ goto error;
+ }
+ if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) {
+ emsg = "Bad mode, would make channel inacessible";
+ goto error;
+ }
+
+ ResetFlag(statePtr, mode);
+ return TCL_OK;
+
+ error:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Tcl_RemoveChannelMode error: %s. Channel: \"%s\"",
+ emsg, Tcl_GetChannelName((Tcl_Channel) chan)));
+ }
+ return TCL_ERROR;
+}
+
+/*
*---------------------------------------------------------------------------
*
* AllocChannelBuffer --
@@ -2442,10 +2531,10 @@ Tcl_GetChannelHandle(
static ChannelBuffer *
AllocChannelBuffer(
- int length) /* Desired length of channel buffer. */
+ Tcl_Size length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
- int n;
+ Tcl_Size n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *)ckalloc(n);
@@ -2461,7 +2550,7 @@ static void
PreserveChannelBuffer(
ChannelBuffer *bufPtr)
{
- if (bufPtr->refCount == 0) {
+ if (!bufPtr->refCount) {
Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
}
bufPtr->refCount++;
@@ -2681,6 +2770,7 @@ FlushChannel(
int wroteSome = 0; /* Set to one if any data was written to the
* driver. */
+ int bufExists;
/*
* Prevent writing on a dead channel -- a channel that has been closed but
* not yet deallocated. This can occur if the exit handler for the channel
@@ -2861,20 +2951,32 @@ FlushChannel(
wroteSome = 1;
}
- bufPtr->nextRemoved += written;
+ bufExists = bufPtr->refCount > 1;
+ ReleaseChannelBuffer(bufPtr);
+ if (bufExists) {
+ /* There is still a reference to this buffer other than the one
+ * this routine just released, meaning that final cleanup of the
+ * buffer hasn't been ordered by, e.g. by a reflected channel
+ * closing the channel from within one of its handler scripts (not
+ * something one would expecte, but it must be considered). Normal
+ * operations on the buffer can proceed.
+ */
- /*
- * If this buffer is now empty, recycle it.
- */
+ bufPtr->nextRemoved += written;
- if (IsBufferEmpty(bufPtr)) {
- statePtr->outQueueHead = bufPtr->nextPtr;
- if (statePtr->outQueueHead == NULL) {
- statePtr->outQueueTail = NULL;
+ /*
+ * If this buffer is now empty, recycle it.
+ */
+
+ if (IsBufferEmpty(bufPtr)) {
+ statePtr->outQueueHead = bufPtr->nextPtr;
+ if (statePtr->outQueueHead == NULL) {
+ statePtr->outQueueTail = NULL;
+ }
+ RecycleBuffer(statePtr, bufPtr, 0);
}
- RecycleBuffer(statePtr, bufPtr, 0);
}
- ReleaseChannelBuffer(bufPtr);
+
} /* Closes "while". */
/*
@@ -3092,13 +3194,7 @@ CloseChannel(
/*
* Cancel any outstanding timer.
*/
-
- if (statePtr->timer != NULL) {
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = NULL;
- TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
- statePtr->timerChanPtr = NULL;
- }
+ DeleteTimerHandler(statePtr);
/*
@@ -3363,7 +3459,8 @@ int
Tcl_Close(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan) /* The channel being closed. Must not be
- * referenced in any interpreter. */
+ * referenced in any interpreter. May be NULL,
+ * in which case this is a no-op. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
@@ -3448,6 +3545,11 @@ Tcl_Close(
Tcl_ClearChannelHandlers(chan);
/*
+ * Cancel any outstanding timer.
+ */
+ DeleteTimerHandler(statePtr);
+
+ /*
* Invoke the registered close callbacks and delete their records.
*/
@@ -3465,6 +3567,7 @@ Tcl_Close(
* it anymore and this will help avoid deadlocks on some channel types.
*/
+#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) {
/* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
@@ -3472,6 +3575,12 @@ Tcl_Close(
result = 0;
}
}
+#else
+ result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
+ if ((result == EINVAL) || result == ENOTCONN) {
+ result = 0;
+ }
+#endif
/*
* The call to FlushChannel will flush any queued output and invoke the
@@ -3519,7 +3628,7 @@ Tcl_Close(
result = flushcode;
}
if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
- && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
+ && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) {
Tcl_SetErrno(result);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
@@ -3535,19 +3644,17 @@ Tcl_Close(
*
* Tcl_CloseEx --
*
- * Closes one side of a channel, read or write.
+ * Closes one side of a channel, read or write, close all.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Closes one direction of the channel.
+ * Closes one direction of the channel, or do a full close.
*
* NOTE:
* Tcl_CloseEx closes the specified direction of the channel as far as
- * the user is concerned. The channel keeps existing however. You cannot
- * call this function to close the last possible direction of the
- * channel. Use Tcl_Close for that.
+ * the user is concerned. If flags = 0, this is equivalent to Tcl_Close.
*
*----------------------------------------------------------------------
*/
@@ -3915,13 +4022,7 @@ Tcl_ClearChannelHandlers(
/*
* Cancel any outstanding timer.
*/
-
- if (statePtr->timer != NULL) {
- Tcl_DeleteTimerHandler(statePtr->timer);
- statePtr->timer = NULL;
- TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
- statePtr->timerChanPtr = NULL;
- }
+ DeleteTimerHandler(statePtr);
/*
* Remove any references to channel handlers for this channel that may be
@@ -3988,8 +4089,8 @@ Tcl_ClearChannelHandlers(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -3998,11 +4099,11 @@ Tcl_ClearChannelHandlers(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_Write(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
- int srcLen) /* Length of data in bytes, or < 0 for
+ Tcl_Size srcLen) /* Length of data in bytes, or < 0 for
* strlen(). */
{
/*
@@ -4016,14 +4117,14 @@ Tcl_Write(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
if (WriteBytes(chanPtr, src, srcLen) < 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
return srcLen;
}
@@ -4042,8 +4143,8 @@ Tcl_Write(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4052,21 +4153,21 @@ Tcl_Write(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_WriteRaw(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
- int srcLen) /* Length of data in bytes, or < 0 for
+ Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for
* strlen(). */
{
Channel *chanPtr = ((Channel *) chan);
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
int errorCode;
- int written;
+ Tcl_Size written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (srcLen < 0) {
@@ -4099,8 +4200,8 @@ Tcl_WriteRaw(
* specified channel to the topmost channel in a stack.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4109,21 +4210,21 @@ Tcl_WriteRaw(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_WriteChars(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* UTF-8 characters to queue in output
* buffer. */
- int len) /* Length of string in bytes, or < 0 for
+ Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for
* strlen(). */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* State info for channel */
- int result;
+ Tcl_Size result;
Tcl_Obj *objPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
chanPtr = statePtr->topChanPtr;
@@ -4168,8 +4269,8 @@ Tcl_WriteChars(
* line buffering mode.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
- * Tcl_GetErrno() will return the error code.
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If
+ * TCL_INDEX_NONE, Tcl_GetErrno() will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
@@ -4178,7 +4279,7 @@ Tcl_WriteChars(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_WriteObj(
Tcl_Channel chan, /* The channel to buffer output for. */
Tcl_Obj *objPtr) /* The object to write. */
@@ -4190,13 +4291,13 @@ Tcl_WriteObj(
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
const char *src;
- int srcLen;
+ Tcl_Size srcLen;
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
if (statePtr->encoding == NULL) {
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
@@ -4213,8 +4314,11 @@ WillWrite(
{
int inputBuffered;
- if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) &&
- ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
+ if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
+#ifndef TCL_NO_DEPRECATED
+ || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
+#endif
+ ) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
int ignore;
DiscardInputQueued(chanPtr->state, 0);
@@ -4235,9 +4339,11 @@ WillRead(
Tcl_SetErrno(EINVAL);
return -1;
}
- if ((Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
- && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
-
+ if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
+#ifndef TCL_NO_DEPRECATED
+ || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
+#endif
+ ) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
/*
* CAVEAT - The assumption here is that FlushChannel() will push out
* the bytes of any writes that are in progress. Since this is a
@@ -4266,7 +4372,7 @@ WillRead(
* ready e.g. if it contains a newline and we are in line buffering mode.
*
* Results:
- * The number of bytes written or -1 in case of error. If -1,
+ * The number of bytes written or TCL_INDEX_NONE in case of error. If TCL_INDEX_NONE,
* Tcl_GetErrno will return the error code.
*
* Side effects:
@@ -4276,11 +4382,11 @@ WillRead(
*----------------------------------------------------------------------
*/
-static int
+static Tcl_Size
Write(
Channel *chanPtr, /* The channel to buffer output for. */
const char *src, /* UTF-8 string to write. */
- int srcLen, /* Length of UTF-8 string in bytes. */
+ Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */
Tcl_Encoding encoding)
{
ChannelState *statePtr = chanPtr->state;
@@ -4309,7 +4415,7 @@ Write(
ChannelBuffer *bufPtr;
char *dst;
int result, srcRead, dstLen, dstWrote;
- int srcLimit = srcLen;
+ Tcl_Size srcLimit = srcLen;
if (nextNewLine) {
srcLimit = nextNewLine - src;
@@ -4331,7 +4437,6 @@ Write(
bufPtr->nextAdded += saved;
saved = 0;
}
- PreserveChannelBuffer(bufPtr);
dst = InsertPoint(bufPtr);
dstLen = SpaceLeft(bufPtr);
@@ -4346,7 +4451,24 @@ Write(
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 || result == TCL_CONVERT_SYNTAX) {
+ 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;
}
@@ -4417,7 +4539,6 @@ Write(
if (IsBufferFull(bufPtr)) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
- ReleaseChannelBuffer(bufPtr);
return -1;
}
flushed += statePtr->bufSize;
@@ -4437,7 +4558,6 @@ Write(
needNlFlush = 0;
}
}
- ReleaseChannelBuffer(bufPtr);
}
if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
(needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
@@ -4446,8 +4566,10 @@ Write(
}
}
+ UpdateInterest(chanPtr);
+
if (encodingError) {
- Tcl_SetErrno(EINVAL);
+ Tcl_SetErrno(EILSEQ);
return -1;
}
return total;
@@ -4461,8 +4583,8 @@ Write(
* Reads a complete line of input from the channel into a Tcl_DString.
*
* Results:
- * Length of line read (in characters) or -1 if error, EOF, or blocked.
- * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
+ * Length of line read (in characters) or TCL_INDEX_NONE if error, EOF, or blocked.
+ * If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error code for the
* error or condition that occurred.
*
* Side effects:
@@ -4472,7 +4594,7 @@ Write(
*---------------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_Gets(
Tcl_Channel chan, /* Channel from which to read. */
Tcl_DString *lineRead) /* The line read will be appended to this
@@ -4481,7 +4603,7 @@ Tcl_Gets(
* for managing the storage. */
{
Tcl_Obj *objPtr;
- int charsStored;
+ Tcl_Size charsStored;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
@@ -4502,8 +4624,8 @@ Tcl_Gets(
* converted to UTF-8 using the encoding specified by the channel.
*
* Results:
- * Number of characters accumulated in the object or -1 if error,
- * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error
+ * Number of characters accumulated in the object or TCL_INDEX_NONE if error,
+ * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error
* code for the error or condition that occurred.
*
* Side effects:
@@ -4515,7 +4637,7 @@ Tcl_Gets(
*---------------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_GetsObj(
Tcl_Channel chan, /* Channel from which to read. */
Tcl_Obj *objPtr) /* The line read will be appended to this
@@ -4527,13 +4649,20 @@ Tcl_GetsObj(
/* State info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
- int oldLength;
+ Tcl_Size oldLength;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ UpdateInterest(chanPtr);
+ ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
+ Tcl_SetErrno(EILSEQ);
+ return TCL_INDEX_NONE;
+ }
+
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4548,7 +4677,7 @@ Tcl_GetsObj(
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -4620,6 +4749,12 @@ Tcl_GetsObj(
ResetFlag(statePtr, CHANNEL_BLOCKED);
while (1) {
if (dst >= dstEnd) {
+ /*
+ * In case of encoding errors, state gets flag
+ * CHANNEL_ENCODING_ERROR set in the call below. First, the
+ * EOF/EOL condition is checked, as we may have valid data with
+ * EOF/EOL before the encoding error.
+ */
if (FilterInputBytes(chanPtr, &gs) != 0) {
goto restore;
}
@@ -4675,7 +4810,7 @@ Tcl_GetsObj(
*/
if (eol >= dstEnd) {
- int offset;
+ Tcl_Size offset;
if (eol != eof) {
offset = eol - objPtr->bytes;
@@ -4788,6 +4923,28 @@ Tcl_GetsObj(
goto done;
}
goto gotEOL;
+ } else if (gs.bytesWrote == 0
+ && GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ /* Ticket c4eb46a1 Harald Oehlmann 2023-11-12 debugging session.
+ * In non blocking mode we loop indifenitly on a decoding error in
+ * this while-loop.
+ * Removed the following from the upper condition:
+ * "&& !GotFlag(statePtr, CHANNEL_NONBLOCKING)"
+ * In case of an encoding error with leading correct bytes, we pass here
+ * two times, as gs.bytesWrote is not 0 on the first pass. This feels
+ * once to much, as the data is anyway not used.
+ */
+
+ /* Set eol to the position that caused the encoding error, and then
+ * continue to gotEOL, which stores the data that was decoded
+ * without error to objPtr. This allows the caller to do something
+ * useful with the data decoded so far, and also results in the
+ * position of the file being the first byte that was not
+ * successfully decoded, allowing further processing at exactly that
+ * point, if desired.
+ */
+ eol = dstEnd;
+ goto gotEOL;
}
dst = dstEnd;
}
@@ -4887,6 +5044,7 @@ Tcl_GetsObj(
done:
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
@@ -4903,6 +5061,12 @@ Tcl_GetsObj(
}
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && gs.bytesWrote == 0) {
+ bufPtr->nextRemoved = oldRemoved;
+ Tcl_SetErrno(EILSEQ);
+ copiedTotal = -1;
+ }
+ ResetFlag(statePtr, CHANNEL_ENCODING_ERROR);
return copiedTotal;
}
@@ -4920,8 +5084,8 @@ Tcl_GetsObj(
* may be called when an -eofchar is set on the channel.
*
* Results:
- * Number of characters accumulated in the object or -1 if error,
- * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error
+ * Number of characters accumulated in the object or TCL_INDEX_NONE if error,
+ * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error
* code for the error or condition that occurred.
*
* Side effects:
@@ -4943,8 +5107,9 @@ TclGetsObjBinary(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
- int rawLen, byteLen, eolChar;
+ int inEofChar, skip, copiedTotal, oldFlags, oldRemoved;
+ Tcl_Size rawLen, byteLen, oldLength;
+ int eolChar;
unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;
/*
@@ -5068,7 +5233,7 @@ TclGetsObjBinary(
if ((dst == dstEnd) && (byteLen == oldLength)) {
/*
* If we didn't append any bytes before encountering EOF,
- * caller needs to see -1.
+ * caller needs to see TCL_INDEX_NONE.
*/
byteArray = Tcl_SetByteArrayLength(objPtr, oldLength);
@@ -5196,10 +5361,9 @@ TclGetsObjBinary(
static void
FreeBinaryEncoding(
- ClientData dummy) /* Not used */
+ TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
@@ -5358,6 +5522,13 @@ FilterInputBytes(
&statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead,
&gsPtr->bytesWrote, &gsPtr->charsWrote);
+ if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) {
+ SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
+ ResetFlag(statePtr, CHANNEL_STICKY_EOF);
+ ResetFlag(statePtr, CHANNEL_EOF);
+ result = TCL_OK;
+ }
+
/*
* Make sure that if we go through 'gets', that we reset the
* TCL_ENCODING_START flag still. [Bug #523988]
@@ -5577,7 +5748,7 @@ CommonGetsCleanup(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5586,11 +5757,11 @@ CommonGetsCleanup(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_Read(
Tcl_Channel chan, /* The channel from which to read. */
char *dst, /* Where to store input read. */
- int bytesToRead) /* Maximum number of bytes to read. */
+ Tcl_Size bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
@@ -5603,7 +5774,7 @@ Tcl_Read(
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
return DoRead(chanPtr, dst, bytesToRead, 0);
@@ -5622,7 +5793,7 @@ Tcl_Read(
* No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5631,11 +5802,11 @@ Tcl_Read(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ReadRaw(
Tcl_Channel chan, /* The channel from which to read. */
char *readBuf, /* Where to store input read. */
- int bytesToRead) /* Maximum number of bytes to read. */
+ Tcl_Size bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
@@ -5644,7 +5815,7 @@ Tcl_ReadRaw(
assert(bytesToRead > 0);
if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
- return -1;
+ return TCL_INDEX_NONE;
}
/*
@@ -5698,13 +5869,7 @@ Tcl_ReadRaw(
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
- if (nread > 0) {
- /*
- * Successful read (short is OK) - add to bytes copied.
- */
-
- copied += nread;
- } else if (nread < 0) {
+ if (nread < 0) {
/*
* An error signaled. If CHANNEL_BLOCKED, then the error is not
* real, but an indication of blocked state. In that case, retain
@@ -5718,6 +5883,12 @@ Tcl_ReadRaw(
if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
copied = -1;
}
+ } else if (nread > 0) {
+ /*
+ * Successful read (short is OK) - add to bytes copied.
+ */
+
+ copied += nread;
} else {
/*
* nread == 0. Driver is at EOF. Let that state filter up.
@@ -5740,7 +5911,7 @@ Tcl_ReadRaw(
* object.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5749,12 +5920,12 @@ Tcl_ReadRaw(
*---------------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ReadChars(
Tcl_Channel chan, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
- int toRead, /* Maximum number of characters to store, or
- * -1 to read all available data (up to EOF or
+ Tcl_Size toRead, /* Maximum number of characters to store, or
+ * TCL_INDEX_NONE to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
@@ -5778,10 +5949,10 @@ Tcl_ReadChars(
*/
UpdateInterest(chanPtr);
- return -1;
+ return TCL_INDEX_NONE;
}
- return DoReadChars(chanPtr, objPtr, toRead, appendFlag);
+ return DoReadChars(chanPtr, objPtr, toRead, 0, appendFlag);
}
/*
*---------------------------------------------------------------------------
@@ -5796,7 +5967,7 @@ Tcl_ReadChars(
* object.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno() to
+ * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to
* retrieve the error code for the error that occurred.
*
* Side effects:
@@ -5805,13 +5976,14 @@ Tcl_ReadChars(
*---------------------------------------------------------------------------
*/
-static int
+static Tcl_Size
DoReadChars(
Channel *chanPtr, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
- int toRead, /* Maximum number of characters to store, or
- * -1 to read all available data (up to EOF or
+ Tcl_Size toRead, /* Maximum number of characters to store, or
+ * TCL_INDEX_NONE to read all available data (up to EOF or
* when channel blocks). */
+ int allowShortReads, /* Allow half-blocking (pipes,sockets) */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
@@ -5820,35 +5992,20 @@ DoReadChars(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
- int copied;
+ Tcl_Size copied;
int result;
Tcl_Encoding encoding = statePtr->encoding;
int binaryMode;
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
- binaryMode = (encoding == NULL)
- && (statePtr->inputTranslation == TCL_TRANSLATE_LF)
- && (statePtr->inEofChar == '\0');
-
- if (appendFlag == 0) {
- if (binaryMode) {
- Tcl_SetByteArrayLength(objPtr, 0);
- } else {
- Tcl_SetObjLength(objPtr, 0);
-
- /*
- * We're going to access objPtr->bytes directly, so we must ensure
- * that this is actually a string object (otherwise it might have
- * been pure Unicode).
- *
- * Probably not needed anymore.
- */
-
- TclGetString(objPtr);
- }
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
+ /* TODO: UpdateInterest not needed here? */
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return -1;
}
-
/*
* Early out when next read will see eofchar.
*
@@ -5887,6 +6044,32 @@ DoReadChars(
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
+ binaryMode = (encoding == NULL)
+ && (statePtr->inputTranslation == TCL_TRANSLATE_LF)
+ && (statePtr->inEofChar == '\0');
+
+ if (appendFlag) {
+ if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) {
+ binaryMode = 0;
+ }
+ } else {
+ if (binaryMode) {
+ Tcl_SetByteArrayLength(objPtr, 0);
+ } else {
+ Tcl_SetObjLength(objPtr, 0);
+
+ /*
+ * We're going to access objPtr->bytes directly, so we must ensure
+ * that this is actually a string object (otherwise it might have
+ * been pure Unicode).
+ *
+ * Probably not needed anymore.
+ */
+
+ TclGetString(objPtr);
+ }
+ }
+
/*
* Must clear the BLOCKED|EOF flags here since we check before reading.
*/
@@ -5896,7 +6079,7 @@ DoReadChars(
}
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
- for (copied = 0; (unsigned) toRead > 0; ) {
+ for (copied = 0; toRead != 0 ; ) {
int copiedNow = -1;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
@@ -5919,14 +6102,27 @@ DoReadChars(
statePtr->inQueueTail = NULL;
}
}
+
+ /*
+ * If CHANNEL_ENCODING_ERROR and CHANNEL_STICKY_EOF are both set,
+ * then CHANNEL_ENCODING_ERROR was caused by data that occurred
+ * after the EOF character was encountered, so it doesn't count as
+ * a real error.
+ */
+
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
+ && !GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ && (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
+ goto finish;
+ }
}
if (copiedNow < 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
}
- if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)
- == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) {
+ if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads)
+ && GotFlag(statePtr, CHANNEL_BLOCKED)) {
break;
}
result = GetInput(chanPtr);
@@ -5947,6 +6143,7 @@ DoReadChars(
}
}
+finish:
/*
* Failure to fill a channel buffer may have left channel reporting a
* "blocked" state, but so long as we fulfilled the request here, the
@@ -5975,10 +6172,23 @@ DoReadChars(
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
+
+ /* This must comes after UpdateInterest(), which may set errno */
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
+ && (!copied || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
+ /* Channel either is blocking or is nonblocking with no data
+ * succesfully red before the error. Return an error so that callers
+ * like [read] can also return an error.
+ */
+ ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
+ Tcl_SetErrno(EILSEQ);
+ copied = -1;
+ }
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
}
@@ -5998,7 +6208,7 @@ DoReadChars(
*
* Results:
* The return value is the number of bytes appended to the object, or
- * -1 to indicate that zero bytes were read due to an EOF.
+ * TCL_INDEX_NONE to indicate that zero bytes were read due to an EOF.
*
* Side effects:
* The storage of bytes in objPtr can cause (re-)allocation of memory.
@@ -6014,7 +6224,7 @@ ReadBytes(
* been allocated to hold data, not how many
* bytes of data have been stored in the
* object. */
- int bytesToRead) /* Maximum number of bytes to store, or < 0 to
+ int bytesToRead) /* Maximum number of bytes to store, or -1 to
* get all available bytes. Bytes are obtained
* from the first buffer in the queue - even
* if this number is larger than the number of
@@ -6067,7 +6277,7 @@ ReadChars(
* allocated to hold data, not how many bytes
* of data have been stored in the object. */
int charsToRead, /* Maximum number of characters to store, or
- * -1 to get all available characters.
+ * TCL_INDEX_NONE to get all available characters.
* Characters are obtained from the first
* buffer in the queue -- even if this number
* is larger than the number of characters
@@ -6091,7 +6301,8 @@ ReadChars(
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
- int numBytes, srcLen = BytesLeft(bufPtr);
+ Tcl_Size numBytes;
+ int srcLen = BytesLeft(bufPtr);
/*
* One src byte can yield at most one character. So when the number of
@@ -6167,6 +6378,16 @@ ReadChars(
flags, &statePtr->inputEncodingState,
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
+ if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX
+ || (
+ code == TCL_CONVERT_MULTIBYTE
+ && GotFlag(statePtr, CHANNEL_EOF
+ ))
+ ) {
+ SetFlag(statePtr, CHANNEL_ENCODING_ERROR);
+ code = TCL_OK;
+ }
+
/*
* Perform the translation transformation in place. Read no more than
* the dstDecoded bytes the encoding transformation actually produced.
@@ -6194,12 +6415,12 @@ ReadChars(
* the stopping, but the value of dstRead does not include it.
*
* Also rather bizarre, our caller can only notice an EOF
- * condition if we return the value -1 as the number of chars
+ * condition if we return the value TCL_INDEX_NONE as the number of chars
* read. This forces us to perform a 2-call dance where the
* first call can read all the chars up to the eof char, and
* the second call is solely for consuming the encoded eof
* char then pointed at by src so that we can return that
- * magic -1 value. This seems really wasteful, especially
+ * magic TCL_INDEX_NONE value. This seems really wasteful, especially
* since the first decoding pass of each call is likely to
* decode many bytes beyond that eof char that's all we care
* about.
@@ -6342,7 +6563,7 @@ ReadChars(
* bytes demanded by the Tcl_ExternalToUtf() call!
*/
- dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1);
+ dstLimit = TclUtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1);
statePtr->flags = savedFlags;
statePtr->inputEncodingFlags = savedIEFlags;
statePtr->inputEncodingState = savedState;
@@ -6603,11 +6824,14 @@ TranslateInputEOL(
* EOF character was seen in EOL translated range. Leave current file
* position pointing at the EOF character, but don't store the EOF
* character in the output string.
+ *
+ * If CHANNEL_ENCODING_ERROR is set, it can only be because of data
+ * encountered after the EOF character, so it is nonsense. Unset it.
*/
SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF);
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
- ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR);
+ ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR|CHANNEL_ENCODING_ERROR);
}
}
@@ -6620,7 +6844,7 @@ TranslateInputEOL(
* channel, at either the head or tail of the queue.
*
* Results:
- * The number of bytes stored in the channel, or -1 on error.
+ * The number of bytes stored in the channel, or TCL_INDEX_NONE on error.
*
* Side effects:
* Adds input to the input queue of a channel.
@@ -6628,11 +6852,11 @@ TranslateInputEOL(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_Ungets(
Tcl_Channel chan, /* The channel for which to add the input. */
const char *str, /* The input itself. */
- int len, /* The length of the input. */
+ Tcl_Size len, /* The length of the input. */
int atEnd) /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
{
@@ -6656,7 +6880,7 @@ Tcl_Ungets(
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- len = -1;
+ len = TCL_INDEX_NONE;
goto done;
}
statePtr->flags = flags;
@@ -6841,24 +7065,21 @@ GetInput(
}
/*
- * WARNING: There was once a comment here claiming that it was
- * a bad idea to make another call to the inputproc of a channel
- * driver when EOF has already been detected on the channel. Through
- * much of Tcl's history, this warning was then completely negated
- * by having all (most?) read paths clear the EOF setting before
- * reaching here. So we had a guard that was never triggered.
+ * WARNING: There was once a comment here claiming that it was a bad idea
+ * to make another call to the inputproc of a channel driver when EOF has
+ * already been detected on the channel. Through much of Tcl's history,
+ * this warning was then completely negated by having all (most?) read
+ * paths clear the EOF setting before reaching here. So we had a guard
+ * that was never triggered.
+ *
+ * Don't be tempted to restore the guard. Even if EOF is set on the
+ * channel, continue through and call the inputproc again. This is the
+ * way to enable the ability to [read] again beyond the EOF, which seems a
+ * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683]
+ * and which may even be essential for channels representing things like
+ * ttys or other devices where the stream might take the logical form of a
+ * series of 'files' separated by an EOF condition.
*
- * Don't be tempted to restore the guard. Even if EOF is set on
- * the channel, continue through and call the inputproc again. This
- * is the way to enable the ability to [read] again beyond the EOF,
- * which seems a strange thing to do, but for which use cases exist
- * [Tcl Bug 5adc350683] and which may even be essential for channels
- * representing things like ttys or other devices where the stream
- * might take the logical form of a series of 'files' separated by
- * an EOF condition.
- */
-
- /*
* First check for more buffers in the pushback area of the topmost
* channel in the stack and use them. They can be the result of a
* transformation which went away without reading all the information
@@ -6927,15 +7148,17 @@ GetInput(
PreserveChannelBuffer(bufPtr);
nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead);
+ ReleaseChannelBuffer(bufPtr);
if (nread < 0) {
result = Tcl_GetErrno();
} else {
result = 0;
- bufPtr->nextAdded += nread;
+ if (statePtr->inQueueTail != NULL) {
+ statePtr->inQueueTail->nextAdded += nread;
+ }
}
- ReleaseChannelBuffer(bufPtr);
return result;
}
@@ -6957,10 +7180,10 @@ GetInput(
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
Tcl_Seek(
Tcl_Channel chan, /* The channel on which to seek. */
- Tcl_WideInt offset, /* Offset to seek to. */
+ long long offset, /* Offset to seek to. */
int mode) /* Relative to which location to seek? */
{
Channel *chanPtr = (Channel *) chan;
@@ -6970,7 +7193,7 @@ Tcl_Seek(
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of device driver operations. */
- Tcl_WideInt curPos; /* Position on the device. */
+ long long curPos; /* Position on the device. */
int wasAsync; /* Was the channel nonblocking before the seek
* operation? If so, must restore to
* non-blocking mode after the seek. */
@@ -7001,7 +7224,11 @@ Tcl_Seek(
* defined. This means that the channel does not support seeking.
*/
- if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) {
+ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
+#ifndef TCL_NO_DEPRECATED
+ && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
+#endif
+ ) {
Tcl_SetErrno(EINVAL);
return -1;
}
@@ -7126,7 +7353,7 @@ Tcl_Seek(
*----------------------------------------------------------------------
*/
-Tcl_WideInt
+long long
Tcl_Tell(
Tcl_Channel chan) /* The channel to return pos for. */
{
@@ -7137,7 +7364,7 @@ Tcl_Tell(
int inputBuffered, outputBuffered;
/* # bytes held in buffers. */
int result; /* Of calling device driver. */
- Tcl_WideInt curPos; /* Position on device. */
+ long long curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
return -1;
@@ -7165,7 +7392,11 @@ Tcl_Tell(
* defined. This means that the channel does not support seeking.
*/
- if (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) {
+ if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
+#ifndef TCL_NO_DEPRECATED
+ && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
+#endif
+ ) {
Tcl_SetErrno(EINVAL);
return -1;
}
@@ -7199,47 +7430,6 @@ Tcl_Tell(
/*
*---------------------------------------------------------------------------
*
- * Tcl_SeekOld, Tcl_TellOld --
- *
- * Backward-compatibility versions of the seek/tell interface that do not
- * support 64-bit offsets. This interface is not documented or expected
- * to be supported indefinitely.
- *
- * Results:
- * As for Tcl_Seek and Tcl_Tell respectively, except truncated to
- * whatever value will fit in an 'int'.
- *
- * Side effects:
- * As for Tcl_Seek and Tcl_Tell respectively.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-Tcl_SeekOld(
- Tcl_Channel chan, /* The channel on which to seek. */
- int offset, /* Offset to seek to. */
- int mode) /* Relative to which location to seek? */
-{
- Tcl_WideInt wOffset, wResult;
-
- wOffset = Tcl_LongAsWide((long) offset);
- wResult = Tcl_Seek(chan, wOffset, mode);
- return (int) Tcl_WideAsLong(wResult);
-}
-
-int
-Tcl_TellOld(
- Tcl_Channel chan) /* The channel to return pos for. */
-{
- Tcl_WideInt wResult = Tcl_Tell(chan);
-
- return (int) Tcl_WideAsLong(wResult);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* Tcl_TruncateChannel --
*
* Truncate a channel to the given length.
@@ -7258,7 +7448,7 @@ Tcl_TellOld(
int
Tcl_TruncateChannel(
Tcl_Channel chan, /* Channel to truncate. */
- Tcl_WideInt length) /* Length to truncate it to. */
+ long long length) /* Length to truncate it to. */
{
Channel *chanPtr = (Channel *) chan;
Tcl_DriverTruncateProc *truncateProc =
@@ -7420,9 +7610,39 @@ Tcl_Eof(
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ return 0;
+ }
return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChannelGetBlockingMode --
+ *
+ * Returns 1 if the channel is in blocking mode (default), 0 otherwise.
+ *
+ * Results:
+ * 1 or 0, always.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChannelGetBlockingMode(
+ Tcl_Channel chan)
+{
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of real channel structure. */
+
+ return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -7590,7 +7810,7 @@ Tcl_ChannelBuffered(
void
Tcl_SetChannelBufferSize(
Tcl_Channel chan, /* The channel whose buffer size to set. */
- int sz) /* The size to set. */
+ Tcl_Size sz) /* The size to set. */
{
ChannelState *statePtr; /* State of real channel structure. */
@@ -7644,7 +7864,7 @@ Tcl_SetChannelBufferSize(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_GetChannelBufferSize(
Tcl_Channel chan) /* The channel for which to find the buffer
* size. */
@@ -7694,9 +7914,9 @@ Tcl_BadChannelOption(
{
if (interp != NULL) {
const char *genericopt =
- "blocking buffering buffersize encoding eofchar translation";
+ "blocking buffering buffersize encoding eofchar profile translation";
const char **argv;
- int argc, i;
+ Tcl_Size argc, i;
Tcl_DString ds;
Tcl_Obj *errObj;
@@ -7894,6 +8114,23 @@ Tcl_GetChannelOption(
return TCL_OK;
}
}
+ if (len == 0 || HaveOpt(1, "-profile")) {
+ int profile;
+ const char *profileName;
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-profile");
+ }
+ /* Note currently input and output profiles are same */
+ profile = ENCODING_PROFILE_GET(statePtr->inputEncodingFlags);
+ profileName = TclEncodingProfileIdToName(interp, profile);
+ if (profileName == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_DStringAppendElement(dsPtr, profileName);
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
if (len == 0 || HaveOpt(1, "-translation")) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-translation");
@@ -7989,8 +8226,8 @@ Tcl_SetChannelOption(
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
size_t len; /* Length of optionName string. */
- int argc;
- const char **argv;
+ Tcl_Size argc;
+ const char **argv = NULL;
/*
* If the channel is in the middle of a background copy, fail.
@@ -8065,6 +8302,7 @@ Tcl_SetChannelOption(
return TCL_OK;
} else if (HaveOpt(2, "-encoding")) {
Tcl_Encoding encoding;
+ int profile;
if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
encoding = NULL;
@@ -8089,29 +8327,35 @@ Tcl_SetChannelOption(
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = encoding;
statePtr->inputEncodingState = NULL;
+ profile = ENCODING_PROFILE_GET(statePtr->inputEncodingFlags);
statePtr->inputEncodingFlags = TCL_ENCODING_START;
+ ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile);
statePtr->outputEncodingState = NULL;
statePtr->outputEncodingFlags = TCL_ENCODING_START;
- ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
+ ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */
+ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
UpdateInterest(chanPtr);
return TCL_OK;
} else if (HaveOpt(2, "-eofchar")) {
- if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
+ if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) {
+ if (GotFlag(statePtr, TCL_READABLE)) {
+ statePtr->inEofChar = newValue[0];
+ }
+ statePtr->outEofChar = 0;
+ } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
- }
- if (argc == 0) {
+ } else if (argc == 0) {
statePtr->inEofChar = 0;
statePtr->outEofChar = 0;
} else if (argc == 1 || argc == 2) {
- int outIndex = (argc - 1);
int inValue = (int) argv[0][0];
- int outValue = (int) argv[outIndex][0];
+ int outValue = (argc == 2) ? (int) argv[1][0] : 0;
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
- " character", -1));
+ " character", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8126,7 +8370,7 @@ Tcl_SetChannelOption(
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
- " one, or two elements", -1));
+ " one, or two elements", TCL_INDEX_NONE));
}
ckfree(argv);
return TCL_ERROR;
@@ -8147,6 +8391,15 @@ Tcl_SetChannelOption(
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
return TCL_OK;
+ } else if (HaveOpt(1, "-profile")) {
+ int profile;
+ if (TclEncodingProfileNameToId(interp, newValue, &profile) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile);
+ ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile);
+ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
+ return TCL_OK;
} else if (HaveOpt(1, "-translation")) {
const char *readMode, *writeMode;
@@ -8574,6 +8827,18 @@ UpdateInterest(
}
}
}
+
+ if (!statePtr->timer
+ && mask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)) {
+
+ TclChannelPreserve((Tcl_Channel)chanPtr);
+ statePtr->timerChanPtr = chanPtr;
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ }
+
+
ChanWatch(chanPtr, mask);
}
@@ -8596,39 +8861,79 @@ UpdateInterest(
static void
ChannelTimerProc(
- ClientData clientData)
+ void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
/* State info for channel */
ChannelState *statePtr = chanPtr->state;
+ /* TclChannelPreserve() must be called before the current function was
+ * scheduled, is already in effect. In this function it guards against
+ * deallocation in Tcl_NotifyChannel and also keps the channel preserved
+ * until ChannelTimerProc is later called again.
+ */
+
if (chanPtr->typePtr == NULL) {
- statePtr->timer = NULL;
- TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
- statePtr->timerChanPtr = NULL;
+ CleanupTimerHandler(statePtr);
} else {
- if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
- && (statePtr->interestMask & TCL_READABLE)
- && (statePtr->inQueueHead != NULL)
- && IsBufferReady(statePtr->inQueueHead)) {
+ Tcl_Preserve(statePtr);
+ statePtr->timer = NULL;
+ if (statePtr->interestMask & TCL_WRITABLE
+ && GotFlag(statePtr, CHANNEL_NONBLOCKING)
+ && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)
+ ) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
-
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc,chanPtr);
- Tcl_Preserve(statePtr);
- Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
- Tcl_Release(statePtr);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
} else {
- statePtr->timer = NULL;
- UpdateInterest(chanPtr);
- TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
- statePtr->timerChanPtr = NULL;
+ /* The channel may have just been closed from within Tcl_NotifyChannel */
+ if (!GotFlag(statePtr, CHANNEL_INCLOSE)) {
+ if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
+ && (statePtr->interestMask & TCL_READABLE)
+ && (statePtr->inQueueHead != NULL)
+ && IsBufferReady(statePtr->inQueueHead)) {
+ /*
+ * Restart the timer in case a channel handler reenters the event loop
+ * before UpdateInterest gets called by Tcl_NotifyChannel.
+ */
+
+ statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ ChannelTimerProc,chanPtr);
+ Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
+ } else {
+ CleanupTimerHandler(statePtr);
+ UpdateInterest(chanPtr);
+ }
+ } else {
+ CleanupTimerHandler(statePtr);
+ }
}
+ Tcl_Release(statePtr);
+ }
+}
+
+static void
+DeleteTimerHandler(
+ ChannelState *statePtr
+)
+{
+ if (statePtr->timer != NULL) {
+ Tcl_DeleteTimerHandler(statePtr->timer);
+ CleanupTimerHandler(statePtr);
}
}
+static void
+CleanupTimerHandler(
+ ChannelState *statePtr
+){
+ TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
+ statePtr->timer = NULL;
+ statePtr->timerChanPtr = NULL;
+}
/*
*----------------------------------------------------------------------
@@ -8661,7 +8966,7 @@ Tcl_CreateChannelHandler(
* handler. */
Tcl_ChannelProc *proc, /* Procedure to call for each selected
* event. */
- ClientData clientData) /* Arbitrary data to pass to proc. */
+ void *clientData) /* Arbitrary data to pass to proc. */
{
ChannelHandler *chPtr;
Channel *chanPtr = (Channel *) chan;
@@ -8733,7 +9038,7 @@ Tcl_DeleteChannelHandler(
Tcl_Channel chan, /* The channel for which to remove the
* callback. */
Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */
- ClientData clientData) /* The client data in the callback to
+ void *clientData) /* The client data in the callback to
* delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -8939,21 +9244,20 @@ CreateScriptRecord(
void
TclChannelEventScriptInvoker(
- ClientData clientData, /* The script+interp record. */
- int mask) /* Not used. */
+ void *clientData, /* The script+interp record. */
+ TCL_UNUSED(int) /*mask*/)
{
- Tcl_Interp *interp; /* Interpreter in which to eval the script. */
- Channel *chanPtr; /* The channel for which this handler is
- * registered. */
- EventScriptRecord *esPtr; /* The event script + interpreter to eval it
+ EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
+ /* The event script + interpreter to eval it
* in. */
+ Channel *chanPtr = esPtr->chanPtr;
+ /* The channel for which this handler is
+ * registered. */
+ Tcl_Interp *interp = esPtr->interp;
+ /* Interpreter in which to eval the script. */
+ int mask = esPtr->mask;
int result; /* Result of call to eval script. */
- esPtr = (EventScriptRecord *)clientData;
- chanPtr = esPtr->chanPtr;
- mask = esPtr->mask;
- interp = esPtr->interp;
-
/*
* Be sure event executed in managed channel (covering bugs similar [f583715154]).
*/
@@ -9008,7 +9312,7 @@ TclChannelEventScriptInvoker(
int
Tcl_FileEventObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
@@ -9022,7 +9326,6 @@ Tcl_FileEventObjCmd(
int mask;
static const char *const modeOptions[] = {"readable", "writable", NULL};
static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
- (void)dummy;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
@@ -9103,7 +9406,7 @@ Tcl_FileEventObjCmd(
static void
ZeroTransferTimerProc(
- ClientData clientData)
+ void *clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
@@ -9132,6 +9435,7 @@ ZeroTransferTimerProc(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
@@ -9143,13 +9447,14 @@ TclCopyChannelOld(
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
+#endif
int
TclCopyChannel(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
- Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */
+ long long toRead, /* Amount of data to copy, or -1 for all. */
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
Channel *inPtr = (Channel *) inChan;
@@ -9206,8 +9511,8 @@ TclCopyChannel(
* Make sure the output side is unbuffered.
*/
- outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED)
- | CHANNEL_UNBUFFERED;
+ ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED);
+ SetFlag(outStatePtr, CHANNEL_UNBUFFERED);
/*
* Test for conditions where we know we can just move bytes from input
@@ -9218,7 +9523,9 @@ TclCopyChannel(
moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */
&& inStatePtr->inputTranslation == TCL_TRANSLATE_LF
&& outStatePtr->outputTranslation == TCL_TRANSLATE_LF
- && inStatePtr->encoding == outStatePtr->encoding;
+ && inStatePtr->encoding == outStatePtr->encoding
+ && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
+ && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8;
/*
* Allocate a new CopyState to maintain info about the current copy in
@@ -9337,7 +9644,7 @@ MBError(
static void
MBEvent(
- ClientData clientData,
+ void *clientData,
int mask)
{
CopyState *csPtr = (CopyState *) clientData;
@@ -9421,7 +9728,7 @@ MBWrite(
* then the calculations involving extra must be made wide too.
*
* Noted with Win32/MSVC debug build treating the warning (possible of
- * data in __int64 to int conversion) as error.
+ * data in long long to int conversion) as error.
*/
bufPtr = AllocChannelBuffer(extra);
@@ -9521,7 +9828,8 @@ CopyData(
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK;
- int sizeb;
+ Tcl_Size sizeb;
+ Tcl_Size sizePart;
Tcl_WideInt total;
int size;
const char *buffer;
@@ -9546,7 +9854,9 @@ CopyData(
inBinary = (inStatePtr->encoding == NULL);
outBinary = (outStatePtr->encoding == NULL);
- sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);
+ sameEncoding = inStatePtr->encoding == outStatePtr->encoding
+ && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8
+ && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8;
if (!(inBinary || sameEncoding)) {
TclNewObj(bufObj);
@@ -9563,12 +9873,20 @@ CopyData(
Tcl_SetErrno(inStatePtr->unreportedError);
inStatePtr->unreportedError = 0;
goto readError;
+ } else if (inStatePtr->flags & CHANNEL_ENCODING_ERROR) {
+ Tcl_SetErrno(EILSEQ);
+ inStatePtr->flags &= ~CHANNEL_ENCODING_ERROR;
+ goto readError;
}
Tcl_GetChannelError(outChan, &msg);
if ((outStatePtr->unreportedError != 0) || (msg != NULL)) {
Tcl_SetErrno(outStatePtr->unreportedError);
outStatePtr->unreportedError = 0;
goto writeError;
+ } else if (outStatePtr->flags & CHANNEL_ENCODING_ERROR) {
+ Tcl_SetErrno(EILSEQ);
+ outStatePtr->flags &= ~CHANNEL_ENCODING_ERROR;
+ goto writeError;
}
if (cmdPtr && (mask == 0)) {
@@ -9596,7 +9914,25 @@ CopyData(
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
- 0 /* No append */);
+ !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
+ ,0 /* No append */);
+ /*
+ * In case of a recoverable encoding error, any data before
+ * the error should be written. This data is in the bufObj.
+ * Program flow for this case:
+ * - Check, if there are any remaining bytes to write
+ * - If yes, simulate a successful read to write them out
+ * - Come back here by the outer loop and read again
+ * - Do not enter in the if below, as there are no pending
+ * writes
+ * - Fail below with a read error
+ */
+ if (size < 0 && Tcl_GetErrno() == EILSEQ) {
+ Tcl_GetStringFromObj(bufObj, &sizePart);
+ if (sizePart > 0) {
+ size = sizePart;
+ }
+ }
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
@@ -9829,7 +10165,7 @@ CopyData(
*
* Results:
* The number of bytes actually stored (<= bytesToRead),
- * or -1 if there is an error in reading the channel. Use
+ * or TCL_INDEX_NONE if there is an error in reading the channel. Use
* Tcl_GetErrno() to retrieve the error code for the error
* that occurred.
*
@@ -9838,7 +10174,7 @@ CopyData(
* - EOF is reached on the channel; or
* - the channel is non-blocking, and we've read all we can
* without blocking.
- * - a channel reading error occurs (and we return -1)
+ * - a channel reading error occurs (and we return TCL_INDEX_NONE)
*
* Side effects:
* May cause input to be buffered.
@@ -9846,11 +10182,11 @@ CopyData(
*----------------------------------------------------------------------
*/
-static int
+static Tcl_Size
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
- int bytesToRead, /* Maximum number of bytes to read. */
+ Tcl_Size bytesToRead, /* Maximum number of bytes to read. */
int allowShortReads) /* Allow half-blocking (pipes,sockets) */
{
ChannelState *statePtr = chanPtr->state;
@@ -9870,6 +10206,11 @@ DoRead(
* too. Keep on keeping on for now.
*/
+ if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+ UpdateInterest(chanPtr);
+ Tcl_SetErrno(EILSEQ);
+ return -1;
+ }
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
@@ -9967,10 +10308,10 @@ DoRead(
}
/*
- * 1) We're @EOF because we saw eof char.
+ * 1) We're @EOF because we saw eof char, or there was an encoding error.
*/
- if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
+ if (GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)) {
break;
}
@@ -10055,6 +10396,7 @@ DoRead(
assert(!GotFlag(statePtr, CHANNEL_EOF)
|| GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
|| Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
== (CHANNEL_EOF|CHANNEL_BLOCKED)));
@@ -10083,7 +10425,7 @@ DoRead(
static void
CopyEventProc(
- ClientData clientData,
+ void *clientData,
int mask)
{
(void) CopyData((CopyState *)clientData, mask);
@@ -10553,6 +10895,7 @@ Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2)
|| (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) {
/*
@@ -10561,6 +10904,7 @@ Tcl_ChannelVersion(
*/
return TCL_CHANNEL_VERSION_1;
}
+#endif
return chanTypePtr->version;
}
@@ -10584,13 +10928,14 @@ Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
-
+#endif
return chanTypePtr->blockModeProc;
}
@@ -10610,6 +10955,7 @@ Tcl_ChannelBlockModeProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10617,6 +10963,7 @@ Tcl_ChannelCloseProc(
{
return chanTypePtr->closeProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10706,6 +11053,7 @@ Tcl_ChannelOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
@@ -10713,6 +11061,7 @@ Tcl_ChannelSeekProc(
{
return chanTypePtr->seekProc;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -10831,9 +11180,11 @@ Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
+#endif
return chanTypePtr->flushProc;
}
@@ -10858,9 +11209,11 @@ Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
+#endif
return chanTypePtr->handlerProc;
}
@@ -10885,9 +11238,11 @@ Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) {
return NULL;
}
+#endif
return chanTypePtr->wideSeekProc;
}
@@ -10913,9 +11268,11 @@ Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
+#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) {
return NULL;
}
+#endif
return chanTypePtr->threadActionProc;
}
@@ -10942,15 +11299,17 @@ Tcl_SetChannelErrorInterp(
Tcl_Obj *msg) /* Error message to store. */
{
Interp *iPtr = (Interp *) interp;
-
- if (iPtr->chanMsg != NULL) {
- TclDecrRefCount(iPtr->chanMsg);
- iPtr->chanMsg = NULL;
- }
+ Tcl_Obj *disposePtr = iPtr->chanMsg;
if (msg != NULL) {
iPtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(iPtr->chanMsg);
+ } else {
+ iPtr->chanMsg = NULL;
+ }
+
+ if (disposePtr != NULL) {
+ TclDecrRefCount(disposePtr);
}
return;
}
@@ -10978,15 +11337,17 @@ Tcl_SetChannelError(
Tcl_Obj *msg) /* Error message to store. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
-
- if (statePtr->chanMsg != NULL) {
- TclDecrRefCount(statePtr->chanMsg);
- statePtr->chanMsg = NULL;
- }
+ Tcl_Obj *disposePtr = statePtr->chanMsg;
if (msg != NULL) {
statePtr->chanMsg = FixLevelCode(msg);
Tcl_IncrRefCount(statePtr->chanMsg);
+ } else {
+ statePtr->chanMsg = NULL;
+ }
+
+ if (disposePtr != NULL) {
+ TclDecrRefCount(disposePtr);
}
return;
}
@@ -11015,7 +11376,7 @@ FixLevelCode(
Tcl_Obj *msg)
{
int explicitResult, numOptions, lcn;
- int lc;
+ Tcl_Size lc;
Tcl_Obj **lv, **lvn;
int res, i, j, val, lignore, cignore;
int newlevel = -1, newcode = -1;
@@ -11032,7 +11393,7 @@ FixLevelCode(
* information. Hence an error means that we've got serious breakage.
*/
- res = TclListObjGetElements(NULL, msg, &lc, &lv);
+ res = TclListObjGetElementsM(NULL, msg, &lc, &lv);
if (res != TCL_OK) {
Tcl_Panic("Tcl_SetChannelError: bad syntax of message");
}
@@ -11108,7 +11469,7 @@ FixLevelCode(
if (0 == strcmp(TclGetString(lv[i]), "-level")) {
if (newlevel >= 0) {
lvn[j++] = lv[i];
- lvn[j++] = Tcl_NewIntObj(newlevel);
+ lvn[j++] = Tcl_NewWideIntObj(newlevel);
newlevel = -1;
lignore = 1;
continue;
@@ -11118,7 +11479,7 @@ FixLevelCode(
} else if (0 == strcmp(TclGetString(lv[i]), "-code")) {
if (newcode >= 0) {
lvn[j++] = lv[i];
- lvn[j++] = Tcl_NewIntObj(newcode);
+ lvn[j++] = Tcl_NewWideIntObj(newcode);
newcode = -1;
cignore = 1;
continue;
@@ -11260,11 +11621,11 @@ DupChannelInternalRep(
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- resPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- copyPtr->typePtr = srcPtr->typePtr;
+ ChanGetInternalRep(srcPtr, resPtr);
+ assert(resPtr);
+ ChanSetInternalRep(copyPtr, resPtr);
}
/*
@@ -11287,10 +11648,11 @@ static void
FreeChannelInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
- ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedChanName *resPtr;
- objPtr->typePtr = NULL;
- if (--resPtr->refCount) {
+ ChanGetInternalRep(objPtr, resPtr);
+ assert(resPtr);
+ if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
@@ -11322,6 +11684,7 @@ DumpFlags(
ChanFlag('c', CHANNEL_CLOSED);
ChanFlag('E', CHANNEL_EOF);
ChanFlag('S', CHANNEL_STICKY_EOF);
+ ChanFlag('U', CHANNEL_ENCODING_ERROR);
ChanFlag('B', CHANNEL_BLOCKED);
ChanFlag('/', INPUT_SAW_CR);
ChanFlag('D', CHANNEL_DEAD);
diff --git a/generic/tclIO.h b/generic/tclIO.h
index c7a3b7f..08fff44 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -36,12 +36,12 @@
*/
typedef struct ChannelBuffer {
- int refCount; /* Current uses count */
- int nextAdded; /* The next position into which a character
+ Tcl_Size refCount; /* Current uses count */
+ Tcl_Size nextAdded; /* The next position into which a character
* will be put in the buffer. */
- int nextRemoved; /* Position of next byte to be removed from
+ Tcl_Size nextRemoved; /* Position of next byte to be removed from
* the buffer. */
- int bufLength; /* How big is the buffer? */
+ Tcl_Size bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real
@@ -50,7 +50,7 @@ typedef struct ChannelBuffer {
* structure. */
} ChannelBuffer;
-#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf)
+#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf)
/*
* How much extra space to allocate in buffer to hold bytes from previous
@@ -96,7 +96,7 @@ typedef struct EventScriptRecord {
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
- ClientData instanceData; /* Instance-specific data provided by creator
+ void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
@@ -113,7 +113,7 @@ typedef struct Channel {
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
- int refCount;
+ Tcl_Size refCount;
} Channel;
/*
@@ -158,12 +158,14 @@ typedef struct ChannelState {
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
+#if TCL_MAJOR_VERSION < 9
int outEofChar; /* If nonzero, append this to the channel when
- * it is closed if it is open for writing. */
+ * it is closed if it is open for writing. For Tcl 8.x only */
+#endif
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
- int refCount; /* How many interpreters hold references to
+ Tcl_Size refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
@@ -186,7 +188,7 @@ typedef struct ChannelState {
EventScriptRecord *scriptRecordPtr;
/* Chain of all scripts registered for event
* handlers ("fileevent") on this channel. */
- int bufSize; /* What size buffers to allocate? */
+ Tcl_Size bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
Channel *timerChanPtr; /* Needed in order to decrement the refCount of
the right channel when the timer is
@@ -217,8 +219,10 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
- int epoch; /* Used to test validity of stored channelname
+ size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
+ int maxPerms; /* TIP #220: Max access privileges
+ * the channel was created with. */
} ChannelState;
/*
@@ -228,12 +232,8 @@ typedef struct ChannelState {
* the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set.
*/
-#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in nonblocking
+#define CHANNEL_NONBLOCKING (1<<6) /* Channel is currently in nonblocking
* mode. */
-#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be
- * flushed after every newline. */
-#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always
- * be flushed immediately. */
#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued
* output buffers has been
* scheduled. */
@@ -272,9 +272,14 @@ typedef struct ChannelState {
* delivered for buffered data until
* the state of the channel
* changes. */
+#define CHANNEL_ENCODING_ERROR (1<<15) /* set if channel
+ * encountered an encoding error */
#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is
* being used. */
-
+#define CHANNEL_LINEBUFFERED (1<<17) /* Output to the channel must be
+ * flushed after every newline. */
+#define CHANNEL_UNBUFFERED (1<<18) /* Output to the channel must always
+ * be flushed immediately. */
#define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed.
* Its structures are still live and
* usable, but it may not be closed
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 4fd7c04..9667419 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -3,7 +3,7 @@
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -15,8 +15,8 @@
* Callback structure for accept callback in a TCP server.
*/
-typedef struct AcceptCallback {
- char *script; /* Script to invoke. */
+typedef struct {
+ Tcl_Obj *script; /* Script to invoke. */
Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
@@ -25,7 +25,7 @@ typedef struct AcceptCallback {
* It must be per-thread because of std channel limitations.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;
@@ -36,20 +36,15 @@ static Tcl_ThreadDataKey dataKey;
* Static functions for this file:
*/
-static void FinalizeIOCmdTSD(ClientData clientData);
-static void AcceptCallbackProc(ClientData callbackData,
- Tcl_Channel chan, char *address, int port);
-static int ChanPendingObjCmd(ClientData unused,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int ChanTruncateObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp,
- AcceptCallback *acceptCallbackPtr);
-static void TcpAcceptCallbacksDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
-static void TcpServerCloseProc(ClientData callbackData);
+static Tcl_ExitProc FinalizeIOCmdTSD;
+static Tcl_TcpAcceptProc AcceptCallbackProc;
+static Tcl_ObjCmdProc ChanPendingObjCmd;
+static Tcl_ObjCmdProc ChanTruncateObjCmd;
+static void RegisterTcpServerInterpCleanup(
+ Tcl_Interp *interp,
+ AcceptCallback *acceptCallbackPtr);
+static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc;
+static void TcpServerCloseProc(void *callbackData);
static void UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
@@ -72,7 +67,7 @@ static void UnregisterTcpServerInterpCleanupProc(
static void
FinalizeIOCmdTSD(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(void *))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -100,10 +95,9 @@ FinalizeIOCmdTSD(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_PutsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -112,9 +106,8 @@ Tcl_PutsObjCmd(
Tcl_Obj *string; /* String to write. */
Tcl_Obj *chanObjPtr = NULL; /* channel object. */
int newline; /* Add a newline at end? */
- int result; /* Result of puts operation. */
+ Tcl_Size result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
- ThreadSpecificData *tsdPtr;
switch (objc) {
case 2: /* [puts $x] */
@@ -139,6 +132,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[2];
string = objv[3];
break;
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
@@ -150,6 +144,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[1];
string = objv[2];
break;
+#endif
}
/* Fall through */
default: /* [puts] or
@@ -159,7 +154,7 @@ Tcl_PutsObjCmd(
}
if (chanObjPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
@@ -181,12 +176,12 @@ Tcl_PutsObjCmd(
TclChannelPreserve(chan);
result = Tcl_WriteObj(chan, string);
- if (result < 0) {
+ if (result == TCL_INDEX_NONE) {
goto error;
}
if (newline != 0) {
result = Tcl_WriteChars(chan, "\n", 1);
- if (result < 0) {
+ if (result == TCL_INDEX_NONE) {
goto error;
}
}
@@ -226,10 +221,9 @@ Tcl_PutsObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FlushObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -291,16 +285,15 @@ Tcl_FlushObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_GetsObjCmd(
- ClientData dummy, /* Not used. */
+ 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 lineLen; /* Length of line just read. */
+ Tcl_Size lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *linePtr, *chanObjPtr;
int code = TCL_OK;
@@ -323,7 +316,7 @@ Tcl_GetsObjCmd(
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
- if (lineLen < 0) {
+ if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
@@ -342,7 +335,7 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- lineLen = -1;
+ lineLen = TCL_IO_FAILURE;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
@@ -350,7 +343,9 @@ Tcl_GetsObjCmd(
code = TCL_ERROR;
goto done;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
+ Tcl_Obj *lineLenObj;
+ TclNewIndexObj(lineLenObj, lineLen);
+ Tcl_SetObjResult(interp, lineLenObj);
} else {
Tcl_SetObjResult(interp, linePtr);
}
@@ -376,10 +371,9 @@ Tcl_GetsObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ReadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -387,7 +381,7 @@ Tcl_ReadObjCmd(
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
- int charactersRead; /* How many characters were read? */
+ Tcl_Size charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *chanObjPtr;
@@ -437,8 +431,9 @@ Tcl_ReadObjCmd(
toRead = -1;
if (i < objc) {
- if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
+ if ((TclGetIntFromObj(NULL, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
+#if !defined(TCL_NO_DEPRECATED)
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -447,21 +442,29 @@ Tcl_ReadObjCmd(
*/
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
+#endif
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL);
return TCL_ERROR;
+#if !defined(TCL_NO_DEPRECATED)
}
newline = 1;
+#endif
}
}
TclNewObj(resultPtr);
- Tcl_IncrRefCount(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
- if (charactersRead < 0) {
+ if (charactersRead == TCL_IO_FAILURE) {
+ Tcl_Obj *returnOptsPtr = NULL;
+ if (TclChannelGetBlockingMode(chan)) {
+ returnOptsPtr = Tcl_NewDictObj();
+ Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1),
+ resultPtr);
+ }
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
@@ -475,7 +478,9 @@ Tcl_ReadObjCmd(
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
TclChannelRelease(chan);
- Tcl_DecrRefCount(resultPtr);
+ if (returnOptsPtr) {
+ Tcl_SetReturnOptions(interp, returnOptsPtr);
+ }
return TCL_ERROR;
}
@@ -485,7 +490,7 @@ Tcl_ReadObjCmd(
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
- int length;
+ Tcl_Size length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
@@ -494,7 +499,6 @@ Tcl_ReadObjCmd(
}
Tcl_SetObjResult(interp, resultPtr);
TclChannelRelease(chan);
- Tcl_DecrRefCount(resultPtr);
return TCL_OK;
}
@@ -516,10 +520,9 @@ Tcl_ReadObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_SeekObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -555,7 +558,7 @@ Tcl_SeekObjCmd(
TclChannelPreserve(chan);
result = Tcl_Seek(chan, offset, mode);
- if (result == Tcl_LongAsWide(-1)) {
+ if (result == -1) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
@@ -592,10 +595,9 @@ Tcl_SeekObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_TellObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -655,10 +657,9 @@ Tcl_TellObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_CloseObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -731,7 +732,7 @@ Tcl_CloseObjCmd(
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
const char *string;
- int len;
+ Tcl_Size len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
@@ -764,10 +765,9 @@ Tcl_CloseObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FconfigureObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -840,10 +840,9 @@ Tcl_FconfigureObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_EofObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -880,10 +879,9 @@ Tcl_EofObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_ExecObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -893,12 +891,12 @@ Tcl_ExecObjCmd(
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
- int argc, background, i, index, keepNewline, result, skip, length;
- int ignoreStderr;
+ int argc, background, i, index, keepNewline, result, skip, ignoreStderr;
+ Tcl_Size length;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
- enum options {
+ enum execOptionsEnum {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
@@ -948,7 +946,7 @@ Tcl_ExecObjCmd(
*/
argc = objc - skip;
- argv = (const char **)TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
+ argv = (const char **)TclStackAlloc(interp, (argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
@@ -987,7 +985,7 @@ Tcl_ExecObjCmd(
TclNewObj(resultPtr);
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
- if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
+ if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
@@ -1048,10 +1046,9 @@ Tcl_ExecObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_FblockedObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1095,10 +1092,9 @@ Tcl_FblockedObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_OpenObjCmd(
- ClientData notUsed, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1156,7 +1152,8 @@ Tcl_OpenObjCmd(
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
- int mode, seekFlag, cmdObjc, binary;
+ int mode, seekFlag, binary;
+ Tcl_Size cmdObjc;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
@@ -1219,12 +1216,11 @@ Tcl_OpenObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TcpAcceptCallbacksDeleteProc(
- ClientData clientData, /* Data which was passed when the assocdata
+ void *clientData, /* Data which was passed when the assocdata
* was registered. */
- Tcl_Interp *interp) /* Interpreter being deleted - not used. */
+ TCL_UNUSED(Tcl_Interp *))
{
Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
@@ -1325,7 +1321,7 @@ UnregisterTcpServerInterpCleanupProc(
return;
}
- hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
+ hPtr = Tcl_FindHashEntry(hTblPtr, (char *)acceptCallbackPtr);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -1350,7 +1346,7 @@ UnregisterTcpServerInterpCleanupProc(
static void
AcceptCallbackProc(
- ClientData callbackData, /* The data stored when the callback was
+ void *callbackData, /* The data stored when the callback was
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
@@ -1367,15 +1363,22 @@ AcceptCallbackProc(
*/
if (acceptCallbackPtr->interp != NULL) {
- char portBuf[TCL_INTEGER_SPACE];
- char *script = acceptCallbackPtr->script;
Tcl_Interp *interp = acceptCallbackPtr->interp;
- int result;
+ Tcl_Obj *script, *objv[2];
+ int result = TCL_OK;
- Tcl_Preserve(script);
- Tcl_Preserve(interp);
+ objv[0] = acceptCallbackPtr->script;
+ objv[1] = Tcl_NewListObj(3, NULL);
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(
+ Tcl_GetChannelName(chan), -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1));
+ Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewWideIntObj(port));
- TclFormatInt(portBuf, port);
+ script = Tcl_ConcatObj(2, objv);
+ Tcl_IncrRefCount(script);
+ Tcl_DecrRefCount(objv[1]);
+
+ Tcl_Preserve(interp);
Tcl_RegisterChannel(interp, chan);
/*
@@ -1385,8 +1388,9 @@ AcceptCallbackProc(
Tcl_RegisterChannel(NULL, chan);
- result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
- " ", address, " ", portBuf, NULL);
+ result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(script);
+
if (result != TCL_OK) {
Tcl_BackgroundException(interp, result);
Tcl_UnregisterChannel(interp, chan);
@@ -1400,7 +1404,6 @@ AcceptCallbackProc(
Tcl_UnregisterChannel(NULL, chan);
Tcl_Release(interp);
- Tcl_Release(script);
} else {
/*
* The interpreter has been deleted, so there is no useful way to use
@@ -1434,7 +1437,7 @@ AcceptCallbackProc(
static void
TcpServerCloseProc(
- ClientData callbackData) /* The data passed in the call to
+ void *callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
@@ -1444,7 +1447,7 @@ TcpServerCloseProc(
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
- Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
+ Tcl_DecrRefCount(acceptCallbackPtr->script);
ckfree(acceptCallbackPtr);
}
@@ -1467,27 +1470,30 @@ TcpServerCloseProc(
int
Tcl_SocketObjCmd(
- ClientData notUsed, /* Not used. */
+ 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", "-server", NULL
+ "-async", "-backlog", "-myaddr", "-myport", "-reuseaddr",
+ "-reuseport", "-server", NULL
};
- enum socketOptions {
- SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ enum socketOptionsEnum {
+ SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR,
+ SKT_REUSEPORT, SKT_SERVER
};
- int optionIndex, a, server = 0, port, myport = 0, async = 0;
- const char *host, *script = NULL, *myaddr = NULL;
+ int a, server = 0, myport = 0, async = 0, reusep = -1, optionIndex,
+ reusea = -1, backlog = -1;
+ unsigned int flags = 0;
+ const char *host, *port, *myaddr = NULL;
+ Tcl_Obj *script = NULL;
Tcl_Channel chan;
- if (TclpHasSockets(interp) != TCL_OK) {
- return TCL_ERROR;
- }
+ TclInitSockets();
for (a = 1; a < objc; a++) {
- const char *arg = Tcl_GetString(objv[a]);
+ const char *arg = TclGetString(objv[a]);
if (arg[0] != '-') {
break;
@@ -1496,7 +1502,7 @@ Tcl_SocketObjCmd(
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum socketOptions) optionIndex) {
+ switch ((enum socketOptionsEnum) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -1542,7 +1548,40 @@ Tcl_SocketObjCmd(
"no argument given for -server option", -1));
return TCL_ERROR;
}
- script = TclGetString(objv[a]);
+ script = objv[a];
+ break;
+ case SKT_REUSEADDR:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseaddr option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_REUSEPORT:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseport option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_BACKLOG:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -backlog option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[a], &backlog) != TCL_OK) {
+ return TCL_ERROR;
+ }
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1564,35 +1603,66 @@ Tcl_SocketObjCmd(
wrongNumArgs:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv,
- "?-myaddr addr? ?-myport myport? ?-async? host port");
+ "?-async? ?-myaddr addr? ?-myport myport? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
- "-server command ?-myaddr addr? port");
+ "-server command ?-backlog count? ?-myaddr addr? "
+ "?-reuseaddr boolean? ?-reuseport boolean? port");
return TCL_ERROR;
}
- if (a == objc-1) {
- if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
- &port) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
+ if (!server && (reusea != -1 || reusep != -1 || backlog != -1)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "options -backlog, -reuseaddr, and -reuseport are only valid "
+ "for servers", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the options to their default value if the user didn't override
+ * their value.
+ */
+
+ if (reusep == -1) {
+ reusep = 0;
+ }
+ if (reusea == -1) {
+ reusea = 1;
+ }
+
+ /*
+ * Build the bitset with the flags values.
+ */
+
+ if (reusea) {
+ flags |= TCL_TCPSERVER_REUSEADDR;
+ }
+ if (reusep) {
+ flags |= TCL_TCPSERVER_REUSEPORT;
+ }
+
+ /*
+ * All the arguments should have been parsed by now, 'a' points to the
+ * last one, the port number.
+ */
+
+ if (a != objc-1) {
goto wrongNumArgs;
}
+ port = TclGetString(objv[a]);
+
if (server) {
- AcceptCallback *acceptCallbackPtr = (AcceptCallback *)
- ckalloc(sizeof(AcceptCallback));
- unsigned len = strlen(script) + 1;
- char *copyScript = (char *)ckalloc(len);
+ AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback));
- memcpy(copyScript, script, len);
- acceptCallbackPtr->script = copyScript;
+ Tcl_IncrRefCount(script);
+ acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
- chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
- acceptCallbackPtr);
+
+ chan = Tcl_OpenTcpServerEx(interp, port, host, flags, backlog,
+ AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
- ckfree(copyScript);
+ Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
@@ -1614,7 +1684,13 @@ Tcl_SocketObjCmd(
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
- chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
+ int portNum;
+
+ if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
@@ -1645,7 +1721,7 @@ Tcl_SocketObjCmd(
int
Tcl_FcopyObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1738,18 +1814,17 @@ Tcl_FcopyObjCmd(
*---------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ChanPendingObjCmd(
- ClientData unused, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
- int index, mode;
static const char *const options[] = {"input", "output", NULL};
- enum options {PENDING_INPUT, PENDING_OUTPUT};
+ enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT};
+ int mode, index;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
@@ -1765,19 +1840,19 @@ ChanPendingObjCmd(
return TCL_ERROR;
}
- switch ((enum options) index) {
+ switch ((enum pendingOptionsEnum) index) {
case PENDING_INPUT:
if (!(mode & TCL_READABLE)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
if (!(mode & TCL_WRITABLE)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan)));
}
break;
}
@@ -1803,7 +1878,7 @@ ChanPendingObjCmd(
static int
ChanTruncateObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1838,7 +1913,7 @@ ChanTruncateObjCmd(
*/
length = Tcl_Tell(chan);
- if (length == Tcl_WideAsLong(-1)) {
+ if (length == -1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not determine current location in \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
@@ -1876,7 +1951,7 @@ ChanTruncateObjCmd(
static int
ChanPipeObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1927,7 +2002,7 @@ ChanPipeObjCmd(
int
TclChannelNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 4792ae2..93442a1 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -4,8 +4,8 @@
* Implements a generic transformation exposing the underlying API at the
* script level. Contributed by Andreas Kupries.
*
- * Copyright (c) 2000 Ajuba Solutions
- * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com)
+ * Copyright © 2000 Ajuba Solutions
+ * Copyright © 1999-2000 Andreas Kupries (a.kupries@westend.com)
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,15 +22,15 @@
static int TransformBlockModeProc(ClientData instanceData,
int mode);
static int TransformCloseProc(ClientData instanceData,
- Tcl_Interp *interp);
-static int TransformClose2Proc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int TransformInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCodePtr);
static int TransformOutputProc(ClientData instanceData,
const char *buf, int toWrite, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
static int TransformSeekProc(ClientData instanceData, long offset,
int mode, int *errorCodePtr);
+#endif
static int TransformSetOptionProc(ClientData instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
@@ -41,8 +41,8 @@ static void TransformWatchProc(ClientData instanceData, int mask);
static int TransformGetFileHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static int TransformNotifyProc(ClientData instanceData, int mask);
-static Tcl_WideInt TransformWideSeekProc(ClientData instanceData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
+static long long TransformWideSeekProc(ClientData instanceData,
+ long long offset, int mode, int *errorCodePtr);
/*
* Forward declarations of internal procedures. Secondly the procedures for
@@ -121,15 +121,19 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf,
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- TransformCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
+#ifndef TCL_NO_DEPRECATED
TransformSeekProc, /* Seek proc. */
+#else
+ NULL, /* Seek proc. */
+#endif
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
TransformGetFileHandleProc, /* Get OS handles out of channel. */
- TransformClose2Proc, /* close2proc */
+ TransformCloseProc, /* close2proc */
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up. */
@@ -213,7 +217,7 @@ struct TransformChannelData {
* a transformation of incoming data. Also
* serves as buffer of all data not yet
* consumed by the reader. */
- int refCount;
+ size_t refCount;
};
static void
@@ -227,7 +231,7 @@ static void
ReleaseData(
TransformChannelData *dataPtr)
{
- if (--dataPtr->refCount) {
+ if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
@@ -253,7 +257,6 @@ ReleaseData(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
TclChannelTransform(
Tcl_Interp *interp, /* Interpreter for result. */
@@ -263,7 +266,7 @@ TclChannelTransform(
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* State info for channel. */
int mode; /* Read/write mode of the channel. */
- int objc;
+ Tcl_Size objc;
TransformChannelData *dataPtr;
Tcl_DString ds;
@@ -271,7 +274,7 @@ TclChannelTransform(
return TCL_ERROR;
}
- if (TCL_OK != TclListObjLength(interp, cmdObjPtr, &objc)) {
+ if (TCL_OK != TclListObjLengthM(interp, cmdObjPtr, &objc)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("-command value is not a list", -1));
return TCL_ERROR;
@@ -380,7 +383,7 @@ ExecuteCallback(
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
- int resLen;
+ Tcl_Size resLen;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
@@ -518,7 +521,7 @@ TransformBlockModeProc(
/*
*----------------------------------------------------------------------
*
- * TransformCloseProc/TransformClose2Proc --
+ * TransformCloseProc --
*
* Trap handler. Called by the generic IO system during destruction of
* the transformation channel.
@@ -535,9 +538,14 @@ TransformBlockModeProc(
static int
TransformCloseProc(
ClientData instanceData,
- Tcl_Interp *interp)
+ Tcl_Interp *interp,
+ int flags)
{
- TransformChannelData *dataPtr = instanceData;
+ TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
/*
* Important: In this procedure 'dataPtr->self' already points to the
@@ -594,18 +602,6 @@ TransformCloseProc(
ReleaseData(dataPtr);
return TCL_OK;
}
-
-static int
-TransformClose2Proc(
- ClientData instanceData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return TransformCloseProc(instanceData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -842,6 +838,7 @@ TransformOutputProc(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
@@ -888,6 +885,7 @@ TransformSeekProc(
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -909,20 +907,22 @@ TransformSeekProc(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
- Tcl_WideInt offset, /* Size of movement. */
+ long long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
+#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
+#endif
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
- ClientData parentData = Tcl_GetChannelInstanceData(parent);
+ void *parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
@@ -932,10 +932,14 @@ TransformWideSeekProc(
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+ } else if (parentSeekProc) {
+ return parentSeekProc(parentData, 0, mode, errorCodePtr);
+#endif
+ } else {
+ *errorCodePtr = EINVAL;
+ return -1;
}
-
- return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode,
- errorCodePtr));
}
/*
@@ -963,25 +967,29 @@ TransformWideSeekProc(
* If we have a wide seek capability, we should stick with that.
*/
- if (parentWideSeekProc != NULL) {
- return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
- }
+ if (parentWideSeekProc == NULL) {
+ /*
+ * We're transferring to narrow seeks at this point; this is a bit complex
+ * because we have to check whether the seek is possible first (i.e.
+ * whether we are losing information in truncating the bits of the
+ * offset). Luckily, there's a defined error for what happens when trying
+ * to go out of the representable range.
+ */
- /*
- * We're transferring to narrow seeks at this point; this is a bit complex
- * because we have to check whether the seek is possible first (i.e.
- * whether we are losing information in truncating the bits of the
- * offset). Luckily, there's a defined error for what happens when trying
- * to go out of the representable range.
- */
+#ifndef TCL_NO_DEPRECATED
+ if (offset<LONG_MIN || offset>LONG_MAX) {
+ *errorCodePtr = EOVERFLOW;
+ return -1;
+ }
- if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
- *errorCodePtr = EOVERFLOW;
- return Tcl_LongAsWide(-1);
+ return parentSeekProc(parentData, offset,
+ mode, errorCodePtr);
+#else
+ *errorCodePtr = EINVAL;
+ return -1;
+#endif
}
-
- return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset),
- mode, errorCodePtr));
+ return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
@@ -1087,7 +1095,6 @@ TransformGetOptionProc(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
TransformWatchProc(
ClientData instanceData, /* Channel to watch. */
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 69a8e11..e342126 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -10,7 +10,7 @@
*
* See TIP #219 for the specification of this functionality.
*
- * Copyright (c) 2004-2005 ActiveState, a division of Sophos
+ * Copyright © 2004-2005 ActiveState, a division of Sophos
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,31 +31,35 @@
* Signatures of all functions used in the C layer of the reflection.
*/
-static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
+static int ReflectClose(void *clientData,
Tcl_Interp *interp, int flags);
-static int ReflectInput(ClientData clientData, char *buf,
+static int ReflectInput(void *clientData, char *buf,
int toRead, int *errorCodePtr);
-static int ReflectOutput(ClientData clientData, const char *buf,
+static int ReflectOutput(void *clientData, const char *buf,
int toWrite, int *errorCodePtr);
-static void ReflectWatch(ClientData clientData, int mask);
-static int ReflectBlock(ClientData clientData, int mode);
-#ifdef TCL_THREADS
-static void ReflectThread(ClientData clientData, int action);
+static void ReflectWatch(void *clientData, int mask);
+static int ReflectBlock(void *clientData, int mode);
+#if TCL_THREADS
+static void ReflectThread(void *clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
-static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
+static int ReflectEventDelete(Tcl_Event *ev, void *cd);
#endif
-static Tcl_WideInt ReflectSeekWide(ClientData clientData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
-static int ReflectSeek(ClientData clientData, long offset,
+static long long ReflectSeekWide(void *clientData,
+ long long offset, int mode, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+static int ReflectSeek(void *clientData, long offset,
int mode, int *errorCodePtr);
-static int ReflectGetOption(ClientData clientData,
+#endif
+static int ReflectGetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-static int ReflectSetOption(ClientData clientData,
+static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
+static int ReflectTruncate(void *clientData,
+ long long length);
+static void TimerRunRead(void *clientData);
+static void TimerRunWrite(void *clientData);
/*
* The C layer channel type/driver definition used by the reflection.
@@ -64,25 +68,29 @@ static int ReflectSetOption(ClientData clientData,
static const Tcl_ChannelType tclRChannelType = {
"tclrchannel", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
- ReflectClose, /* Close channel, clean instance data */
+ TCL_CLOSE2PROC, /* Close channel, clean instance data */
ReflectInput, /* Handle read request */
ReflectOutput, /* Handle write request */
+#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. NULL'able */
+#else
+ NULL,
+#endif
ReflectSetOption, /* Set options. NULL'able */
ReflectGetOption, /* Get options. NULL'able */
ReflectWatch, /* Initialize notifier */
NULL, /* Get OS handle from the channel. NULL'able */
- ReflectClose2, /* No close2 support. NULL'able */
+ ReflectClose, /* No close2 support. NULL'able */
ReflectBlock, /* Set blocking/nonblocking. NULL'able */
NULL, /* Flush channel. Not used by core. NULL'able */
NULL, /* Handle events. NULL'able */
ReflectSeekWide, /* Move access point (64 bit). NULL'able */
-#ifdef TCL_THREADS
+#if TCL_THREADS
ReflectThread, /* thread action, tracking owner */
#else
- NULL, /* thread action */
+ NULL, /* thread action */
#endif
- NULL /* truncate */
+ ReflectTruncate /* Truncate. NULL'able */
};
/*
@@ -98,7 +106,7 @@ typedef struct {
* interpreter/thread containing its Tcl
* command is gone.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */
Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */
#endif
@@ -113,6 +121,17 @@ typedef struct {
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
+ Tcl_TimerToken readTimer; /*
+ A token for the timer that is scheduled in
+ order to call Tcl_NotifyChannel when the
+ channel is readable
+ */
+ Tcl_TimerToken writeTimer; /*
+ A token for the timer that is scheduled in
+ order to call Tcl_NotifyChannel when the
+ channel is writable
+ */
+
/*
* Note regarding the usage of timers.
*
@@ -122,11 +141,9 @@ typedef struct {
*
* See 'refchan', 'memchan', etc.
*
- * Here this is _not_ required. Interest in events is posted to the Tcl
- * level via 'watch'. And posting of events is possible from the Tcl level
- * as well, via 'chan postevent'. This means that the generation of all
- * events, fake or not, timer based or not, is completely in the hands of
- * the Tcl level. Therefore no timer here.
+ * A timer is used here as well in order to ensure at least on pass through
+ * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
+ * ef28eb1f1516.
*/
} ReflectedChannel;
@@ -171,6 +188,7 @@ static const char *const methodNames[] = {
"initialize", /* */
"read", /* OPT */
"seek", /* OPT */
+ "truncate", /* OPT */
"watch", /* */
"write", /* OPT */
NULL
@@ -184,6 +202,7 @@ typedef enum {
METH_INIT,
METH_READ,
METH_SEEK,
+ METH_TRUNCATE,
METH_WATCH,
METH_WRITE
} MethodName;
@@ -193,7 +212,8 @@ typedef enum {
(FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH))
#define NULLABLE_METHODS \
(FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \
- FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL))
+ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \
+ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE))
#define RANDW \
(TCL_READABLE | TCL_WRITABLE)
@@ -202,7 +222,7 @@ typedef enum {
#define NEGIMPL(a,b)
#define HAS(x,f) ((x) & FLAG(f))
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Thread specific types and structures.
*
@@ -223,7 +243,8 @@ typedef enum {
ForwardedBlock,
ForwardedSetOpt,
ForwardedGetOpt,
- ForwardedGetOptAll
+ ForwardedGetOptAll,
+ ForwardedTruncate
} ForwardedOperation;
/*
@@ -237,7 +258,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
int code; /* O: Ok/Fail of the cmd handler */
char *msgStr; /* O: Error message for handler failure */
int mustFree; /* O: True if msgStr is allocated, false if
@@ -253,13 +274,13 @@ typedef struct ForwardParamBase {
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
- int toRead; /* I: #bytes to read,
+ Tcl_Size toRead; /* I: #bytes to read,
* O: #bytes actually read */
};
struct ForwardParamOutput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
const char *buf; /* I: Where the bytes to write come from */
- int toWrite; /* I: #bytes to write,
+ Tcl_Size toWrite; /* I: #bytes to write,
* O: #bytes actually written */
};
struct ForwardParamSeek {
@@ -286,6 +307,10 @@ struct ForwardParamGetOpt {
const char *name; /* Name of option to get, maybe NULL */
Tcl_DString *value; /* Result */
};
+struct ForwardParamTruncate {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ Tcl_WideInt length; /* I: Length of file. */
+};
/*
* Now join all these together in a single union for convenience.
@@ -300,6 +325,7 @@ typedef union ForwardParam {
struct ForwardParamBlock block;
struct ForwardParamSetOpt setOpt;
struct ForwardParamGetOpt getOpt;
+ struct ForwardParamTruncate truncate;
} ForwardParam;
/*
@@ -312,7 +338,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
@@ -349,7 +375,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected channels owned by this thread. This is the
* per-thread version of the per-interpreter map.
@@ -382,7 +408,7 @@ TCL_DECLARE_MUTEX(rcForwardMutex)
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
-static void SrcExitProc(ClientData clientData);
+static void SrcExitProc(void *clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
@@ -409,7 +435,7 @@ static void SrcExitProc(ClientData clientData);
static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
static ReflectedChannelMap * GetThreadReflectedChannelMap(void);
-static void DeleteThreadReflectedChannelMap(ClientData clientData);
+static Tcl_ExitProc DeleteThreadReflectedChannelMap;
#endif /* TCL_THREADS */
@@ -436,8 +462,7 @@ static int InvokeTclMethod(ReflectedChannel *rcPtr,
Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
-static void DeleteReflectedChannelMap(ClientData clientData,
- Tcl_Interp *interp);
+static Tcl_InterpDeleteProc DeleteReflectedChannelMap;
static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj);
static void MarkDead(ReflectedChannel *rcPtr);
@@ -452,7 +477,7 @@ static const char *msg_read_toomuch = "{read delivered more than requested}";
static const char *msg_write_toomuch = "{write wrote more than requested}";
static const char *msg_write_nothing = "{write wrote nothing}";
static const char *msg_seek_beforestart = "{Tried to seek before origin}";
-#ifdef TCL_THREADS
+#if TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
#endif /* TCL_THREADS */
static const char *msg_send_dstlost = "{Owner lost}";
@@ -482,7 +507,7 @@ static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo
int
TclChanCreateObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -495,7 +520,7 @@ TclChanCreateObjCmd(
Tcl_Obj *cmdNameObj; /* Command name */
Tcl_Channel chan; /* Token for the new channel */
Tcl_Obj *modeObj; /* mode in obj form for method call */
- int listc; /* Result of 'initialize', and of */
+ Tcl_Size 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' */
@@ -508,7 +533,6 @@ TclChanCreateObjCmd(
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
- (void)dummy;
/*
* Syntax: chan create MODE CMDPREFIX
@@ -592,10 +616,10 @@ TclChanCreateObjCmd(
* Compare open mode against optional r/w.
*/
- if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -621,35 +645,35 @@ TclChanCreateObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"read\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"write\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -687,9 +711,14 @@ TclChanCreateObjCmd(
clonePtr->blockModeProc = NULL;
}
if (!(methods & FLAG(METH_SEEK))) {
+#ifndef TCL_NO_DEPRECATED
clonePtr->seekProc = NULL;
+#endif
clonePtr->wideSeekProc = NULL;
}
+ if (!(methods & FLAG(METH_TRUNCATE))) {
+ clonePtr->truncateProc = NULL;
+ }
chanPtr->typePtr = clonePtr;
}
@@ -708,7 +737,7 @@ TclChanCreateObjCmd(
Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
}
Tcl_SetHashValue(hPtr, chan);
-#ifdef TCL_THREADS
+#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName,
&isNew);
@@ -727,7 +756,7 @@ TclChanCreateObjCmd(
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
- ckfree((char*) rcPtr);
+ ckfree(rcPtr);
return TCL_ERROR;
#undef MODE
@@ -752,8 +781,8 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
-typedef struct ReflectEvent {
+#if TCL_THREADS
+typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
@@ -762,7 +791,7 @@ typedef struct ReflectEvent {
static int
ReflectEventRun(
Tcl_Event *ev,
- int flags)
+ TCL_UNUSED(int) /*flags*/)
{
/* OWNER thread
*
@@ -772,7 +801,6 @@ ReflectEventRun(
*/
ReflectEvent *e = (ReflectEvent *) ev;
- (void)flags;
Tcl_NotifyChannel(e->rcPtr->chan, e->events);
return 1;
@@ -781,7 +809,7 @@ ReflectEventRun(
static int
ReflectEventDelete(
Tcl_Event *ev,
- ClientData cd)
+ void *cd)
{
/* OWNER thread
*
@@ -801,7 +829,7 @@ ReflectEventDelete(
int
TclChanPostEventObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -830,7 +858,6 @@ TclChanPostEventObjCmd(
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)dummy;
/*
* Number of arguments...
@@ -854,7 +881,7 @@ TclChanPostEventObjCmd(
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can not find reflected channel named \"%s\"", chanId));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, (void *)NULL);
return TCL_ERROR;
}
@@ -926,11 +953,22 @@ TclChanPostEventObjCmd(
* We have the channel and the events to post.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
- Tcl_NotifyChannel(chan, events);
-#ifdef TCL_THREADS
+ if (events & TCL_READABLE) {
+ if (rcPtr->readTimer == NULL) {
+ rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ TimerRunRead, rcPtr);
+ }
+ }
+ if (events & TCL_WRITABLE) {
+ if (rcPtr->writeTimer == NULL) {
+ rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
+ TimerRunWrite, rcPtr);
+ }
+ }
+#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent));
@@ -961,8 +999,8 @@ TclChanPostEventObjCmd(
* XXX Actually, in that case the channel should be dead also !
*/
- Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(rcPtr->owner);
+ Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev,
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
}
#endif
@@ -977,6 +1015,24 @@ TclChanPostEventObjCmd(
#undef EVENT
}
+static void
+TimerRunRead(
+ void *clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->readTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
+}
+
+static void
+TimerRunWrite(
+ void *clientData)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ rcPtr->writeTimer = NULL;
+ Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
+}
+
/*
* Channel error message marshalling utilities.
*/
@@ -1006,10 +1062,10 @@ UnmarshallErrorResult(
Tcl_Interp *interp,
Tcl_Obj *msgObj)
{
- int lc;
+ Tcl_Size lc;
Tcl_Obj **lv;
int explicitResult;
- int numOptions;
+ Tcl_Size numOptions;
/*
* Process the caught message.
@@ -1021,7 +1077,7 @@ UnmarshallErrorResult(
* information; if we panic here, something has gone badly wrong already.
*/
- if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
@@ -1102,10 +1158,10 @@ TclChanCaughtErrorBypass(
/*
*----------------------------------------------------------------------
*
- * ReflectClose/ReflectClose2 --
+ * ReflectClose --
*
* This function is invoked when the channel is closed, to delete the
- * driver specific instance data.
+ * driver-specific instance data.
*
* Results:
* A Posix error.
@@ -1118,8 +1174,9 @@ TclChanCaughtErrorBypass(
static int
ReflectClose(
- ClientData clientData,
- Tcl_Interp *interp)
+ void *clientData,
+ Tcl_Interp *interp,
+ int flags)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
int result; /* Result code for 'close' */
@@ -1129,6 +1186,10 @@ ReflectClose(
Tcl_HashEntry *hPtr; /* Entry in the above map */
const Tcl_ChannelType *tctPtr;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
@@ -1146,7 +1207,7 @@ ReflectClose(
* if lost?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1167,10 +1228,16 @@ ReflectClose(
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
+ ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
- Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
+ if (rcPtr->readTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->readTimer);
+ }
+ if (rcPtr->writeTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->writeTimer);
+ }
+ Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return EOK;
}
@@ -1178,7 +1245,7 @@ ReflectClose(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1225,7 +1292,7 @@ ReflectClose(
Tcl_DeleteHashEntry(hPtr);
}
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
rcmPtr = GetThreadReflectedChannelMap();
hPtr = Tcl_FindHashEntry(&rcmPtr->map,
Tcl_GetChannelName(rcPtr->chan));
@@ -1236,24 +1303,18 @@ ReflectClose(
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
- ((Channel *)rcPtr->chan)->typePtr = NULL;
+ ckfree(tctPtr);
+ ((Channel *)rcPtr->chan)->typePtr = NULL;
+ }
+ if (rcPtr->readTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->readTimer);
+ }
+ if (rcPtr->writeTimer != NULL) {
+ Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
-
-static int
-ReflectClose2(
- ClientData clientData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return ReflectClose(clientData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -1273,14 +1334,14 @@ ReflectClose2(
static int
ReflectInput(
- ClientData clientData,
+ void *clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *toReadObj;
- int bytec; /* Number of returned bytes */
+ Tcl_Size bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
Tcl_Obj *resObj; /* Result data for 'read' */
@@ -1288,7 +1349,7 @@ ReflectInput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1308,7 +1369,7 @@ ReflectInput(
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
- p.input.toRead = -1;
+ p.input.toRead = TCL_INDEX_NONE;
} else {
*errorCodePtr = EOK;
}
@@ -1380,7 +1441,7 @@ ReflectInput(
static int
ReflectOutput(
- ClientData clientData,
+ void *clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -1394,7 +1455,7 @@ ReflectOutput(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1507,10 +1568,10 @@ ReflectOutput(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
ReflectSeekWide(
- ClientData clientData,
- Tcl_WideInt offset,
+ void *clientData,
+ long long offset,
int seekMode,
int *errorCodePtr)
{
@@ -1523,7 +1584,7 @@ ReflectSeekWide(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1548,7 +1609,7 @@ ReflectSeekWide(
Tcl_Preserve(rcPtr);
- offObj = Tcl_NewWideIntObj(offset);
+ TclNewIntObj(offObj, offset);
baseObj = Tcl_NewStringObj(
(seekMode == SEEK_SET) ? "start" :
(seekMode == SEEK_CUR) ? "current" : "end", -1);
@@ -1583,9 +1644,10 @@ ReflectSeekWide(
goto stop;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
- ClientData clientData,
+ void *clientData,
long offset,
int seekMode,
int *errorCodePtr)
@@ -1597,9 +1659,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1620,7 +1683,7 @@ ReflectSeek(
static void
ReflectWatch(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1646,7 +1709,7 @@ ReflectWatch(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1692,7 +1755,7 @@ ReflectWatch(
static int
ReflectBlock(
- ClientData clientData,
+ void *clientData,
int nonblocking)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1704,7 +1767,7 @@ ReflectBlock(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1740,7 +1803,7 @@ ReflectBlock(
return errorNum;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -1759,7 +1822,7 @@ ReflectBlock(
static void
ReflectThread(
- ClientData clientData,
+ void *clientData,
int action)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
@@ -1796,7 +1859,7 @@ ReflectThread(
static int
ReflectSetOption(
- ClientData clientData, /* Channel to query */
+ void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
@@ -1810,7 +1873,7 @@ ReflectSetOption(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1868,7 +1931,7 @@ ReflectSetOption(
static int
ReflectGetOption(
- ClientData clientData, /* Channel to query */
+ void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
@@ -1881,7 +1944,8 @@ ReflectGetOption(
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
- int listc, result = TCL_OK;
+ Tcl_Size listc;
+ int result = TCL_OK;
Tcl_Obj **listv;
MethodName method;
@@ -1889,9 +1953,9 @@ ReflectGetOption(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
- int opcode;
+ ForwardedOperation opcode;
ForwardParam p;
p.getOpt.name = optionName;
@@ -1962,7 +2026,7 @@ ReflectGetOption(
* result is a valid list. Nor that the list has an even number elements.
*/
- if (TclListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, resObj, &listc, &listv) != TCL_OK) {
goto error;
}
@@ -1974,12 +2038,12 @@ ReflectGetOption(
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
- "elements, got %d element%s instead", listc,
+ "elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
- int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ Tcl_Size len;
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
@@ -2003,6 +2067,73 @@ ReflectGetOption(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectTruncate --
+ *
+ * This function is invoked to truncate a channel's file size.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ReflectTruncate(
+ void *clientData, /* Channel to query */
+ long long length) /* Length to truncate to. */
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
+ Tcl_Obj *lenObj;
+ int errorNum; /* EINVAL or EOK (success). */
+ Tcl_Obj *resObj; /* Result for 'truncate' */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#if TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.truncate.length = length;
+
+ ForwardOpToHandlerThread(rcPtr, ForwardedTruncate, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rcPtr->chan, &p);
+ return EINVAL;
+ }
+
+ return EOK;
+ }
+#endif
+
+ /* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */
+
+ Tcl_Preserve(rcPtr);
+
+ lenObj = Tcl_NewWideIntObj(length);
+ Tcl_IncrRefCount(lenObj);
+
+ if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ errorNum = EINVAL;
+ } else {
+ errorNum = EOK;
+ }
+
+ Tcl_DecrRefCount(lenObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return errorNum;
+}
+
+/*
* Helpers. =========================================================
*/
@@ -2036,12 +2167,12 @@ EncodeEventMask(
int *mask)
{
int events; /* Mask of events to post */
- int listc; /* #elements in eventspec list */
+ Tcl_Size 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 (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2137,7 +2268,7 @@ NewReflectedChannel(
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
- MethodName mn = METH_BLOCKING;
+ int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
@@ -2146,17 +2277,18 @@ NewReflectedChannel(
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
-#ifdef TCL_THREADS
+ rcPtr->readTimer = 0;
+ rcPtr->writeTimer = 0;
+#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
- /* ASSERT: cmdpfxObj is a Tcl List */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
- while (mn <= METH_WRITE) {
+ while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
Tcl_NewStringObj(methodNames[mn++], -1));
}
@@ -2292,7 +2424,6 @@ InvokeTclMethod(
*/
cmd = TclListObjCopy(NULL, rcPtr->cmd);
-
Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj);
Tcl_ListObjAppendElement(NULL, cmd, methObj);
Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name);
@@ -2346,8 +2477,8 @@ InvokeTclMethod(
*/
if (result != TCL_ERROR) {
- int cmdLen;
- const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+ Tcl_Size cmdLen;
+ const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
@@ -2426,7 +2557,7 @@ ErrnoReturn(
if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK)
|| (code >= 0))) {
- if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) {
+ if (strcmp("EAGAIN", TclGetString(resObj)) == 0) {
code = -EAGAIN;
} else {
code = 0;
@@ -2463,8 +2594,7 @@ GetReflectedChannelMap(
if (rcmPtr == NULL) {
rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
- Tcl_SetAssocData(interp, RCMKEY,
- (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
+ Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr);
}
return rcmPtr;
}
@@ -2513,7 +2643,7 @@ MarkDead(
static void
DeleteReflectedChannelMap(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData;
@@ -2522,7 +2652,7 @@ DeleteReflectedChannelMap(
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
-#ifdef TCL_THREADS
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
@@ -2552,7 +2682,7 @@ DeleteReflectedChannelMap(
Tcl_DeleteHashTable(&rcmPtr->map);
ckfree(&rcmPtr->map);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
@@ -2635,10 +2765,12 @@ DeleteReflectedChannelMap(
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
+#else
+ (void)interp;
#endif
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2690,7 +2822,7 @@ GetThreadReflectedChannelMap(void)
static void
DeleteThreadReflectedChannelMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(void *))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
@@ -2698,7 +2830,6 @@ DeleteThreadReflectedChannelMap(
ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void)dummy;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2868,8 +2999,8 @@ ForwardOpToHandlerThread(
* Queue the event and poke the other thread's notifier.
*/
- Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(dst);
+ 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
@@ -2917,7 +3048,7 @@ ForwardOpToHandlerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
@@ -2946,7 +3077,6 @@ ForwardProc(
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)mask;
/*
* Ignore the event if no one is waiting for its result anymore.
@@ -3014,20 +3144,20 @@ ForwardProc(
} else {
ForwardSetObjError(paramPtr, resObj);
}
- paramPtr->input.toRead = -1;
+ paramPtr->input.toRead = TCL_IO_FAILURE;
} else {
/*
* Process a regular result.
*/
- int bytec; /* Number of returned bytes */
+ Tcl_Size bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
if (paramPtr->input.toRead < bytec) {
ForwardSetStaticError(paramPtr, msg_read_toomuch);
- paramPtr->input.toRead = -1;
+ paramPtr->input.toRead = TCL_IO_FAILURE;
} else {
if (bytec > 0) {
memcpy(paramPtr->input.buf, bytev, bytec);
@@ -3080,10 +3210,13 @@ ForwardProc(
}
case ForwardedSeek: {
- Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
- Tcl_Obj *baseObj = Tcl_NewStringObj(
- (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
- (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
+ Tcl_Obj *offObj;
+ Tcl_Obj *baseObj;
+
+ TclNewIntObj(offObj, paramPtr->seek.offset);
+ baseObj = Tcl_NewStringObj(
+ (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
+ (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
Tcl_IncrRefCount(offObj);
Tcl_IncrRefCount(baseObj);
@@ -3196,10 +3329,10 @@ ForwardProc(
* NOTE (4) as well.
*/
- int listc;
+ Tcl_Size listc;
Tcl_Obj **listv;
- if (TclListObjGetElements(interp, resObj, &listc,
+ if (TclListObjGetElementsM(interp, resObj, &listc,
&listv) != TCL_OK) {
Tcl_DecrRefCount(resObj);
resObj = MarshallError(interp);
@@ -3216,8 +3349,8 @@ ForwardProc(
ForwardSetDynamicError(paramPtr, buf);
} else {
- int len;
- const char *str = Tcl_GetStringFromObj(resObj, &len);
+ Tcl_Size len;
+ const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
@@ -3228,6 +3361,19 @@ ForwardProc(
Tcl_Release(rcPtr);
break;
+ case ForwardedTruncate: {
+ Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length);
+
+ Tcl_IncrRefCount(lenObj);
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(lenObj);
+ break;
+ }
+
default:
/*
* Bad operation code.
@@ -3264,7 +3410,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -3315,8 +3461,8 @@ ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
- int len;
- const char *msgStr = Tcl_GetStringFromObj(obj, &len);
+ Tcl_Size len;
+ const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index bc0e20c..75e2f96 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -10,7 +10,7 @@
*
* See TIP #230 for the specification of this functionality.
*
- * Copyright (c) 2007-2008 ActiveState.
+ * Copyright © 2007-2008 ActiveState.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,29 +31,29 @@
* Signatures of all functions used in the C layer of the reflection.
*/
-static int ReflectClose(ClientData clientData,
- Tcl_Interp *interp);
-static int ReflectClose2(ClientData clientData,
+static int ReflectClose(void *clientData,
Tcl_Interp *interp, int flags);
-static int ReflectInput(ClientData clientData, char *buf,
+static int ReflectInput(void *clientData, char *buf,
int toRead, int *errorCodePtr);
-static int ReflectOutput(ClientData clientData, const char *buf,
+static int ReflectOutput(void *clientData, const char *buf,
int toWrite, int *errorCodePtr);
-static void ReflectWatch(ClientData clientData, int mask);
-static int ReflectBlock(ClientData clientData, int mode);
-static Tcl_WideInt ReflectSeekWide(ClientData clientData,
- Tcl_WideInt offset, int mode, int *errorCodePtr);
-static int ReflectSeek(ClientData clientData, long offset,
+static void ReflectWatch(void *clientData, int mask);
+static int ReflectBlock(void *clientData, int mode);
+static long long ReflectSeekWide(void *clientData,
+ long long offset, int mode, int *errorCodePtr);
+#ifndef TCL_NO_DEPRECATED
+static int ReflectSeek(void *clientData, long offset,
int mode, int *errorCodePtr);
-static int ReflectGetOption(ClientData clientData,
+#endif
+static int ReflectGetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
-static int ReflectSetOption(ClientData clientData,
+static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
-static int ReflectHandle(ClientData clientData, int direction,
- ClientData *handle);
-static int ReflectNotify(ClientData clientData, int mask);
+static int ReflectHandle(void *clientData, int direction,
+ void **handle);
+static int ReflectNotify(void *clientData, int mask);
/*
* The C layer channel type/driver definition used by the reflection.
@@ -62,15 +62,19 @@ static int ReflectNotify(ClientData clientData, int mask);
static const Tcl_ChannelType tclRTransformType = {
"tclrtransform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel. */
- ReflectClose, /* Close channel, clean instance data. */
+ TCL_CLOSE2PROC, /* Close channel, clean instance data. */
ReflectInput, /* Handle read request. */
ReflectOutput, /* Handle write request. */
+#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. */
+#else
+ NULL, /* Move location of access point. */
+#endif
ReflectSetOption, /* Set options. */
ReflectGetOption, /* Get options. */
ReflectWatch, /* Initialize notifier. */
ReflectHandle, /* Get OS handle from the channel. */
- ReflectClose2, /* No close2 support. NULL'able. */
+ ReflectClose, /* No close2 support. NULL'able. */
ReflectBlock, /* Set blocking/nonblocking. */
NULL, /* Flush channel. Not used by core.
* NULL'able. */
@@ -125,7 +129,7 @@ typedef struct {
* in the argv, see below. The separate field
* gives us direct access, needed when working
* with the reflection maps. */
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
#endif
@@ -218,7 +222,7 @@ typedef enum {
#define NEGIMPL(a,b)
#define HAS(x,f) ((x) & FLAG(f))
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Thread specific types and structures.
*
@@ -251,7 +255,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
int code; /* O: Ok/Fail of the cmd handler */
char *msgStr; /* O: Error message for handler failure */
int mustFree; /* O: True if msgStr is allocated, false if
@@ -296,7 +300,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
@@ -327,7 +331,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected transformations owned by this thread.
*/
@@ -359,7 +363,7 @@ TCL_DECLARE_MUTEX(rtForwardMutex)
static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
-static void SrcExitProc(ClientData clientData);
+static void SrcExitProc(void *clientData);
#define FreeReceivedError(p) \
do { \
@@ -398,7 +402,7 @@ static void ForwardSetObjError(ForwardParam *p,
Tcl_Obj *objPtr);
static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
static void DeleteThreadReflectedTransformMap(
- ClientData clientData);
+ void *clientData);
#endif /* TCL_THREADS */
#define SetChannelErrorStr(c,msgStr) \
@@ -424,7 +428,7 @@ static int InvokeTclMethod(ReflectedTransform *rtPtr,
Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
static ReflectedTransformMap * GetReflectedTransformMap(Tcl_Interp *interp);
-static void DeleteReflectedTransformMap(ClientData clientData,
+static void DeleteReflectedTransformMap(void *clientData,
Tcl_Interp *interp);
/*
@@ -436,7 +440,7 @@ static void DeleteReflectedTransformMap(ClientData clientData,
static const char *msg_read_unsup = "{read not supported by Tcl driver}";
static const char *msg_write_unsup = "{write not supported by Tcl driver}";
-#ifdef TCL_THREADS
+#if TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
static const char *msg_send_dstlost = "{Owner lost}";
#endif /* TCL_THREADS */
@@ -454,7 +458,7 @@ static const char *msg_dstlost =
static void TimerKill(ReflectedTransform *rtPtr);
static void TimerSetup(ReflectedTransform *rtPtr);
-static void TimerRun(ClientData clientData);
+static void TimerRun(void *clientData);
static int TransformRead(ReflectedTransform *rtPtr,
int *errorCodePtr, Tcl_Obj *bufObj);
static int TransformWrite(ReflectedTransform *rtPtr,
@@ -499,7 +503,7 @@ static int TransformLimit(ReflectedTransform *rtPtr,
int
TclChanPushObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -526,7 +530,6 @@ TclChanPushObjCmd(
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
int isNew; /* Placeholder. */
- (void)dummy;
/*
* Syntax: chan push CHANNEL CMDPREFIX
@@ -553,7 +556,7 @@ TclChanPushObjCmd(
*/
chanObj = objv[CHAN];
- parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode);
+ parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode);
if (parentChan == NULL) {
return TCL_ERROR;
}
@@ -604,10 +607,10 @@ TclChanPushObjCmd(
* through the mask. Compare open mode against optional r/w.
*/
- if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -618,7 +621,7 @@ TclChanPushObjCmd(
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
- Tcl_GetString(cmdObj),
+ TclGetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
@@ -632,7 +635,7 @@ TclChanPushObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -654,7 +657,7 @@ TclChanPushObjCmd(
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -665,14 +668,14 @@ TclChanPushObjCmd(
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -693,14 +696,14 @@ TclChanPushObjCmd(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
#endif /* TCL_THREADS */
@@ -745,7 +748,7 @@ TclChanPushObjCmd(
int
TclChanPopObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -763,7 +766,6 @@ TclChanPopObjCmd(
const char *chanId; /* Tcl level channel handle */
Tcl_Channel chan; /* Channel associated to the handle */
int mode; /* Channel r/w mode */
- (void)dummy;
/*
* Number of arguments...
@@ -841,7 +843,7 @@ UnmarshallErrorResult(
* information; if we panic here, something has gone badly wrong already.
*/
- if (TclListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, msgObj, &lc, &lv) != TCL_OK) {
Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
}
if (interp == NULL) {
@@ -882,8 +884,9 @@ UnmarshallErrorResult(
static int
ReflectClose(
- ClientData clientData,
- Tcl_Interp *interp)
+ void *clientData,
+ Tcl_Interp *interp,
+ int flags)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int errorCode, errorCodeSet = 0;
@@ -894,6 +897,10 @@ ReflectClose(
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
@@ -911,7 +918,7 @@ ReflectClose(
* if lost?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -938,7 +945,7 @@ ReflectClose(
if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
if (!TransformDrain(rtPtr, &errorCode)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
FreeReflectedTransform);
@@ -952,7 +959,7 @@ ReflectClose(
if (HAS(rtPtr->methods, METH_FLUSH)) {
if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
Tcl_EventuallyFree(rtPtr,
FreeReflectedTransform);
@@ -968,7 +975,7 @@ ReflectClose(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -1025,9 +1032,9 @@ ReflectClose(
* under a channel by deleting the owning thread.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -1037,18 +1044,6 @@ ReflectClose(
Tcl_EventuallyFree(rtPtr, FreeReflectedTransform);
return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL);
}
-
-static int
-ReflectClose2(
- ClientData clientData,
- Tcl_Interp *interp,
- int flags)
-{
- if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) == 0) {
- return ReflectClose(clientData, interp);
- }
- return EINVAL;
-}
/*
*----------------------------------------------------------------------
@@ -1068,7 +1063,7 @@ ReflectClose2(
static int
ReflectInput(
- ClientData clientData,
+ void *clientData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -1261,7 +1256,7 @@ ReflectInput(
static int
ReflectOutput(
- ClientData clientData,
+ void *clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -1332,10 +1327,10 @@ ReflectOutput(
*----------------------------------------------------------------------
*/
-static Tcl_WideInt
+static long long
ReflectSeekWide(
- ClientData clientData,
- Tcl_WideInt offset,
+ void *clientData,
+ long long offset,
int seekMode,
int *errorCodePtr)
{
@@ -1343,18 +1338,6 @@ ReflectSeekWide(
Channel *parent = (Channel *) rtPtr->parent;
Tcl_WideInt curPos; /* Position on the device. */
- Tcl_DriverSeekProc *seekProc =
- Tcl_ChannelSeekProc(Tcl_GetChannelType(rtPtr->parent));
-
- /*
- * Fail if the parent channel is not seekable.
- */
-
- if (seekProc == NULL) {
- Tcl_SetErrno(EINVAL);
- return Tcl_LongAsWide(-1);
- }
-
/*
* Check if we can leave out involving the Tcl level, i.e. transformation
* handler. This is true for tell requests, and transformations which
@@ -1398,17 +1381,23 @@ ReflectSeekWide(
* non-NULL...
*/
- if (Tcl_ChannelWideSeekProc(parent->typePtr) != NULL) {
- curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
- seekMode, errorCodePtr);
- } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
- offset > Tcl_LongAsWide(LONG_MAX)) {
- *errorCodePtr = EOVERFLOW;
- curPos = Tcl_LongAsWide(-1);
+ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
+#ifndef TCL_NO_DEPRECATED
+ if (offset < LONG_MIN || offset > LONG_MAX) {
+ *errorCodePtr = EOVERFLOW;
+ curPos = -1;
+ } else {
+ curPos = Tcl_ChannelSeekProc(parent->typePtr)(
+ parent->instanceData, offset, seekMode,
+ errorCodePtr);
+ }
+#else
+ *errorCodePtr = EINVAL;
+ curPos = -1;
+#endif
} else {
- curPos = Tcl_LongAsWide(Tcl_ChannelSeekProc(parent->typePtr)(
- parent->instanceData, Tcl_WideAsLong(offset), seekMode,
- errorCodePtr));
+ curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
+ seekMode, errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
@@ -1419,9 +1408,10 @@ ReflectSeekWide(
return curPos;
}
+#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
- ClientData clientData,
+ void *clientData,
long offset,
int seekMode,
int *errorCodePtr)
@@ -1433,9 +1423,10 @@ ReflectSeek(
* routine.
*/
- return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
+ return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1456,7 +1447,7 @@ ReflectSeek(
static void
ReflectWatch(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1507,7 +1498,7 @@ ReflectWatch(
static int
ReflectBlock(
- ClientData clientData,
+ void *clientData,
int nonblocking)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1540,7 +1531,7 @@ ReflectBlock(
static int
ReflectSetOption(
- ClientData clientData, /* Channel to query */
+ void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
@@ -1582,7 +1573,7 @@ ReflectSetOption(
static int
ReflectGetOption(
- ClientData clientData, /* Channel to query */
+ void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
Tcl_DString *dsPtr) /* String to place the result into */
@@ -1631,9 +1622,9 @@ ReflectGetOption(
static int
ReflectHandle(
- ClientData clientData,
+ void *clientData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1667,7 +1658,7 @@ ReflectHandle(
static int
ReflectNotify(
- ClientData clientData,
+ void *clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -1762,7 +1753,7 @@ static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
- int mode,
+ TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
@@ -1770,7 +1761,6 @@ NewReflectedTransform(
int listc;
Tcl_Obj **listv;
int i;
- (void)mode;
rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform));
@@ -1779,7 +1769,7 @@ NewReflectedTransform(
rtPtr->chan = NULL;
rtPtr->methods = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
rtPtr->thread = Tcl_GetCurrentThread();
#endif
rtPtr->parent = parentChan;
@@ -1806,7 +1796,7 @@ NewReflectedTransform(
/* ASSERT: cmdpfxObj is a Tcl List */
- TclListObjGetElements(interp, cmdpfxObj, &listc, &listv);
+ TclListObjGetElementsM(interp, cmdpfxObj, &listc, &listv);
/*
* See [==] as well.
@@ -2056,7 +2046,7 @@ InvokeTclMethod(
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
int cmdLen;
- const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+ const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
@@ -2158,17 +2148,19 @@ GetReflectedTransformMap(
static void
DeleteReflectedTransformMap(
- ClientData clientData, /* The per-interpreter data structure. */
+ void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedTransformMap *rtmPtr; /* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedTransform *rtPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
+#else
+ (void)interp;
#endif /* TCL_THREADS */
/*
@@ -2195,7 +2187,7 @@ DeleteReflectedTransformMap(
Tcl_DeleteHashTable(&rtmPtr->map);
ckfree(&rtmPtr->map);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
@@ -2267,7 +2259,7 @@ DeleteReflectedTransformMap(
#endif /* TCL_THREADS */
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
*----------------------------------------------------------------------
*
@@ -2319,14 +2311,13 @@ GetThreadReflectedTransformMap(void)
static void
DeleteThreadReflectedTransformMap(
- ClientData dummy) /* The per-thread data structure. */
+ TCL_UNUSED(void *))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedTransformMap *rtmPtr; /* The map */
ForwardingResult *resultPtr;
- (void)dummy;
/*
* The origin thread for one or more reflected channels is gone.
@@ -2464,8 +2455,8 @@ ForwardOpToOwnerThread(
* Queue the event and poke the other thread's notifier.
*/
- Tcl_ThreadQueueEvent(dst, (Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(dst);
+ 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
@@ -2514,7 +2505,7 @@ ForwardOpToOwnerThread(
static int
ForwardProc(
Tcl_Event *evGPtr,
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
/*
* Notes regarding access to the referenced data.
@@ -2539,7 +2530,6 @@ ForwardProc(
/* Map of reflected channels with handlers in
* this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
- (void)mask;
/*
* Ignore the event if no one is waiting for its result anymore.
@@ -2583,7 +2573,7 @@ ForwardProc(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
/*
@@ -2593,7 +2583,7 @@ ForwardProc(
*/
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedTransformArgs(rtPtr);
@@ -2770,7 +2760,7 @@ ForwardProc(
static void
SrcExitProc(
- ClientData clientData)
+ void *clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
@@ -2822,7 +2812,7 @@ ForwardSetObjError(
Tcl_Obj *obj)
{
int len;
- const char *msgStr = Tcl_GetStringFromObj(obj, &len);
+ const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
@@ -2910,7 +2900,7 @@ TimerSetup(
static void
TimerRun(
- ClientData clientData)
+ void *clientData)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
@@ -2970,7 +2960,7 @@ ResultClear(
return;
}
- ckfree((char *) rPtr->buf);
+ ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
@@ -3103,7 +3093,7 @@ TransformRead(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3159,7 +3149,7 @@ TransformWrite(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3225,7 +3215,7 @@ TransformDrain(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3275,7 +3265,7 @@ TransformFlush(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3330,7 +3320,7 @@ TransformClear(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
@@ -3362,7 +3352,7 @@ TransformLimit(
* Are we in the correct thread?
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 6413960..eaa9cc8 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -3,7 +3,7 @@
*
* Common routines used by all socket based channel types.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -12,24 +12,30 @@
#include "tclInt.h"
#if defined(_WIN32)
-/* On Windows, we need to do proper Unicode->UTF-8 conversion. */
+/*
+ * On Windows, we need to do proper Unicode->UTF-8 conversion.
+ */
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
Tcl_DString errorMsg; /* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#undef gai_strerror
-static const char *gai_strerror(int code) {
+static const char *
+gai_strerror(
+ int code)
+{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
- Tcl_DStringFree(&tsdPtr->errorMsg);
+ Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
} else {
+ Tcl_DStringInit(&tsdPtr->errorMsg);
tsdPtr->initialized = 1;
}
- Tcl_WinTCharToUtf((TCHAR *)gai_strerrorW(code), -1, &tsdPtr->errorMsg);
+ Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif
@@ -56,8 +62,8 @@ static const char *gai_strerror(int code) {
int
TclSockGetPort(
Tcl_Interp *interp,
- const char *string, /* Integer or service name */
- const char *proto, /* "tcp" or "udp", typically */
+ const char *string, /* Integer or service name */
+ const char *proto, /* "tcp" or "udp", typically */
int *portPtr) /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
@@ -126,7 +132,7 @@ TclSockMinimumBuffers(
}
len = sizeof(int);
getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
- (char *) &current, &len);
+ (char *) &current, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
@@ -154,15 +160,15 @@ TclSockMinimumBuffers(
int
TclCreateSocketAddress(
- Tcl_Interp *interp, /* Interpreter for querying
- * the desired socket family */
- struct addrinfo **addrlist, /* Socket address list */
- const char *host, /* Host. NULL implies INADDR_ANY */
- int port, /* Port number */
- int willBind, /* Is this an address to bind() to or
- * to connect() to? */
- const char **errorMsgPtr) /* Place to store the error message
- * detail, if available. */
+ Tcl_Interp *interp, /* Interpreter for querying the desired socket
+ * family */
+ struct addrinfo **addrlist, /* Socket address list */
+ const char *host, /* Host. NULL implies INADDR_ANY */
+ int port, /* Port number */
+ int willBind, /* Is this an address to bind() to or to
+ * connect() to? */
+ const char **errorMsgPtr) /* Place to store the error message detail, if
+ * available. */
{
struct addrinfo hints;
struct addrinfo *p;
@@ -181,30 +187,31 @@ TclCreateSocketAddress(
* Workaround for OSX's apparent inability to resolve "localhost", "0"
* when the loopback device is the only available network interface.
*/
+
if (host != NULL && port == 0) {
- portstring = NULL;
+ portstring = NULL;
} else {
- TclFormatInt(portbuf, port);
- portstring = portbuf;
+ TclFormatInt(portbuf, port);
+ portstring = portbuf;
}
(void) memset(&hints, 0, sizeof(hints));
hints.ai_family = AF_UNSPEC;
/*
- * Magic variable to enforce a certain address family - to be superseded
- * by a TIP that adds explicit switches to [socket]
+ * Magic variable to enforce a certain address family; to be superseded
+ * by a TIP that adds explicit switches to [socket].
*/
if (interp != NULL) {
- family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0);
- if (family != NULL) {
- if (strcmp(family, "inet") == 0) {
- hints.ai_family = AF_INET;
- } else if (strcmp(family, "inet6") == 0) {
- hints.ai_family = AF_INET6;
- }
- }
+ family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0);
+ if (family != NULL) {
+ if (strcmp(family, "inet") == 0) {
+ hints.ai_family = AF_INET;
+ } else if (strcmp(family, "inet6") == 0) {
+ hints.ai_family = AF_INET6;
+ }
+ }
}
hints.ai_socktype = SOCK_STREAM;
@@ -214,7 +221,7 @@ TclCreateSocketAddress(
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
* localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
- * using AI_ADDRCONFIG in situations where it works, is probably low,
+ * using AI_ADDRCONFIG is probably low even in situations where it works,
* we'll leave it out for now. After all, it is just an optimisation.
*
* Missing on: OpenBSD, NetBSD.
@@ -251,6 +258,7 @@ TclCreateSocketAddress(
*
* There might be more elegant/efficient ways to do this.
*/
+
if (willBind) {
for (p = *addrlist; p != NULL; p = p->ai_next) {
if (p->ai_family == AF_INET) {
@@ -283,6 +291,38 @@ TclCreateSocketAddress(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenTcpServer --
+ *
+ * Opens a TCP server socket and creates a channel around it.
+ *
+ * Results:
+ * The channel or NULL if failed. If an error occurred, an error message
+ * is left in the interp's result if interp is not NULL.
+ *
+ * Side effects:
+ * Opens a server socket and creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_OpenTcpServer(
+ Tcl_Interp *interp,
+ int port,
+ const char *host,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+{
+ char portbuf[TCL_INTEGER_SPACE];
+
+ TclFormatInt(portbuf, port);
+ return Tcl_OpenTcpServerEx(interp, portbuf, host, -1,
+ TCL_TCPSERVER_REUSEADDR, acceptProc, callbackData);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index a4febaa..7719f35 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1,18 +1,15 @@
/*
* tclIOUtil.c --
*
- * This file contains the implementation of Tcl's generic filesystem
- * code, which supports a pluggable filesystem architecture allowing both
- * platform specific filesystems and 'virtual filesystems'. All
- * filesystem access should go through the functions defined in this
- * file. Most of this code was contributed by Vince Darley.
+ * Provides an interface for managing filesystems in Tcl, and also for
+ * creating a filesystem interface in Tcl arbitrary facilities. All
+ * filesystem operations are performed via this interface. Vince Darley
+ * is the primary author. Other signifiant contributors are Karl
+ * Lehenbauer, Mark Diekhans and Peter da Silva.
*
- * Parts of this file are based on code contributed by Karl Lehenbauer,
- * Mark Diekhans and Peter da Silva.
- *
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 2001-2004 Vincent Darley.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2001-2004 Vincent Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -33,42 +30,41 @@
/*
* struct FilesystemRecord --
*
- * A filesystem record is used to keep track of each filesystem currently
- * registered with the core, in a linked list.
+ * An item in a linked list of registered filesystems
*/
typedef struct FilesystemRecord {
- ClientData clientData; /* Client specific data for the new filesystem
+ ClientData clientData; /* Client-specific data for the filesystem
* (can be NULL) */
const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */
struct FilesystemRecord *nextPtr;
- /* The next filesystem registered to Tcl, or
- * NULL if no more. */
+ /* The next registered filesystem, or NULL to
+ * indicate the end of the list. */
struct FilesystemRecord *prevPtr;
- /* The previous filesystem registered to Tcl,
- * or NULL if no more. */
+ /* The previous filesystem, or NULL to indicate
+ * the ned of the list */
} FilesystemRecord;
/*
- * This structure holds per-thread private copy of the current directory
- * maintained by the global cwdPathPtr. This structure holds per-thread
- * private copies of some global data. This way we avoid most of the
- * synchronization calls which boosts performance, at cost of having to update
- * this information each time the corresponding epoch counter changes.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
- size_t cwdPathEpoch;
+ size_t cwdPathEpoch; /* Compared with the global cwdPathEpoch to
+ * determine whether cwdPathPtr is stale.
+ */
size_t filesystemEpoch;
- Tcl_Obj *cwdPathPtr;
+ Tcl_Obj *cwdPathPtr; /* A private copy of cwdPathPtr. Updated when
+ * the value is accessed and cwdPathEpoch has
+ * changed.
+ */
ClientData cwdClientData;
FilesystemRecord *filesystemList;
size_t claims;
} ThreadSpecificData;
/*
- * Prototypes for functions defined later in this file.
+ * Forward declarations.
*/
static Tcl_NRPostProc EvalFileCallback;
@@ -86,29 +82,12 @@ static void Disclaim(void);
static void * DivertFindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void DivertUnloadFile(Tcl_LoadHandle loadHandle);
-
-/*
- * These form part of the native filesystem support. They are needed here
- * because we have a few native filesystem functions (which are the same for
- * win/unix) in this file. There is no need to place them in tclInt.h, because
- * they are not (and should not be) used anywhere else.
- */
-
-MODULE_SCOPE const char *const tclpFileAttrStrings[];
-MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
/*
- * Declare the native filesystem support. These functions should be considered
- * private to Tcl, and should really not be called directly by any code other
- * than this file (i.e. neither by Tcl's core nor by extensions). Similarly,
- * the old string-based Tclp... native filesystem functions should not be
- * called.
- *
- * The correct API to use now is the Tcl_FS... set of functions, which ensure
- * correct and complete virtual filesystem support.
- *
- * We cannot make all of these static, since some of them are implemented in
- * the platform-specific directories.
+ * Functions that provide native filesystem support. They are private and
+ * should be used only here. They should be called instead of calling Tclp...
+ * native filesystem functions. Others should use the Tcl_FS... functions
+ * which ensure correct and complete virtual filesystem support.
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
@@ -118,12 +97,21 @@ static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
/*
- * The only reason these functions are not static is that they are either
- * called by code in the native (win/unix) directories or they are actually
- * implemented in those directories. They should simply not be called by code
- * outside Tcl's native filesystem core i.e. they should be considered
- * 'static' to Tcl's filesystem code (if we ever built the native filesystem
- * support into a separate code library, this could actually be enforced).
+ * Functions that support the native filesystem functions listed above. They
+ * are the same for win/unix, and not in tclInt.h because they are and should
+ * be used only here.
+ */
+
+MODULE_SCOPE const char *const tclpFileAttrStrings[];
+MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+
+
+/*
+ * These these functions are not static either because routines in the native
+ * (win/unix) directories call them or they are actually implemented in those
+ * directories. They should be called from outside Tcl's native filesystem
+ * routines. If we ever built the native filesystem support into a separate
+ * code library, this could actually be enforced.
*/
Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
@@ -143,11 +131,9 @@ Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
/*
- * Define the native filesystem dispatch table. If necessary, it is ok to make
- * this non-static, but it should only be accessed by the functions actually
- * listed within it (or perhaps other helper functions of them). Anything
- * which is not part of this 'native filesystem implementation' should not be
- * delving inside here!
+ * The native filesystem dispatch table. This could me made public but it
+ * should only be accessed by the functions it points to, or perhaps
+ * subordinate helper functions.
*/
const Tcl_Filesystem tclNativeFilesystem = {
@@ -190,13 +176,10 @@ const Tcl_Filesystem tclNativeFilesystem = {
};
/*
- * Define the tail of the linked list. Note that for unconventional uses of
- * Tcl without a native filesystem, we may in the future wish to modify the
- * current approach of hard-coding the native filesystem in the lookup list
- * 'filesystemList' below.
- *
- * We initialize the record so that it thinks one file uses it. This means it
- * will never be freed.
+ * An initial record in the linked list for the native filesystem. Remains at
+ * the tail of the list and is never freed. Currently the native filesystem is
+ * hard-coded. It may make sense to modify this to accommodate unconventional
+ * uses of Tcl that provide no native filesystem.
*/
static FilesystemRecord nativeFilesystemRecord = {
@@ -207,44 +190,42 @@ static FilesystemRecord nativeFilesystemRecord = {
};
/*
- * This is incremented each time we modify the linked list of filesystems. Any
- * time it changes, all cached filesystem representations are suspect and must
- * be freed. For multithreading builds, change of the filesystem epoch will
- * trigger cache cleanup in all threads.
+ * Incremented each time the linked list of filesystems is modified. For
+ * multithreaded builds, invalidates all cached filesystem internal
+ * representations.
*/
static size_t theFilesystemEpoch = 1;
/*
- * Stores the linked list of filesystems. A 1:1 copy of this list is also
- * maintained in the TSD for each thread. This is to avoid synchronization
- * issues.
+ * The linked list of filesystems. To minimize locking each thread maintains a
+ * local copy of this list.
+ *
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
- * Used to implement Tcl_FSGetCwd in a file-system independent way.
+ * A files-system indepent sense of the current directory.
*/
static Tcl_Obj *cwdPathPtr = NULL;
-static size_t cwdPathEpoch = 0;
+static size_t cwdPathEpoch = 0; /* The pathname of the current directory */
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
static Tcl_ThreadDataKey fsDataKey;
/*
- * One of these structures is used each time we successfully load a file from
- * a file system by way of making a temporary copy of the file on the native
- * filesystem. We need to store both the actual unloadProc/clientData
- * combination which was used, and the original and modified filenames, so
- * that we can correctly undo the entire operation when we want to unload the
- * code.
+ * When a temporary copy of a file is created on the native filesystem in order
+ * to load the file, an FsDivertLoad structure is created to track both the
+ * actual unloadProc/clientData combination which was used, and the original and
+ * modified filenames. This makes it possible to correctly undo the entire
+ * operation in order to unload the library.
*/
-typedef struct FsDivertLoad {
+typedef struct {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
@@ -253,14 +234,14 @@ typedef struct FsDivertLoad {
} FsDivertLoad;
/*
- * The following functions are obsolete string based APIs, and should be
- * removed in a future release (Tcl 9 would be a good time).
+ * Obsolete string-based APIs that should be removed in a future release,
+ * perhaps in Tcl 9.
*/
/* Obsolete */
int
Tcl_Stat(
- const char *path, /* Path of file to stat (in current CP). */
+ const char *path, /* Pathname of file to stat (in current CP). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
@@ -275,8 +256,8 @@ Tcl_Stat(
Tcl_WideInt tmp1, tmp2, tmp3 = 0;
# define OUT_OF_RANGE(x) \
- (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
- ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
+ (((Tcl_WideInt)(x)) < LONG_MIN || \
+ ((Tcl_WideInt)(x)) > LONG_MAX)
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
@@ -347,7 +328,8 @@ Tcl_Stat(
/* Obsolete */
int
Tcl_Access(
- const char *path, /* Path of file to access (in current CP). */
+ const char *path, /* Pathname of file to access (in current CP).
+ */
int mode) /* Permission setting. */
{
int ret;
@@ -363,13 +345,12 @@ Tcl_Access(
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
+ Tcl_Interp *interp, /* Interpreter for error reporting. May be
* NULL. */
- const char *path, /* Name of file to open. */
+ const char *path, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
+ int permissions) /* The modes to use if creating a new file. */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
@@ -413,9 +394,10 @@ Tcl_GetCwd(
int
Tcl_EvalFile(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- const char *fileName) /* Name of file to process. Tilde-substitution
- * will be performed on this name. */
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
+ const char *fileName) /* Pathname of the file containing the script.
+ * Performs Tilde-substitution on this
+ * pathaname. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
@@ -427,18 +409,18 @@ Tcl_EvalFile(
}
/*
- * Now move on to the basic filesystem implementation.
+ * The basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
- ThreadSpecificData *tsdPtr = cd;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/*
- * Trash the cwd copy.
+ * Discard the cwd copy.
*/
if (tsdPtr->cwdPathPtr != NULL) {
@@ -450,7 +432,7 @@ FsThrExitProc(
}
/*
- * Trash the filesystems cache.
+ * Discard the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
@@ -480,20 +462,20 @@ TclFSCwdIsNative(void)
*----------------------------------------------------------------------
*
* TclFSCwdPointerEquals --
- *
- * Check whether the current working directory is equal to the path
- * given.
+ * Determine whether the given pathname is equal to the current working
+ * directory.
*
* Results:
- * 1 (equal) or 0 (unequal) as appropriate.
+ * 1 if equal, 0 otherwise.
*
* Side effects:
- * If the paths are equal, but are not the same object, this method will
- * modify the given pathPtrPtr to refer to the same object. In this case
- * the object pointed to by pathPtrPtr will have its refCount
- * decremented, and it will be adjusted to point to the cwd (with a new
- * refCount).
+ * Updates TSD if needed.
*
+ * Stores a pointer to the current directory in *pathPtrPtr if it is not
+ * already there and the current directory is not NULL.
+ *
+ * If *pathPtrPtr is not null its reference count is decremented
+ * before it is replaced.
*----------------------------------------------------------------------
*/
@@ -542,12 +524,12 @@ TclFSCwdPointerEquals(
int len1, len2;
const char *str1, *str2;
- str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
+ str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
- * They are equal, but different objects. Update so they will be
- * the same object in the future.
+ * The values are equal but the objects are different. Cache the
+ * current structure in place of the old one.
*/
Tcl_DecrRefCount(*pathPtrPtr);
@@ -590,13 +572,13 @@ FsRecacheFilesystemList(void)
}
/*
- * Refill the cache honouring the order.
+ * Refill the cache, honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
- tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
+ tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
@@ -609,6 +591,7 @@ FsRecacheFilesystemList(void)
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
+
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
@@ -636,8 +619,8 @@ FsGetFirstFilesystem(void)
}
/*
- * The epoch can be changed by filesystems being added or removed, by changing
- * the "system encoding" and by env(HOME) changing.
+ * The epoch can is changed when a filesystems is added or removed, when
+ * "system encoding" changes, and when env(HOME) changes.
*/
int
@@ -670,10 +653,9 @@ TclFSEpoch(void)
return tsdPtr->filesystemEpoch;
}
-
/*
- * If non-NULL, clientData is owned by us and must be freed later.
+ * If non-NULL, take posession of clientData and free it later.
*/
static void
@@ -686,7 +668,7 @@ FsUpdateCwd(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
- str = Tcl_GetStringFromObj(cwdObj, &len);
+ str = TclGetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
@@ -702,7 +684,7 @@ FsUpdateCwd(
cwdClientData = NULL;
} else {
/*
- * This must be stored as string obj!
+ * This must be stored as a string obj!
*/
cwdPathPtr = Tcl_NewStringObj(str, len);
@@ -738,17 +720,17 @@ FsUpdateCwd(
*
* TclFinalizeFilesystem --
*
- * Clean up the filesystem. After this, calls to all Tcl_FS... functions
- * will fail.
+ * Clean up the filesystem. After this, any call to a Tcl_FS... function
+ * fails.
*
- * We will later call TclResetFilesystem to restore the FS to a pristine
- * state.
+ * If TclResetFilesystem is called later, it restores the filesystem to a
+ * pristine state.
*
* Results:
* None.
*
* Side effects:
- * Frees any memory allocated by the filesystem.
+ * Frees memory allocated for the filesystem.
*
*----------------------------------------------------------------------
*/
@@ -759,8 +741,9 @@ TclFinalizeFilesystem(void)
FilesystemRecord *fsRecPtr;
/*
- * Assumption that only one thread is active now. Otherwise we would need
- * to put various mutexes around this code.
+ * Assume that only one thread is active. Otherwise mutexes would be needed
+ * around this code.
+ * TO DO: This assumption is false, isn't it?
*/
if (cwdPathPtr != NULL) {
@@ -778,11 +761,14 @@ TclFinalizeFilesystem(void)
* needed.
*/
+ TclZipfsFinalize();
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
- /* The native filesystem is static, so we don't free it. */
+ /*
+ * The native filesystem is static, so don't free it.
+ */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
@@ -795,8 +781,8 @@ TclFinalizeFilesystem(void)
filesystemList = NULL;
/*
- * Now filesystemList is NULL. This means that any attempt to use the
- * filesystem is likely to fail.
+ * filesystemList is now NULL. Any attempt to use the filesystem is likely
+ * to fail.
*/
#ifdef _WIN32
@@ -827,15 +813,6 @@ TclResetFilesystem(void)
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
-
-#ifdef _WIN32
- /*
- * Cleans up the win32 API filesystem proc lookup table. This must happen
- * very late in finalization so that deleting of copied dlls can occur.
- */
-
- TclWinResetInterfaces();
-#endif
}
/*
@@ -843,34 +820,31 @@ TclResetFilesystem(void)
*
* Tcl_FSRegister --
*
- * Insert the filesystem function table at the head of the list of
- * functions which are used during calls to all file-system operations.
- * The filesystem will be added even if it is already in the list. (You
- * can use Tcl_FSData to check if it is in the list, provided the
- * ClientData used was not NULL).
- *
- * Note that the filesystem handling is head-to-tail of the list. Each
- * filesystem is asked in turn whether it can handle a particular
- * request, until one of them says 'yes'. At that point no further
- * filesystems are asked.
+ * Prepends to the list of registered fileystems a new FilesystemRecord
+ * for the given Tcl_Filesystem, which is added even if it is already in
+ * the list. To determine whether the filesystem is already in the list,
+ * use Tcl_FSData().
*
- * In particular this means if you want to add a diagnostic filesystem
- * (which simply reports all fs activity), it must be at the head of the
- * list: i.e. it must be the last registered.
+ * Functions that use the list generally process it from head to tail and
+ * use the first filesystem that is suitable. Therefore, when adding a
+ * diagnostic filsystem (one which simply reports all fs activity), it
+ * must be at the head of the list. I.e. it must be the last one
+ * registered.
*
* Results:
- * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could
+ * TCL_OK, or TCL_ERROR if memory for a new node in the list could
* not be allocated.
*
* Side effects:
- * Memory allocated and modifies the link list for filesystems.
+ * Allocates memory for a filesystem record and modifies the list of
+ * registered filesystems.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(
- ClientData clientData, /* Client specific data for this fs. */
+ ClientData clientData, /* Client-specific data for this filesystem. */
const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
@@ -879,24 +853,11 @@ Tcl_FSRegister(
return TCL_ERROR;
}
- newFilesystemPtr = ckalloc(sizeof(FilesystemRecord));
+ newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
- /*
- * Is this lock and wait strictly speaking necessary? Since any iterators
- * out there will have grabbed a copy of the head of the list and be
- * iterating away from that, if we add a new element to the head of the
- * list, it can't possibly have any effect on any of their loops. In fact
- * it could be better not to wait, since we are adjusting the filesystem
- * epoch, any cached representations calculated by existing iterators are
- * going to have to be thrown away anyway.
- *
- * However, since registering and unregistering filesystems is a very rare
- * action, this is not a very important point.
- */
-
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
@@ -907,7 +868,7 @@ Tcl_FSRegister(
filesystemList = newFilesystemPtr;
/*
- * Increment the filesystem epoch counter, since existing paths might
+ * Increment the filesystem epoch counter since existing pathnames might
* conceivably now belong to different filesystems.
*/
@@ -924,28 +885,26 @@ Tcl_FSRegister(
*
* Tcl_FSUnregister --
*
- * Remove the passed filesystem from the list of filesystem function
- * tables. It also ensures that the built-in (native) filesystem is not
- * removable, although we may wish to change that decision in the future
- * to allow a smaller Tcl core, in which the native filesystem is not
- * used at all (we could, say, initialise Tcl completely over a network
- * connection).
+ * Removes the record for given filesystem from the list of registered
+ * filesystems. Refuses to remove the built-in (native) filesystem. This
+ * might be changed in the future to allow a smaller Tcl core in which the
+ * native filesystem is not used at all, e.g. initializing Tcl over a
+ * network connection.
*
* Results:
- * TCL_OK if the function pointer was successfully removed, TCL_ERROR
+ * TCL_OK if the function pointer was successfully removed, or TCL_ERROR
* otherwise.
*
* Side effects:
- * Memory may be deallocated (or will be later, once no "path" objects
- * refer to this filesystem), but the list of registered filesystems is
- * updated immediately.
+ * The list of registered filesystems is updated. Memory for the
+ * corresponding FilesystemRecord is eventually freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnregister(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
+ const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -953,9 +912,9 @@ Tcl_FSUnregister(
Tcl_MutexLock(&filesystemMutex);
/*
- * Traverse the 'filesystemList' looking for the particular node whose
- * 'fsPtr' member matches 'fsPtr' and remove that one from the list.
- * Ensure that the "default" node cannot be removed.
+ * Traverse filesystemList in search of the record whose
+ * 'fsPtr' member matches 'fsPtr' and remove that record from the list.
+ * Do not revmoe the record for the native filesystem.
*/
fsRecPtr = filesystemList;
@@ -971,11 +930,9 @@ Tcl_FSUnregister(
}
/*
- * Increment the filesystem epoch counter, since existing paths
- * might conceivably now belong to different filesystems. This
- * should also ensure that paths which have cached the filesystem
- * which is about to be deleted do not reference that filesystem
- * (which would of course lead to memory exceptions).
+ * Each cached pathname could now belong to a different filesystem,
+ * so increment the filesystem epoch counter to ensure that cached
+ * information about the removed filesystem is not used.
*/
if (++theFilesystemEpoch == 0) {
@@ -999,52 +956,37 @@ Tcl_FSUnregister(
*
* Tcl_FSMatchInDirectory --
*
- * This routine is used by the globbing code to search a directory for
- * all files which match a given pattern. The appropriate function for
- * the filesystem to which pathPtr belongs will be called. If pathPtr
- * does not belong to any filesystem and if it is NULL or the empty
- * string, then we assume the pattern is to be matched in the current
- * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for
- * each filesystem from having to deal with this issue, we create a
- * pathPtr on the fly (equal to the cwd), and then remove it from the
- * results returned. This makes filesystems easy to write, since they can
- * assume the pathPtr passed to them is an ordinary path. In fact this
- * means we could remove such special case handling from Tcl's native
- * filesystems.
- *
- * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified
- * path of a single file/directory which must be checked for existence
- * and correct type.
+ * Search in the given pathname for files matching the given pattern.
+ * Used by [glob]. Processes just one pattern for one directory. Callers
+ * such as TclGlob and DoGlob implement manage the searching of multiple
+ * directories in cases such as
+ * glob -dir $dir -join * pkgIndex.tcl
*
* Results:
*
- * The return value is a standard Tcl result indicating whether an error
- * occurred in globbing. Error messages are placed in interp, but good
- * results are placed in the resultPtr given.
- *
- * Recursive searches, e.g.
- * glob -dir $dir -join * pkgIndex.tcl
- * which must recurse through each directory matching '*' are handled
- * internally by Tcl, by passing specific flags in a modified 'types'
- * parameter. This means the actual filesystem only ever sees patterns
- * which match in a single directory.
+ * TCL_OK, or TCL_ERROR
*
* Side effects:
- * The interpreter may have an error message inserted into it.
+ * resultPtr is populated, or in the case of an TCL_ERROR, an error message is
+ * set in the interpreter.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(
- Tcl_Interp *interp, /* Interpreter to receive error messages, but
- * may be NULL. */
- Tcl_Obj *resultPtr, /* List object to receive results. */
- Tcl_Obj *pathPtr, /* Contains path to directory to search. */
- const char *pattern, /* Pattern to match against. */
- Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. In particular the directory
- * flag is very important. */
+ Tcl_Interp *interp, /* Interpreter to receive error messages, or
+ * NULL */
+ Tcl_Obj *resultPtr, /* List that results are added to. */
+ Tcl_Obj *pathPtr, /* Pathname of directory to search. If NULL,
+ * the current working directory is used. */
+ const char *pattern, /* Pattern to match. If NULL, pathPtr must be
+ * a fully-specified pathname of a single
+ * file/directory which already exists and is
+ * 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;
@@ -1052,10 +994,10 @@ Tcl_FSMatchInDirectory(
if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
/*
- * We don't currently allow querying of mounts by external code (a
- * valuable future step), so since we're the only function that
- * actually knows about mounts, this means we're being called
- * recursively by ourself. Return no matches.
+ * 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.
*/
return TCL_OK;
@@ -1067,12 +1009,11 @@ Tcl_FSMatchInDirectory(
fsPtr = NULL;
}
- /*
- * Check if we've successfully mapped the path to a filesystem within
- * which to search.
- */
-
if (fsPtr != NULL) {
+ /*
+ * A corresponding filesystem was found. Search within it.
+ */
+
if (fsPtr->matchInDirectoryProc == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
@@ -1085,24 +1026,21 @@ Tcl_FSMatchInDirectory(
return ret;
}
- /*
- * If the path isn't empty, we have no idea how to match files in a
- * directory which belongs to no known filesystem.
- */
-
if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
+ /*
+ * There is a pathname but it belongs to no known filesystem. Mayday!
+ */
+
Tcl_SetErrno(ENOENT);
return -1;
}
/*
- * We have an empty or NULL path. This is defined to mean we must search
- * for files within the current 'cwd'. We therefore use that, but then
- * since the proc we call will return results which include the cwd we
- * must then trim it off the front of each path in the result. We choose
- * to deal with this here (in the generic code), since if we don't, every
- * single filesystem's implementation of Tcl_FSMatchInDirectory will have
- * to deal with it for us.
+ * The pathname is empty or NULL so search in the current working
+ * directory. matchInDirectoryProc prefixes each result with this
+ * directory, so trim it from each result. Deal with this here in the
+ * generic code because otherwise every filesystem implementation of
+ * Tcl_FSMatchInDirectory has to do it.
*/
cwd = Tcl_FSGetCwd(NULL);
@@ -1125,10 +1063,10 @@ Tcl_FSMatchInDirectory(
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
- * Note that we know resultPtr and tmpResultPtr are distinct.
+ * resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
- ret = TclListObjGetElements(interp, tmpResultPtr,
+ ret = TclListObjGetElementsM(interp, tmpResultPtr,
&resLength, &elemsPtr);
for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
@@ -1145,30 +1083,28 @@ Tcl_FSMatchInDirectory(
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
- *
- * This routine is used by the globbing code to take the results of a
- * directory listing and add any mounted paths to that listing. This is
- * required so that simple things like 'glob *' merge mounts and listings
- * correctly.
+ * Adds any mounted pathnames to a set of results so that simple things
+ * like 'glob *' merge mounts and listings correctly. Used by the
+ * Tcl_FSMatchInDirectory.
*
* Results:
* None.
*
* Side effects:
- * Modifies the resultPtr.
+ * Stores a result in resultPtr.
*
*----------------------------------------------------------------------
*/
static void
FsAddMountsToGlobResult(
- Tcl_Obj *resultPtr, /* The current list of matching paths; must
- * not be shared! */
- Tcl_Obj *pathPtr, /* The directory in question. */
- const char *pattern, /* Pattern to match against. */
- Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. In particular the directory
- * flag is very important. */
+ Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must
+ * 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.
+ */
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
@@ -1178,10 +1114,10 @@ FsAddMountsToGlobResult(
return;
}
- if (TclListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
+ if (TclListObjLengthM(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
- if (TclListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
+ if (TclListObjLengthM(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i=0 ; i<mLength ; i++) {
@@ -1213,17 +1149,17 @@ FsAddMountsToGlobResult(
int len, mlen;
/*
- * We know mElt is absolute normalized and lies inside pathPtr, so
- * now we must add to the result the right representation of mElt,
- * i.e. the representation which is relative to pathPtr.
+ * mElt is normalized and lies inside pathPtr so
+ * add to the result the right representation of mElt,
+ * i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
- mount = Tcl_GetStringFromObj(mElt, &mlen);
- path = Tcl_GetStringFromObj(norm, &len);
+ mount = TclGetStringFromObj(mElt, &mlen);
+ path = TclGetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
@@ -1231,13 +1167,14 @@ FsAddMountsToGlobResult(
len--;
}
- len++; /* account for '/' in the mElt [Bug 1602539] */
+ len++; /* account for '/' in the mElt [Bug 1602539] */
+
+
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
/*
- * No need to increment gLength, since we don't want to compare
- * mounts against mounts.
+ * Not comparing mounts to mounts, so no need to increment gLength
*/
}
}
@@ -1251,63 +1188,56 @@ FsAddMountsToGlobResult(
*
* Tcl_FSMountsChanged --
*
- * Notify the filesystem that the available mounted filesystems (or
- * within any one filesystem type, the number or location of mount
- * points) have changed.
+ * Announecs that mount points have changed or that the system encoding
+ * has changed.
*
* Results:
* None.
*
* Side effects:
- * The global filesystem variable 'theFilesystemEpoch' is incremented.
- * The effect of this is to make all cached path representations invalid.
- * Clearly it should only therefore be called when it is really required!
- * There are a few circumstances when it should be called:
+ * The shared 'theFilesystemEpoch' is incremented, invalidating every
+ * exising cached internal representation of a pathname. Avoid calling
+ * Tcl_FSMountsChanged whenever possible. It must be called when:
*
- * (1) when a new filesystem is registered or unregistered. Strictly
- * speaking this is only necessary if the new filesystem accepts file
- * paths as is (normally the filesystem itself is really a shell which
- * hasn't yet had any mount points established and so its
- * 'pathInFilesystem' proc will always fail). However, for safety, Tcl
- * always calls this for you in these circumstances.
+ * (1) A filesystem is registered or unregistered. This is only necessary
+ * if the new filesystem accepts file pathnames as-is. Normally the
+ * filesystem is really a shell which doesn't yet have any mount points
+ * established and so its 'pathInFilesystem' routine always fails.
+ * However, for safety, Tcl calls 'Tcl_FSMountsChanged' each time a
+ * filesystem is registered or unregistered.
*
- * (2) when additional mount points are established inside any existing
- * filesystem (except the native fs)
+ * (2) An additional mount point is established inside an existing
+ * filesystem (except for the native file system; see note below).
*
- * (3) when any filesystem (except the native fs) changes the list of
- * available volumes.
+ * (3) A filesystem changes the list of available volumes (except for the
+ * native file system; see note below).
*
- * (4) when the mapping from a string representation of a file to a full,
- * normalized path changes. For example, if 'env(HOME)' is modified, then
- * any path containing '~' will map to a different filesystem location.
- * Therefore all such paths need to have their internal representation
- * invalidated.
+ * (4) The mapping from a string representation of a file to a full,
+ * normalized pathname changes. For example, if 'env(HOME)' is modified,
+ * then any pathname containing '~' maps to a different item, possibly in
+ * a different filesystem.
*
- * Tcl has no control over (2) and (3), so any registered filesystem must
- * make sure it calls this function when those situations occur.
+ * Tcl has no control over (2) and (3), so each registered filesystem must
+ * call Tcl_FSMountsChnaged in each of those circumstances.
*
- * (Note: the reason for the exception in 2,3 for the native filesystem
- * is that the native filesystem by default claims all unknown files even
- * if it really doesn't understand them or if they don't exist).
+ * 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.
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(
- const Tcl_Filesystem *fsPtr)
-{
+ TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/)
/*
- * We currently don't do anything with this parameter. We could in the
- * future only invalidate files for this filesystem or otherwise take more
- * advanced action.
+ * fsPtr is currently unused. In the future it might invalidate files for
+ * a particular filesystem, or take some other more advanced action.
*/
-
- (void)fsPtr;
-
+{
/*
- * Increment the filesystem epoch counter, since existing paths might now
- * belong to different filesystems.
+ * Increment the filesystem epoch to invalidate every existing cached
+ * internal representation.
*/
Tcl_MutexLock(&filesystemMutex);
@@ -1322,13 +1252,11 @@ Tcl_FSMountsChanged(
*
* Tcl_FSData --
*
- * Retrieve the clientData field for the filesystem given, or NULL if
- * that filesystem is not registered.
+ * Retrieves the clientData member of the given filesystem.
*
* Results:
- * A clientData value, or NULL. Note that if the filesystem was
- * registered with a NULL clientData field, this function will return
- * that NULL value.
+ * A clientData value, or NULL if the given filesystem is not registered.
+ * The clientData value itself may also be NULL.
*
* Side effects:
* None.
@@ -1338,15 +1266,14 @@ Tcl_FSMountsChanged(
ClientData
Tcl_FSData(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to query. */
+ const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of
+ * registered filesystems. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
- * Traverse the list of filesystems look for a particular one. If found,
- * return that filesystem's clientData (originally provided when calling
- * Tcl_FSRegister).
+ * Find the filesystem in and retrieve its clientData.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
@@ -1364,27 +1291,24 @@ Tcl_FSData(
*
* TclFSNormalizeToUniquePath --
*
- * Takes a path specification containing no ../, ./ sequences, and
- * converts it into a unique path for the given platform. On Unix, this
- * means the path must be free of symbolic links/aliases, and on Windows
- * it means we want the long form, with that long form's case-dependence
- * (which gives us a unique, case-dependent path).
+ * Converts the given pathname, containing no ../, ./ components, into a
+ * unique pathname for the given platform. On Unix the resulting pathname
+ * is free of symbolic links/aliases, and on Windows it is the long
+ * case-preserving form.
+ *
*
* Results:
- * The pathPtr is modified in place. The return value is the last byte
- * offset which was recognised in the path string.
+ * Stores the resulting pathname in pathPtr and returns the offset of the
+ * last byte processed in pathPtr.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special notes:
- * If the filesystem-specific normalizePathProcs can re-introduce ../, ./
- * sequences into the path, then this function will not return the
- * correct result. This may be possible with symbolic links on Unix.
+ * If the filesystem-specific normalizePathProcs can reintroduce ../, ./
+ * components into the pathname, this function does not return the correct
+ * result. This may be possible with symbolic links on unix.
*
- * Important assumption: if startAt is non-zero, it must point to a
- * directory separator that we know exists and is already normalized (so
- * it is important not to point to the char just after the separator).
*
*---------------------------------------------------------------------------
*/
@@ -1392,44 +1316,79 @@ Tcl_FSData(
int
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
- Tcl_Obj *pathPtr, /* The path to normalize in place. */
- int startAt) /* Start at this char-offset. */
+ Tcl_Obj *pathPtr, /* An Pathname to normalize in-place. Must be
+ * unshared. */
+ int startAt) /* Offset the string of pathPtr to start at.
+ * Must either be 0 or offset of a directory
+ * separator at the end of a pathname part that
+ * is already normalized, I.e. not the index of
+ * the byte just after the separator. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
+ int i;
+ int isVfsPath = 0;
+ const char *path;
+
/*
- * Call each of the "normalise path" functions in succession. This is a
- * special case, in which if we have a native filesystem handler, we call
- * it first. This is because the root of Tcl's filesystem is always a
- * native filesystem (i.e. '/' on Unix is native).
+ * Pathnames starting with a UNC prefix and ending with a colon character
+ * are reserved for VFS use. These names can not conflict with real UNC
+ * pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
+ * rfc3986's definition of reg-name.
+ *
+ * We check these first to avoid useless calls to the native filesystem's
+ * normalizePathProc.
*/
+ path = TclGetStringFromObj(pathPtr, &i);
+ if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/')
+ || (path[0] == '\\' && path[1] == '\\') ) ) {
+ for ( i = 2; ; i++) {
+ if (path[i] == '\0') break;
+ if (path[i] == path[0]) break;
+ }
+ --i;
+ if (path[i] == ':') isVfsPath = 1;
+ }
+
+ /*
+ * Call the the normalizePathProc routine of each registered filesystem.
+ */
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
- for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- continue;
- }
+
+ if (!isVfsPath) {
/*
- * TODO: Assume that we always find the native file system; it should
- * always be there...
+ * Find and call the native filesystem handler first if there is one
+ * because the root of Tcl's filesystem is always a native filesystem
+ * (i.e., '/' on unix is native).
*/
- if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
- startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
- startAt);
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
+ continue;
+ }
+
+ /*
+ * TODO: Always call the normalizePathProc here because it should
+ * always exist.
+ */
+
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
+ }
+ break;
}
- break;
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- /*
- * Skip the native system next time through.
- */
-
if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
+ /*
+ * Skip the native system this time through.
+ */
continue;
}
@@ -1439,7 +1398,7 @@ TclFSNormalizeToUniquePath(
}
/*
- * We could add an efficiency check like this:
+ * This efficiency check could be added:
* if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
@@ -1454,26 +1413,27 @@ TclFSNormalizeToUniquePath(
*
* TclGetOpenMode --
*
- * This routine is an obsolete, limited version of TclGetOpenModeEx()
- * below. It exists only to satisfy any extensions imprudently using it
- * via Tcl's internal stubs table.
+ * Obsolete. A limited version of TclGetOpenModeEx() which exists only to
+ * satisfy any extensions imprudently using it via Tcl's internal stubs
+ * table.
*
* Results:
- * Same as TclGetOpenModeEx().
+ * See TclGetOpenModeEx().
*
* Side effects:
- * Same as TclGetOpenModeEx().
+ * See TclGetOpenModeEx().
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(
- Tcl_Interp *interp, /* Interpreter to use for error reporting -
- * may be NULL. */
- const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
- int *seekFlagPtr) /* Set this to 1 if the caller should seek to
- * EOF during the opening of the file. */
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. May
+ * be NULL. */
+ const char *modeString, /* e.g. "r+" or "RDONLY CREAT". */
+ int *seekFlagPtr) /* Sets this to 1 to tell the caller to seek to
+ EOF after opening the file, and
+ * 0 otherwise. */
{
int binary = 0;
return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
@@ -1484,46 +1444,44 @@ TclGetOpenMode(
*
* TclGetOpenModeEx --
*
- * Computes a POSIX mode mask for opening a file, from a given string,
- * and also sets flags to indicate whether the caller should seek to EOF
- * after opening the file, and whether the caller should configure the
- * channel for binary data.
+ * Computes a POSIX mode mask for opening a file.
*
* Results:
- * On success, returns mode to pass to "open". If an error occurs, the
- * return value is -1 and if interp is not NULL, sets interp's result
- * object to an error message.
+ * The mode to pass to "open", or -1 if an error occurs.
*
* Side effects:
- * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to
- * seek to EOF after opening the file, or to 0 otherwise. Sets the
- * integer referenced by binaryPtr to 1 to tell the caller to seek to
- * configure the channel for binary data, or to 0 otherwise.
+ * Sets *seekFlagPtr to 1 to tell the caller to
+ * seek to EOF after opening the file, or to 0 otherwise.
+ *
+ * Sets *binaryPtr to 1 to tell the caller to configure the channel as a
+ * binary channel, or to 0 otherwise.
+ *
+ * If there is an error and interp is not NULL, sets interpreter result to
+ * an error message.
*
* Special note:
- * This code is based on a prototype implementation contributed by Mark
- * Diekhans.
+ * Based on a prototype implementation contributed by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenModeEx(
- Tcl_Interp *interp, /* Interpreter to use for error reporting -
- * may be NULL. */
+ Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for
+ * error reporting. */
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
- int *seekFlagPtr, /* Set this to 1 if the caller should seek to
- * EOF during the opening of the file. */
- int *binaryPtr) /* Set this to 1 if the caller should
- * configure the opened channel for binary
- * operations. */
+ 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, modeArgc, c, i, gotRW;
const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
- * Check for the simpler fopen-like access modes (e.g. "r"). They are
+ * 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.
*/
@@ -1533,8 +1491,7 @@ TclGetOpenModeEx(
mode = 0;
/*
- * Guard against international characters before using byte oriented
- * routines.
+ * Guard against wide characters before using byte-oriented routines.
*/
if (!(modeString[0] & 0x80)
@@ -1548,7 +1505,7 @@ TclGetOpenModeEx(
break;
case 'a':
/*
- * Added O_APPEND for proper automatic seek-to-end-on-write by the
+ * Add O_APPEND for proper automatic seek-to-end-on-write by the
* OS. [Bug 680143]
*/
@@ -1566,8 +1523,8 @@ TclGetOpenModeEx(
switch (modeString[i++]) {
case '+':
/*
- * Must remove the O_APPEND flag so that the seek command
- * works. [Bug 1773127]
+ * Remove O_APPEND so that the seek command works. [Bug
+ * 1773127]
*/
mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
@@ -1596,11 +1553,9 @@ TclGetOpenModeEx(
}
/*
- * The access modes are specified using a list of POSIX modes such as
- * O_CREAT.
+ * The access modes are specified as a list of POSIX modes like O_CREAT.
*
- * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL
- * interpreter is passed in.
+ * Tcl_SplitList must work correctly when interp is NULL.
*/
if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
@@ -1695,8 +1650,10 @@ TclGetOpenModeEx(
*
* Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
- * Read in a file and process the entire file as one gigantic Tcl
- * command. Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
+ * Reads a file and evaluates it as a script.
+ *
+ * Tcl_FSEvalFile is Tcl_FSEvalFileEx without the encoding argument.
+ *
* TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
@@ -1704,29 +1661,31 @@ TclGetOpenModeEx(
* file or an error indicating why the file couldn't be read.
*
* Side effects:
- * Depends on the commands in the file. During the evaluation of the
- * contents of the file, iPtr->scriptFile is made to point to pathPtr
- * (the old value is cached and replaced when this function returns).
+ * Arbitrary, depending on the contents of the script. While the script
+ * is evaluated iPtr->scriptFile is a reference to pathPtr, and after the
+ * evaluation completes, has its original value restored again.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSEvalFile(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution
- * will be performed on this name. */
+ Tcl_Interp *interp, /* Interpreter that evaluates the script. */
+ Tcl_Obj *pathPtr) /* Pathname of file containing the script.
+ * Tilde-substitution is performed on this
+ * pathname. */
{
return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
}
int
Tcl_FSEvalFileEx(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution
- * will be performed on this name. */
- const char *encodingName) /* If non-NULL, then use this encoding for the
- * file. NULL means use the system encoding. */
+ Tcl_Interp *interp, /* Interpreter that evaluates the script. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to process.
+ * Tilde-substitution is performed on this
+ * pathname. */
+ const char *encodingName) /* Either the name of an encoding or NULL to
+ use the utf-8 encoding. */
{
int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
@@ -1756,34 +1715,34 @@ Tcl_FSEvalFileEx(
}
/*
- * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
- * this cross-platform to allow for scripted documents. [Bug: 2040]
+ * The eof character is \32 (^Z). This is standard on Windows, and Tcl
+ * uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
- * If the encoding is specified, set it for the channel. Else don't touch
- * it (and use the system encoding) Report error on unknown encoding.
+ * If the encoding is specified, set the channel to that encoding.
+ * Otherwise use utf-8. If the encoding is unknown report an error.
*/
- if (encodingName != NULL) {
- if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
- != TCL_OK) {
- Tcl_Close(interp,chan);
- return result;
- }
+ if (encodingName == NULL) {
+ encodingName = "utf-8";
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp,chan);
+ return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
- * Try to read first character of stream, so we can check for utf-8 BOM to
- * be handled especially.
+ * Read first character of stream to check for utf-8 BOM
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1793,12 +1752,12 @@ Tcl_FSEvalFileEx(
string = Tcl_GetString(objPtr);
/*
- * If first character is not a BOM, append the remaining characters,
- * otherwise replace them. [Bug 3466099]
+ * If first character is not a BOM, append the remaining characters.
+ * Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xEF\xBB\xBF", 3)) < 0) {
+ memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1814,19 +1773,19 @@ Tcl_FSEvalFileEx(
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
- string = Tcl_GetStringFromObj(objPtr, &length);
+ string = TclGetStringFromObj(objPtr, &length);
/*
- * TIP #280 Force the evaluator to open a frame for a sourced file.
+ * TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
/*
- * Now we have to be careful; the script may have changed the
- * iPtr->scriptFile value, so we must reset it without assuming it still
- * points to 'pathPtr'.
+ * Restore the original iPtr->scriptFile value, but because the value may
+ * have hanged during evaluation, don't assume it currently points to
+ * pathPtr.
*/
if (iPtr->scriptFile != NULL) {
@@ -1838,10 +1797,10 @@ Tcl_FSEvalFileEx(
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
- * Record information telling where the error occurred.
+ * Record information about where the error occurred.
*/
- const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ const char *pathString = TclGetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
@@ -1858,11 +1817,12 @@ Tcl_FSEvalFileEx(
int
TclNREvalFile(
- Tcl_Interp *interp, /* Interpreter in which to process file. */
- Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution
- * will be performed on this name. */
- const char *encodingName) /* If non-NULL, then use this encoding for the
- * file. NULL means use the system encoding. */
+ Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
+ Tcl_Obj *pathPtr, /* Pathname of a file containing the script to
+ * evaluate. Tilde-substitution is performed on
+ * this pathname. */
+ const char *encodingName) /* The name of an encoding to use, or NULL to
+ * use the utf-8 encoding. */
{
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile, *objPtr;
@@ -1888,36 +1848,37 @@ TclNREvalFile(
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
+ TclPkgFileSeen(interp, Tcl_GetString(pathPtr));
/*
- * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
- * this cross-platform to allow for scripted documents. [Bug: 2040]
+ * The eof character is \32 (^Z). This is standard on Windows, and Tcl
+ * uses it on every platform to allow for scripted documents. [Bug: 2040]
*/
Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
- * If the encoding is specified, set it for the channel. Else don't touch
- * it (and use the system encoding) Report error on unknown encoding.
+ * If the encoding is specified, set the channel to that encoding.
+ * Otherwise use utf-8. If the encoding is unknown report an error.
*/
- if (encodingName != NULL) {
- if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
- != TCL_OK) {
- Tcl_Close(interp,chan);
- return TCL_ERROR;
- }
+ if (encodingName == NULL) {
+ encodingName = "utf-8";
+ }
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp, chan);
+ return TCL_ERROR;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
/*
- * Try to read first character of stream, so we can check for utf-8 BOM to
- * be handled especially.
+ * Read first character of stream to check for utf-8 BOM
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1928,12 +1889,12 @@ TclNREvalFile(
string = Tcl_GetString(objPtr);
/*
- * If first character is not a BOM, append the remaining characters,
- * otherwise replace them. [Bug 3466099]
+ * If first character is not a BOM, append the remaining characters.
+ * Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xEF\xBB\xBF", 3)) < 0) {
+ memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1953,7 +1914,7 @@ TclNREvalFile(
Tcl_IncrRefCount(iPtr->scriptFile);
/*
- * TIP #280: Force the evaluator to open a frame for a sourced file.
+ * TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
@@ -1969,14 +1930,14 @@ EvalFileCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *oldScriptFile = data[0];
- Tcl_Obj *pathPtr = data[1];
- Tcl_Obj *objPtr = data[2];
+ Tcl_Obj *oldScriptFile = (Tcl_Obj *)data[0];
+ Tcl_Obj *pathPtr = (Tcl_Obj *)data[1];
+ Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
- * Now we have to be careful; the script may have changed the
- * iPtr->scriptFile value, so we must reset it without assuming it still
- * points to 'pathPtr'.
+ * Restore the original iPtr->scriptFile value, but because the value may
+ * have hanged during evaluation, don't assume it currently points to
+ * pathPtr.
*/
if (iPtr->scriptFile != NULL) {
@@ -1988,11 +1949,11 @@ EvalFileCallback(
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
- * Record information telling where the error occurred.
+ * Record information about where the error occurred.
*/
int length;
- const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ const char *pathString = TclGetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
@@ -2011,16 +1972,15 @@ EvalFileCallback(
*
* Tcl_GetErrno --
*
- * Gets the current value of the Tcl error code variable. This is
- * currently the global variable "errno" but could in the future change
+ * Currently the global variable "errno", but could in the future change
* to something else.
*
* Results:
- * The value of the Tcl error code variable.
+ * The current Tcl error number.
*
* Side effects:
- * None. Note that the value of the Tcl error code variable is UNDEFINED
- * if a call to Tcl_SetErrno did not precede this call.
+ * None. The value of the Tcl error code variable is only defined if it
+ * was set by a previous call to Tcl_SetErrno.
*
*----------------------------------------------------------------------
*/
@@ -2029,8 +1989,8 @@ int
Tcl_GetErrno(void)
{
/*
- * On some platforms, errno is really a thread local (implemented by the C
- * library).
+ * On some platforms errno is thread-local, as implemented by the C
+ * library.
*/
return errno;
@@ -2041,15 +2001,15 @@ Tcl_GetErrno(void)
*
* Tcl_SetErrno --
*
- * Sets the Tcl error code variable to the supplied value. On some saner
- * platforms this is actually a thread-local (this is implemented in the
- * C library) but this is *really* unsafe to assume!
+ * Sets the Tcl error code to the given value. On some saner platforms
+ * this is implemented in the C library as a thread-local value , but this
+ * is *really* unsafe to assume!
*
* Results:
* None.
*
* Side effects:
- * Modifies the value of the Tcl error code variable.
+ * Modifies the the Tcl error code value.
*
*----------------------------------------------------------------------
*/
@@ -2059,8 +2019,8 @@ Tcl_SetErrno(
int err) /* The new value. */
{
/*
- * On some platforms, errno is really a thread local (implemented by the C
- * library).
+ * On some platforms, errno is implemented by the C library as a thread
+ * local value
*/
errno = err;
@@ -2071,31 +2031,28 @@ Tcl_SetErrno(
*
* Tcl_PosixError --
*
- * This function is typically called after UNIX kernel calls return
- * errors. It stores machine-readable information about the error in
- * errorCode field of interp and returns an information string for the
- * caller's use.
+ * Typically called after a UNIX kernel call returns an error. Sets the
+ * interpreter errorCode to machine-parsable information about the error.
*
* Results:
- * The return value is a human-readable string describing the error.
+ * A human-readable sring describing the error.
*
* Side effects:
- * The errorCode field of the interp is set.
+ * Sets the errorCode value of the interpreter.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_PosixError(
- Tcl_Interp *interp) /* Interpreter whose errorCode field is to be
- * set. */
+ Tcl_Interp *interp) /* Interpreter to set the errorCode of */
{
const char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
- Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL);
+ Tcl_SetErrorCode(interp, "POSIX", id, msg, (void *)NULL);
}
return msg;
}
@@ -2104,11 +2061,9 @@ Tcl_PosixError(
*----------------------------------------------------------------------
*
* Tcl_FSStat --
+ * Calls 'statProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of stat and lstat.
- *
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Replaces the standard library "stat" routine.
*
* Results:
* See stat documentation.
@@ -2121,8 +2076,10 @@ Tcl_PosixError(
int
Tcl_FSStat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ * current CP). */
+ Tcl_StatBuf *buf) /* A buffer to hold the results of the call to
+ * stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2137,11 +2094,11 @@ Tcl_FSStat(
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
+ * Calls the 'lstatProc' of the filesystem corresponding to pathPtr.
*
- * This function replaces the library version of lstat. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
- * If no 'lstat' function is listed, but a 'stat' function is, then Tcl
- * will fall back on the stat function.
+ * Replaces the library version of lstat. If the filesystem doesn't
+ * provide lstatProc but does provide statProc, Tcl falls back to
+ * statProc.
*
* Results:
* See lstat documentation.
@@ -2154,8 +2111,9 @@ Tcl_FSStat(
int
Tcl_FSLstat(
- Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */
- Tcl_StatBuf *buf) /* Filled with results of stat call. */
+ Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
+ current CP). */
+ Tcl_StatBuf *buf) /* Filled with results of that call to stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2176,8 +2134,9 @@ Tcl_FSLstat(
*
* Tcl_FSAccess --
*
- * This function replaces the library version of access. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'accessProc' of the filesystem corresponding to pathPtr.
+ *
+ * Replaces the library version of access.
*
* Results:
* See access documentation.
@@ -2190,7 +2149,7 @@ Tcl_FSLstat(
int
Tcl_FSAccess(
- Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */
+ Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */
int mode) /* Permission setting. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2207,38 +2166,36 @@ Tcl_FSAccess(
*
* Tcl_FSOpenFileChannel --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'openfileChannelProc' of the filesystem corresponding to
+ * pathPtr.
*
* Results:
- * The new channel or NULL, if the named file could not be opened.
+ * The new channel, or NULL if the named file could not be opened.
*
* Side effects:
- * May open the channel and may cause creation of a file on the file
- * system.
+ * Opens a channel, possibly creating the corresponding the file on the
+ * filesystem.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_FSOpenFileChannel(
- Tcl_Interp *interp, /* Interpreter for error reporting; can be
- * NULL. */
- Tcl_Obj *pathPtr, /* Name of file to open. */
+ Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
+ Tcl_Obj *pathPtr, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
- int permissions) /* If the open involves creating a file, with
- * what modes to create it? */
+ int permissions) /* What modes to use if opening the file
+ involves creating it. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
- /*
- * We need this just to ensure we return the correct error messages under
- * some circumstances.
- */
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
+ /*
+ * Return the correct error message.
+ */
return NULL;
}
@@ -2247,8 +2204,8 @@ Tcl_FSOpenFileChannel(
int mode, seekFlag, binary;
/*
- * Parse the mode, picking up whether we want to seek to start with
- * and/or set the channel automatically into binary mode.
+ * Parse the mode to determine whether to seek at the outset
+ * and/or set the channel into binary mode.
*/
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
@@ -2257,7 +2214,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Do the actual open() call.
+ * Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
@@ -2267,7 +2224,7 @@ Tcl_FSOpenFileChannel(
}
/*
- * Apply appropriate flags parsed out above.
+ * Seek and/or set binary mode as determined above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
@@ -2304,8 +2261,10 @@ Tcl_FSOpenFileChannel(
*
* Tcl_FSUtime --
*
- * This function replaces the library version of utime. The appropriate
- * function for the filesystem to which pathPtr belongs will be called.
+ * Calls 'uTimeProc' of the filesystem corresponding to the given
+ * pathname.
+ *
+ * Replaces the library version of utime.
*
* Results:
* See utime documentation.
@@ -2318,17 +2277,22 @@ Tcl_FSOpenFileChannel(
int
Tcl_FSUtime(
- Tcl_Obj *pathPtr, /* File to change access/modification
- * times. */
- struct utimbuf *tval) /* Structure containing access/modification
+ Tcl_Obj *pathPtr, /* Pathaname of file to call uTimeProc on */
+ struct utimbuf *tval) /* Specifies the access/modification
* times to use. Should not be modified. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ int err;
- if (fsPtr != NULL && fsPtr->utimeProc != NULL) {
- return fsPtr->utimeProc(pathPtr, tval);
+ if (fsPtr == NULL) {
+ err = ENOENT;
+ } else {
+ if (fsPtr->utimeProc != NULL) {
+ return fsPtr->utimeProc(pathPtr, tval);
+ }
+ err = ENOTSUP;
}
- /* TODO: set errno here? Tcl_SetErrno(ENOENT); */
+ Tcl_SetErrno(err);
return -1;
}
@@ -2337,11 +2301,10 @@ Tcl_FSUtime(
*
* NativeFileAttrStrings --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for listing the set of possible
- * attribute strings. This function is part of Tcl's native filesystem
- * support, and is placed here because it is shared by Unix and Windows
- * code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem, for listing the set of possible attribute strings.
+ * Part of Tcl's native filesystem support. Placed here because it is used
+ * under both Unix and Windows.
*
* Results:
* An array of strings
@@ -2354,8 +2317,8 @@ Tcl_FSUtime(
static const char *const *
NativeFileAttrStrings(
- Tcl_Obj *pathPtr,
- Tcl_Obj **objPtrRef)
+ TCL_UNUSED(Tcl_Obj *),
+ TCL_UNUSED(Tcl_Obj **))
{
return tclpFileAttrStrings;
}
@@ -2365,16 +2328,18 @@ NativeFileAttrStrings(
*
* NativeFileAttrsGet --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for 'get' operations. This
- * function is part of Tcl's native filesystem support, and is placed
- * here because it is shared by Unix and Windows code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem for 'get' operations. Part of Tcl's native
+ * filesystem support. Defined here because it is used under both Unix
+ * and Windows.
*
* Results:
- * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
- * was returned) is likely to have a refCount of zero. Either way we must
- * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
- * refCount to ensure it is properly freed.
+ * Standard Tcl return code.
+ *
+ * If there was no error, stores in objPtrRef a pointer to a new object
+ * having a refCount of zero and holding the result. The caller should
+ * store it somewhere, e.g. as the Tcl result, or decrement its refCount
+ * to free it.
*
* Side effects:
* None.
@@ -2386,8 +2351,8 @@ static int
NativeFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* path of file we are operating on. */
- Tcl_Obj **objPtrRef) /* for output. */
+ Tcl_Obj *pathPtr, /* Pathname of the file */
+ Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */
{
return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef);
}
@@ -2397,13 +2362,13 @@ NativeFileAttrsGet(
*
* NativeFileAttrsSet --
*
- * This function implements the platform dependent 'file attributes'
- * subcommand, for the native filesystem, for 'set' operations. This
- * function is part of Tcl's native filesystem support, and is placed
- * here because it is shared by Unix and Windows code.
+ * Implements the platform-dependent 'file attributes' subcommand for the
+ * native filesystem for 'set' operations. A part of Tcl's native
+ * filesystem support, it is defined here because it is used under both
+ * Unix and Windows.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
* None.
@@ -2415,8 +2380,8 @@ static int
NativeFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* path of file we are operating on. */
- Tcl_Obj *objPtr) /* set to this value. */
+ Tcl_Obj *pathPtr, /* Pathname of the file */
+ Tcl_Obj *objPtr) /* The value to set. */
{
return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr);
}
@@ -2426,18 +2391,16 @@ NativeFileAttrsSet(
*
* Tcl_FSFileAttrStrings --
*
- * This function implements part of the hookable 'file attributes'
- * subcommand. The appropriate function for the filesystem to which
- * pathPtr belongs will be called.
+ * Implements part of the hookable 'file attributes'
+ * subcommand.
+ *
+ * Calls 'fileAttrStringsProc' of the filesystem corresponding to the
+ * given pathname.
*
* Results:
- * The called function may either return an array of strings, or may
- * instead return NULL and place a Tcl list into the given objPtrRef.
- * Tcl will take that list and first increment its refCount before using
- * it. On completion of that use, Tcl will decrement its refCount. Hence
- * if the list should be disposed of by Tcl when done, it should have a
- * refCount of zero, and if the list should not be disposed of, the
- * filesystem should ensure it retains a refCount on the object.
+ * Returns an array of strings, or returns NULL and stores in objPtrRef
+ * a pointer to a new Tcl list having a refCount of zero, and containing
+ * the file attribute strings.
*
* Side effects:
* None.
@@ -2464,11 +2427,13 @@ Tcl_FSFileAttrStrings(
*
* TclFSFileAttrIndex --
*
- * Helper function for converting an attribute name to an index into the
+ * Given an attribute name, determines the index of the attribute in the
* attribute table.
*
* Results:
- * Tcl result code, index written to *indexPtr on result==TCL_OK
+ * A standard Tcl result code.
+ *
+ * If there is no error, stores the index in *indexPtr.
*
* Side effects:
* None.
@@ -2478,10 +2443,9 @@ Tcl_FSFileAttrStrings(
int
TclFSFileAttrIndex(
- Tcl_Obj *pathPtr, /* File whose attributes are to be indexed
- * into. */
- const char *attributeName, /* The attribute being looked for. */
- int *indexPtr) /* Where to write the found index. */
+ Tcl_Obj *pathPtr, /* Pathname of the file. */
+ const char *attributeName, /* The name of the attribute. */
+ int *indexPtr) /* A place to store the result. */
{
Tcl_Obj *listObj = NULL;
const char *const *attrTable;
@@ -2518,7 +2482,7 @@ TclFSFileAttrIndex(
int i, objc;
Tcl_Obj **objv;
- if (TclListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(NULL, listObj, &objc, &objv) != TCL_OK) {
TclDecrRefCount(listObj);
return TCL_ERROR;
}
@@ -2541,15 +2505,16 @@ TclFSFileAttrIndex(
*
* Tcl_FSFileAttrsGet --
*
- * This function implements read access for the hookable 'file
- * attributes' subcommand. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Implements read access for the hookable 'file attributes' subcommand.
+ *
+ * Calls 'fileAttrsGetProc' of the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
- * was returned) is likely to have a refCount of zero. Either way we must
- * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
- * refCount to ensure it is properly freed.
+ * A standard Tcl return code.
+ *
+ * On success, stores in objPtrRef a pointer to a new Tcl_Obj having a
+ * refCount of zero, and containing the result.
*
* Side effects:
* None.
@@ -2560,9 +2525,9 @@ TclFSFileAttrIndex(
int
Tcl_FSFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
- int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* filename we are operating on. */
- Tcl_Obj **objPtrRef) /* for output. */
+ int index, /* The index of the attribute command. */
+ Tcl_Obj *pathPtr, /* The pathname of the file. */
+ Tcl_Obj **objPtrRef) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2578,12 +2543,14 @@ Tcl_FSFileAttrsGet(
*
* Tcl_FSFileAttrsSet --
*
- * This function implements write access for the hookable 'file
- * attributes' subcommand. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Implements write access for the hookable 'file
+ * attributes' subcommand.
+ *
+ * Calls 'fileAttrsSetProc' for the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
* None.
@@ -2594,9 +2561,9 @@ Tcl_FSFileAttrsGet(
int
Tcl_FSFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
- int index, /* index of the attribute command. */
- Tcl_Obj *pathPtr, /* filename we are operating on. */
- Tcl_Obj *objPtr) /* Input value. */
+ int index, /* The index of the attribute command. */
+ Tcl_Obj *pathPtr, /* The pathname of the file. */
+ Tcl_Obj *objPtr) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -2612,33 +2579,25 @@ Tcl_FSFileAttrsSet(
*
* Tcl_FSGetCwd --
*
- * This function replaces the library version of getcwd().
- *
- * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own
- * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this
- * with the cwd's containing filesystem, if that filesystem provides a
- * cwdProc (e.g. the native filesystem).
- *
- * Note that if Tcl's cwd is not in the native filesystem, then of course
- * Tcl's cwd and the native cwd are different: extensions should
- * therefore ensure they only access the cwd through this function to
- * avoid confusion.
+ * Replaces the library version of getcwd().
*
- * If a global cwdPathPtr already exists, it is cached in the thread's
- * private data structures and reference to the cached copy is returned,
- * subject to a synchronisation attempt in that cwdPathPtr's fs.
+ * Most virtual filesystems do not implement cwdProc. Tcl maintains its
+ * own record of the current directory which it keeps synchronized with
+ * the filesystem corresponding to the pathname of the current directory
+ * if the filesystem provides a cwdProc (the native filesystem does).
*
- * Otherwise, the chain of functions that have been "inserted" into the
- * filesystem will be called in succession until either a value other
- * than NULL is returned, or the entire list is visited.
+ * If Tcl's current directory is not in the native filesystem, Tcl's
+ * current directory and the current directory of the process are
+ * different. To avoid confusion, extensions should call Tcl_FSGetCwd to
+ * obtain the current directory from Tcl rather than from the operating
+ * system.
*
* Results:
- * The result is a pointer to a Tcl_Obj specifying the current directory,
- * or NULL if the current directory could not be determined. If NULL is
- * returned, an error message is left in the interp's result.
+ * Returns a pointer to a Tcl_Obj having a refCount of 1 and containing
+ * the current thread's local copy of the global cwdPathPtr value.
*
- * The result already has its refCount incremented for the caller. When
- * it is no longer needed, that refCount should be decremented.
+ * Returns NULL if the current directory could not be determined, and
+ * leaves an error message in the interpreter's result.
*
* Side effects:
* Various objects may be freed and allocated.
@@ -2657,9 +2616,10 @@ Tcl_FSGetCwd(
Tcl_Obj *retVal = NULL;
/*
- * We've never been called before, try to find a cwd. Call each of the
- * "Tcl_GetCwd" function in succession. A non-NULL return value
- * indicates the particular function has succeeded.
+ * This is the first time this routine has been called. Call
+ * 'getCwdProc' for each registered filsystems until one returns
+ * something other than NULL, which is a pointer to the pathname of the
+ * current directory.
*/
fsRecPtr = FsGetFirstFilesystem();
@@ -2668,6 +2628,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -2683,7 +2644,7 @@ Tcl_FSGetCwd(
Tcl_Obj *norm;
/*
- * Looks like a new current directory.
+ * Found the pathname of the current directory.
*/
retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
@@ -2691,15 +2652,16 @@ Tcl_FSGetCwd(
norm = TclFSNormalizeAbsolutePath(interp,retVal);
if (norm != NULL) {
/*
- * We found a cwd, which is now in our global storage. We
- * must make a copy. Norm already has a refCount of 1.
+ * Assign to global storage the pathname of the current
+ * directory and copy it into thread-local storage as
+ * well.
*
- * Threading issue: note that multiple threads at system
- * startup could in principle call this function
- * simultaneously. They will therefore each set the
- * cwdPathPtr independently. That behaviour is a bit
- * peculiar, but should be fine. Once we have a cwd, we'll
- * always be in the 'else' branch below which is simpler.
+ * At system startup multiple threads could in principle
+ * call this function simultaneously, which is a little
+ * peculiar, but should be fine given the mutex locks in
+ * FSUPdateCWD. Once some value is assigned to the global
+ * variable the 'else' branch below is always taken, which
+ * is simpler.
*/
FsUpdateCwd(norm, retCd);
@@ -2719,44 +2681,48 @@ Tcl_FSGetCwd(
}
Disclaim();
- /*
- * Now the 'cwd' may NOT be normalized, at least on some platforms.
- * For the sake of efficiency, we want a completely normalized cwd at
- * all times.
- *
- * Finally, if retVal is NULL, we do not have a cwd, which could be
- * problematic.
- */
-
if (retVal != NULL) {
+ /*
+ * On some platforms the pathname of the current directory might
+ * not be normalized. For efficiency, ensure that it is
+ * normalized. For the sake of efficiency, we want a completely
+ * normalized current working directory at all times.
+ */
+
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm != NULL) {
/*
- * We found a cwd, which is now in our global storage. We must
- * make a copy. Norm already has a refCount of 1.
+ * We found a current working directory, which is now in our
+ * global storage. We must make a copy. Norm already has a
+ * refCount of 1.
*
- * Threading issue: note that multiple threads at system
- * startup could in principle call this function
- * simultaneously. They will therefore each set the cwdPathPtr
- * independently. That behaviour is a bit peculiar, but should
- * be fine. Once we have a cwd, we'll always be in the 'else'
- * branch below which is simpler.
+ * Threading issue: Multiple threads at system startup could in
+ * principle call this function simultaneously. They will
+ * therefore each set the cwdPathPtr independently, which is a
+ * bit peculiar, but should be fine. Once we have a cwd, we'll
+ * always be in the 'else' branch below which is simpler.
*/
- ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
+ void *cd = (void *) Tcl_FSGetNativePath(norm);
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
+ } else {
+ /*
+ * retVal is NULL. There is no current directory, which could be
+ * problematic.
+ */
}
} else {
/*
- * We already have a cwd cached, but we want to give the filesystem it
- * is in a chance to check whether that cwd has changed, or is perhaps
- * no longer accessible. This allows an error to be thrown if, say,
- * the permissions on that directory have changed.
+ * There is a thread-local value for the pathname of the current
+ * directory. Give corresponding filesystem a chance update the value
+ * if it is out-of-date. This allows an error to be thrown if, for
+ * example, the permissions on the current working directory have
+ * changed.
*/
const Tcl_Filesystem *fsPtr =
@@ -2764,16 +2730,11 @@ Tcl_FSGetCwd(
ClientData retCd = NULL;
Tcl_Obj *retVal, *norm;
- /*
- * If the filesystem couldn't be found, or if no cwd function exists
- * for this filesystem, then we simply assume the cached cwd is ok.
- * If we do call a cwd, we must watch for errors (if the cwd returns
- * NULL). This ensures that, say, on Unix if the permissions of the
- * cwd change, 'pwd' does actually throw the correct error in Tcl.
- * (This is tested for in the test suite on Unix).
- */
-
if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
+ /*
+ * There is no corresponding filesystem or the filesystem does not
+ * have a getCwd routine. Just assume current local value is ok.
+ */
goto cdDidNotChange;
}
@@ -2805,28 +2766,25 @@ Tcl_FSGetCwd(
Tcl_IncrRefCount(retVal);
}
- /*
- * Check if the 'cwd' function returned an error; if so, reset the
- * cwd.
- */
-
if (retVal == NULL) {
+ /*
+ * The current directory could not not determined. Reset the
+ * current direcory to ensure, for example, that 'pwd' does actually
+ * throw the correct error in Tcl. This is tested for in the test
+ * suite on unix.
+ */
+
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
}
- /*
- * Normalize the path.
- */
-
norm = TclFSNormalizeAbsolutePath(interp, retVal);
- /*
- * Check whether cwd has changed from the value previously stored in
- * cwdPathPtr. Really 'norm' shouldn't be NULL, but we are careful.
- */
-
if (norm == NULL) {
+ /*
+ * 'norm' shouldn't ever be NULL, but we are careful.
+ */
+
/* Do nothing */
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
@@ -2834,32 +2792,35 @@ Tcl_FSGetCwd(
} else if (norm == tsdPtr->cwdPathPtr) {
goto cdEqual;
} else {
- /*
- * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are normalized
- * paths. Therefore we can be more efficient than calling
- * 'Tcl_FSEqualPaths', and in addition avoid a nasty infinite loop
- * bug when trying to normalize tsdPtr->cwdPathPtr.
+ /*
+ * Determine whether the filesystem's answer is the same as the
+ * cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr'
+ * are normalized pathnames, do something more efficient than
+ * calling 'Tcl_FSEqualPaths', and in addition avoid a nasty
+ * infinite loop bug when trying to normalize tsdPtr->cwdPathPtr.
*/
int len1, len2;
const char *str1, *str2;
- str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = Tcl_GetStringFromObj(norm, &len2);
+ str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = TclGetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
- * If the paths were equal, we can be more efficient and
- * retain the old path object which will probably already be
- * shared. In this case we can simply free the normalized path
- * we just calculated.
+ * The pathname values are equal so retain the old pathname
+ * object which is probably already shared and free the
+ * normalized pathname that was just produced.
*/
-
cdEqual:
Tcl_DecrRefCount(norm);
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
}
} else {
+ /*
+ * The pathname of the current directory is not the same as
+ * this thread's local cached value. Replace the local value.
+ */
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
}
@@ -2880,17 +2841,19 @@ Tcl_FSGetCwd(
*
* Tcl_FSChdir --
*
- * This function replaces the library version of chdir().
+ * Replaces the library version of chdir().
*
- * The path is normalized and then passed to the filesystem which claims
- * it.
+ * Calls 'chdirProc' of the filesystem that corresponds to the given
+ * pathname.
*
* Results:
- * See chdir() documentation. If successful, we keep a record of the
- * successful path in cwdPathPtr for subsequent calls to getcwd.
+ * See chdir() documentation.
*
* Side effects:
- * See chdir() documentation. The global cwdPathPtr may change value.
+ * See chdir() documentation.
+ *
+ * On success stores in cwdPathPtr the pathname of the new current
+ * directory.
*
*----------------------------------------------------------------------
*/
@@ -2915,70 +2878,46 @@ Tcl_FSChdir(
if (fsPtr != NULL) {
if (fsPtr->chdirProc != NULL) {
/*
- * If this fails, an appropriate errno will have been stored using
- * 'Tcl_SetErrno()'.
+ * If this fails Tcl_SetErrno() has already been called.
*/
retVal = fsPtr->chdirProc(pathPtr);
} else {
/*
- * Fallback on stat-based implementation.
+ * Fallback to stat-based implementation.
*/
Tcl_StatBuf buf;
- /*
- * If the file can be stat'ed and is a directory and is readable,
- * then we can chdir. If any of these actions fail, then
- * 'Tcl_SetErrno()' should automatically have been called to set
- * an appropriate error code.
- */
-
if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
&& (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
/*
- * We allow the chdir.
+ * stat was successful, and the file is a directory and is
+ * readable. Can proceed to change the current directory.
*/
retVal = 0;
+ } else {
+ /*
+ * 'Tcl_SetErrno()' has already been called.
+ */
}
}
} else {
Tcl_SetErrno(ENOENT);
}
- /*
- * The cwd changed, or an error was thrown. If an error was thrown, we can
- * just continue (and that will report the error to the user). If there
- * was no error we must assume that the cwd was actually changed to the
- * normalized value we calculated above, and we must therefore cache that
- * information.
- *
- * If the filesystem in question has a getCwdProc, then the correct logic
- * which performs the part below is already part of the Tcl_FSGetCwd()
- * call, so no need to replicate it again. This will have a side effect
- * though. The private authoritative representation of the current working
- * directory stored in cwdPathPtr in static memory will be out-of-sync
- * with the real OS-maintained value. The first call to Tcl_FSGetCwd will
- * however recalculate the private copy to match the OS-value so
- * everything will work right.
- *
- * However, if there is no getCwdProc, then we _must_ update our private
- * storage of the cwd, since this is the only opportunity to do that!
- *
- * Note: We currently call this block of code irrespective of whether
- * there was a getCwdProc or not, but the code should all in principle
- * work if we only call this block if fsPtr->getCwdProc == NULL.
- */
-
if (retVal == 0) {
+
+ /* Assume that the cwd was actually changed to the normalized value
+ * just calculated, and cache that information. */
+
/*
- * Note that this normalized path may be different to what we found
- * above (or at least a different object), if the filesystem epoch
- * changed recently. This can actually happen with scripted documents
- * very easily. Therefore we ask for the normalized path again (the
- * correct value will have been cached as a result of the
- * Tcl_FSGetFileSystemForPath call above anyway).
+ * If the filesystem epoch changed recently, the normalized pathname or
+ * its internal handle may be different from what was found above.
+ * This can easily be the case with scripted documents . Therefore get
+ * the normalized pathname again. The correct value will have been
+ * cached as a result of the Tcl_FSGetFileSystemForPath call, above.
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
@@ -2990,45 +2929,60 @@ Tcl_FSChdir(
}
if (fsPtr == &tclNativeFilesystem) {
- /*
- * For the native filesystem, we keep a cache of the native
- * representation of the cwd. But, we want to do that for the
- * exact format that is returned by 'getcwd' (so that we can later
- * compare the two representations for equality), which might not
- * be exactly the same char-string as the native representation of
- * the fully normalized path (e.g. on Windows there's a
- * forward-slash vs backslash difference). Hence we ask for this
- * again here. On Unix it might actually be true that we always
- * have the correct form in the native rep in which case we could
- * simply use:
- * cd = Tcl_FSGetNativePath(pathPtr);
- * instead. This should be examined by someone on Unix.
- */
-
ClientData cd;
ClientData oldcd = tsdPtr->cwdClientData;
/*
- * Assumption we are using a filesystem version 2.
+ * Assume that the native filesystem has a getCwdProc and that it
+ * is at version 2.
*/
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
cd = proc2(oldcd);
if (cd != oldcd) {
+ /*
+ * Call getCwdProc() and store the resulting internal handle to
+ * compare things with it later. This might might not be
+ * exactly the same string as that of the fully normalized
+ * pathname. For example, for the Windows internal handle the
+ * separator is the backslash character. On Unix it might well
+ * be true that the internal handle is the fully normalized
+ * pathname and one could simply use:
+ * cd = Tcl_FSGetNativePath(pathPtr);
+ * but this can't be guaranteed in the general case. In fact,
+ * the internal handle could be any value the filesystem
+ * decides to use to identify a node.
+ */
+
FsUpdateCwd(normDirName, cd);
}
} else {
+ /*
+ * Tcl_FSGetCwd() synchronizes the file-global cwdPathPtr if
+ * needed. However, if there is no 'getCwdProc', cwdPathPtr must be
+ * updated right now because there won't be another chance. This
+ * block of code is currently executed whether or not the
+ * filesystem provides a getCwdProc, but it should in principle
+ * work to only call this block if fsPtr->getCwdProc == NULL.
+ */
+
FsUpdateCwd(normDirName, NULL);
}
- /*
- * If the filesystem changed between old and new cwd
- * force filesystem refresh on path objects.
- */
if (oldFsPtr != NULL && fsPtr != oldFsPtr) {
+ /*
+ * The filesystem of the current directory is not the same as the
+ * filesystem of the previous current directory. Invalidate All
+ * FsPath objects.
+ */
Tcl_FSMountsChanged(NULL);
}
+ } else {
+ /*
+ * The current directory is now changed or an error occurred and an
+ * error message is now set. Just continue.
+ */
}
return retVal;
@@ -3039,25 +2993,17 @@ Tcl_FSChdir(
*
* Tcl_FSLoadFile --
*
- * Dynamically loads a binary code file into memory and returns the
- * addresses of two functions within that file, if they are defined. The
- * appropriate function for the filesystem to which pathPtr belongs will
- * be called.
- *
- * Note that the native filesystem doesn't actually assume 'pathPtr' is a
- * path. Rather it assumes pathPtr is either a path or just the name
- * (tail) of a file which can be found somewhere in the environment's
- * loadable path. This behaviour is not very compatible with virtual
- * filesystems (and has other problems documented in the load man-page),
- * so it is advised that full paths are always used.
+ * Loads a dynamic shared object by passing the given pathname unmodified
+ * to Tcl_LoadFile, and provides pointers to the functions named by 'sym1'
+ * and 'sym2', and another pointer to a function that unloads the object.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error message
- * is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, sets the
+ * interpreter's result to an error message.
*
* Side effects:
- * New code suddenly appears in memory. This may later be unloaded by
- * passing the clientData to the unloadProc.
+ * A dynamic shared object is loaded into memory. This may later be
+ * unloaded by passing the handlePtr to *unloadProcPtr.
*
*----------------------------------------------------------------------
*/
@@ -3065,42 +3011,31 @@ Tcl_FSChdir(
int
Tcl_FSLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Obj *pathPtr, /* Name of the file containing the desired
- * code. */
+ Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic shared object.
+ */
const char *sym1, const char *sym2,
- /* Names of two functions to look up in the
- * file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded
- * file which will be passed back to
+ /* Names of two functions to find in the
+ * dynamic shared object. */
+ Tcl_LibraryInitProc **proc1Ptr, Tcl_LibraryInitProc **proc2Ptr,
+ /* Places to store pointers to the functions
+ * named by sym1 and sym2. */
+ Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded
+ * object. Can be passed to
* (*unloadProcPtr)() to unload the file. */
- Tcl_FSUnloadFileProc **unloadProcPtr)
- /* Filled with address of Tcl_FSUnloadFileProc
- * function which should be used for this
- * file. */
+ TCL_UNUSED(Tcl_FSUnloadFileProc **))
{
const char *symbols[3];
void *procPtrs[2];
int res;
- /*
- * Initialize the arrays.
- */
-
symbols[0] = sym1;
symbols[1] = sym2;
symbols[2] = NULL;
- /*
- * Perform the load.
- */
-
res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr);
if (res == TCL_OK) {
- *proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0];
- *proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1];
+ *proc1Ptr = (Tcl_LibraryInitProc *) procPtrs[0];
+ *proc2Ptr = (Tcl_LibraryInitProc *) procPtrs[1];
} else {
*proc1Ptr = *proc2Ptr = NULL;
}
@@ -3113,49 +3048,40 @@ Tcl_FSLoadFile(
*
* Tcl_LoadFile --
*
- * Dynamically loads a binary code file into memory and returns the
- * addresses of a number of given functions within that file, if they are
- * defined. The appropriate function for the filesystem to which pathPtr
- * belongs will be called.
+ * Load a dynamic shared object by calling 'loadFileProc' of the
+ * filesystem corresponding to the given pathname, and then finds within
+ * the loaded object the functions named in symbols[].
*
- * Note that the native filesystem doesn't actually assume 'pathPtr' is a
- * path. Rather it assumes pathPtr is either a path or just the name
- * (tail) of a file which can be found somewhere in the environment's
- * loadable path. This behaviour is not very compatible with virtual
- * filesystems (and has other problems documented in the load man-page),
- * so it is advised that full paths are always used.
+ * The given pathname is passed unmodified to `loadFileProc`, which
+ * decides how to resolve it. On POSIX systems the native filesystem
+ * passes the given pathname to dlopen(), which resolves the filename
+ * according to its own set of rules. This behaviour is not very
+ * compatible with virtual filesystems, and has other problems as
+ * documented for [load], so it is recommended to use an absolute
+ * pathname.
*
* Results:
- * A standard Tcl completion code. If an error occurs, an error message
- * is left in the interp's result.
+ * A standard Tcl completion code. If an error occurs, sets the
+ * interpreter result to an error message.
*
* Side effects:
- * New code suddenly appears in memory. This may later be unloaded by
- * calling TclFS_UnloadFile.
+ * Memory is allocated for the new object. May be freed by calling
+ * TclFS_UnloadFile.
*
*----------------------------------------------------------------------
*/
/*
- * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY
- * error) yet somehow trash some internal data structures which prevents the
- * second and further shared libraries from getting properly loaded. Only the
- * first is ok. We try to get around the issue by not unlinking,
- * i.e. emulating the behaviour of the older HPUX which denied removal.
+ * Modern HPUX allows the unlink (no ETXTBSY error) yet somehow trashes some
+ * internal data structures, preventing any additional dynamic shared objects
+ * from getting properly loaded. Only the first is ok. Work around the issue
+ * by not unlinking, i.e., emulating the behaviour of the older HPUX which
+ * denied removal.
*
* Doing the unlink is also an issue within docker containers, whose AUFS
* bungles this as well, see
* https://github.com/dotcloud/docker/issues/1911
*
- * For these situations the change below makes the execution of the unlink
- * semi-controllable at runtime.
- *
- * An AUFS filesystem (if it can be detected) will force avoidance of
- * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a
- * users general request (unlink and not.
- *
- * By default the unlink is done (if not in AUFS). However if the variable is
- * present and set to true (any integer > 0) then the unlink is skipped.
*/
#ifdef _WIN32
@@ -3166,55 +3092,66 @@ Tcl_FSLoadFile(
#endif
static int
-skipUnlink (Tcl_Obj* shlibFile)
+skipUnlink(
+ Tcl_Obj *shlibFile)
{
- /* Order of testing:
- * 1. On hpux we generally want to skip unlink in general
+ /*
+ * Unlinking is not performed in the following cases:
*
- * Outside of hpux then:
- * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int)
- * 3. For general AUFS environment (statfs, if available).
+ * 1. The operating system is HPUX.
*
- * Ad 2: This variable can disable/override the AUFS detection, i.e. for
- * testing if a newer AUFS does not have the bug any more.
+ * 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
+ * set to true (an integer > 0)
+ *
+ * 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available).
*
- * Ad 3: This is conditionally compiled in. Condition currently must be set manually.
- * This part needs proper tests in the configure(.in).
*/
+
#ifdef hpux
+ (void)shlibFile;
return 1;
#else
- WCHAR *skipstr;
+ WCHAR *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
- skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
-#ifdef TCL_TEMPLOAD_NO_UNLINK
+#ifndef TCL_TEMPLOAD_NO_UNLINK
+ (void)shlibFile;
+#else
+/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether
+ * this automatic overriding of unlink is included.
+ */
#ifndef NO_FSTATFS
{
struct statfs fs;
- /* Have fstatfs. May not have the AUFS super magic ... Indeed our build
+ /*
+ * Have fstatfs. May not have the AUFS super magic ... Indeed our build
* box is too old to have it directly in the headers. Define taken from
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
- * Better reference will be gladly taken.
+ * Better reference will be gladly accepted.
*/
#ifndef AUFS_SUPER_MAGIC
+/* AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for
+ * testing if a newer AUFS does not have the bug any more.
+*/
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
- if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) &&
- (fs.f_type == AUFS_SUPER_MAGIC)) {
+ if ((statfs(Tcl_GetString(shlibFile), &fs) == 0)
+ && (fs.f_type == AUFS_SUPER_MAGIC)) {
return 1;
}
}
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
- /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
- * Don't skip */
+ /*
+ * No HPUX, environment variable override, or AUFS detected. Perform
+ * unlink.
+ */
return 0;
#endif /* hpux */
}
@@ -3222,16 +3159,15 @@ skipUnlink (Tcl_Obj* shlibFile)
int
Tcl_LoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Obj *pathPtr, /* Name of the file containing the desired
- * code. */
- const char *const symbols[],/* Names of functions to look up in the file's
- * symbol table. */
+ Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic
+ * shared object. */
+ const char *const symbols[],/* A null-terminated array of names of
+ * functions to find in the loaded object. */
int flags, /* Flags */
- void *procVPtrs, /* Where to return the addresses corresponding
- * to symbols[]. */
- Tcl_LoadHandle *handlePtr) /* Filled with token for shared library
- * information which can be used in
- * TclpFindSymbol. */
+ void *procVPtrs, /* A place to store pointers to the functions
+ * named by symbols[]. */
+ Tcl_LoadHandle *handlePtr) /* A place to hold a token for the loaded object.
+ * Can be used by TclpFindSymbol. */
{
void **procPtrs = (void **) procVPtrs;
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
@@ -3269,10 +3205,11 @@ Tcl_LoadFile(
}
/*
- * The filesystem doesn't support 'load', so we fall back on the following
- * technique:
- *
- * First check if it is readable -- and exists!
+ * The filesystem doesn't support 'load'. Fall to the following:
+ */
+
+ /*
+ * Make sure the file is accessible.
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
@@ -3286,9 +3223,9 @@ Tcl_LoadFile(
#ifdef TCL_LOAD_FROM_MEMORY
/*
- * The platform supports loading code from memory, so ask for a buffer of
- * the appropriate size, read the file into it and load the code from the
- * buffer:
+ * The platform supports loading a dynamic shared object from memory.
+ * Create a sufficiently large buffer, read the file into it, and then load
+ * the dynamic shared object from the buffer:
*/
{
@@ -3304,7 +3241,7 @@ Tcl_LoadFile(
size = (int) statBuf.st_size;
/*
- * Tcl_Read takes an int: check that file size isn't wide.
+ * Tcl_Read takes an int: Determine whether the file size is wide.
*/
if (size != (Tcl_WideInt) statBuf.st_size) {
@@ -3319,7 +3256,7 @@ Tcl_LoadFile(
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
- ret = Tcl_Read(data, buffer, size);
+ ret = Tcl_Read(data, (char *)buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
&unloadProcPtr, flags);
@@ -3335,8 +3272,7 @@ Tcl_LoadFile(
#endif /* TCL_LOAD_FROM_MEMORY */
/*
- * Get a temporary filename to use, first to copy the file into, and then
- * to load.
+ * Get a temporary filename, first to copy the file into, and then to load.
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
@@ -3348,11 +3284,15 @@ Tcl_LoadFile(
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
/*
- * We already know we can't use Tcl_FSLoadFile from this filesystem,
- * and we must avoid a possible infinite loop. Try to delete the file
- * we probably created, and then exit.
+ * Tcl_FSLoadFile isn't available for the filesystem of the temporary
+ * file. In order to avoid a possible infinite loop, do not attempt to
+ * load further.
*/
+ /*
+ * Try to delete the file we probably created and then exit.
+ */
+
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
if (interp) {
@@ -3363,10 +3303,6 @@ Tcl_LoadFile(
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
- /*
- * Cross-platform copy failed.
- */
-
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
@@ -3374,10 +3310,9 @@ Tcl_LoadFile(
#ifndef _WIN32
/*
- * Do we need to set appropriate permissions on the file? This may be
- * required on some systems. On Unix we could loop over the file
- * attributes, and set any that are called "-permissions" to 0700. However
- * we just do this directly, like this:
+ * It might be necessary on some systems to set the appropriate permissions
+ * on the file. On Unix we could loop over the file attributes and set any
+ * that are called "-permissions" to 0700, but just do it directly instead:
*/
{
@@ -3394,8 +3329,8 @@ Tcl_LoadFile(
#endif
/*
- * We need to reset the result now, because the cross-filesystem copy may
- * have stored the number of bytes in the result.
+ * The cross-filesystem copy may have stored the number of bytes in the
+ * result, so reset the result now.
*/
if (interp) {
@@ -3405,30 +3340,24 @@ Tcl_LoadFile(
retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs,
&newLoadHandle);
if (retVal != TCL_OK) {
- /*
- * The file didn't load successfully.
- */
-
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
- * Try to delete the file immediately - this is possible in some OSes, and
- * avoids any worries about leaving the copy laying around on exit.
+ * Try to delete the file immediately. Some operatings systems allow this,
+ * and it avoids leaving the copy laying around after exit.
*/
- if (
- !skipUnlink (copyToPtr) &&
- (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
+ if (!skipUnlink(copyToPtr) &&
+ (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
/*
- * We tell our caller about the real shared library which was loaded.
- * Note that this does mean that the package list maintained by 'load'
- * will store the original (vfs) path alongside the temporary load
- * handle and unload proc ptr.
+ * Tell the caller all the details: The package list maintained by
+ * 'load' stores the original (vfs) pathname, the handle of object
+ * loaded from the temporary file, and the unloadProcPtr.
*/
*handlePtr = newLoadHandle;
@@ -3439,47 +3368,41 @@ Tcl_LoadFile(
}
/*
- * When we unload this file, we need to divert the unloading so we can
- * unload and cleanup the temporary file correctly.
+ * Divert the unloading in order to unload and cleanup the temporary file.
*/
- tvdlPtr = ckalloc(sizeof(FsDivertLoad));
+ tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad));
/*
- * Remember three pieces of information. This allows us to cleanup the
- * diverted load completely, on platforms which allow proper unloading of
- * code.
+ * Remember three pieces of information in order to clean up the diverted
+ * load completely on platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
if (copyFsPtr != &tclNativeFilesystem) {
- /*
- * copyToPtr is already incremented for this reference.
- */
-
+ /* refCount of copyToPtr is already incremented. */
tvdlPtr->divertedFile = copyToPtr;
/*
- * This is the filesystem we loaded it into. Since we have a reference
- * to 'copyToPtr', we already have a refCount on this filesystem, so
- * we don't need to worry about it disappearing on us.
+ * This is the filesystem for the temporary file the object was loaded
+ * from. A reference to copyToPtr is already stored in
+ * tvdlPtr->divertedFile, so need need to increment the refCount again.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/*
- * We need the native rep.
+ * Grab the native representation.
*/
tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));
/*
- * We don't need or want references to the copied Tcl_Obj or the
- * filesystem if it is the native one.
+ * Don't keeep a reference to the Tcl_Obj or the native filesystem.
*/
tvdlPtr->divertedFile = NULL;
@@ -3489,7 +3412,7 @@ Tcl_LoadFile(
copyToPtr = NULL;
- divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_));
+ divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
divertedLoadHandle->clientData = tvdlPtr;
divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
@@ -3502,8 +3425,8 @@ Tcl_LoadFile(
resolveSymbols:
/*
- * At this point, *handlePtr is already set up to the handle for the
- * loaded library. We now try to resolve the symbols.
+ * handlePtr now contains a token for the loaded object.
+ * Resolve the symbols.
*/
if (symbols != NULL) {
@@ -3512,9 +3435,8 @@ Tcl_LoadFile(
if (procPtrs[i] == NULL) {
/*
* At least one symbol in the list was not found. Unload the
- * file, and report the problem back to the caller.
- * (Tcl_FindSymbol should already have left an appropriate
- * error message.)
+ * file and return an error code. Tcl_FindSymbol should have
+ * already left an appropriate error message.
*/
(*handlePtr)->unloadFileProcPtr(*handlePtr);
@@ -3531,16 +3453,17 @@ Tcl_LoadFile(
*
* DivertFindSymbol --
*
- * Find a symbol in a shared library loaded by copy-from-VFS.
+ * Find a symbol in a shared library loaded by making a copying a file
+ * from the virtual filesystem to a native filesystem.
*
*----------------------------------------------------------------------
*/
static void *
DivertFindSymbol(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_LoadHandle loadHandle, /* Handle to the diverted module */
- const char *symbol) /* Symbol to resolve */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */
+ const char *symbol) /* The name of symbol to resolve. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
@@ -3553,83 +3476,75 @@ DivertFindSymbol(
*
* DivertUnloadFile --
*
- * Unloads a file that has been loaded by copying from VFS to the native
- * filesystem.
- *
- * Parameters:
- * loadHandle -- Handle of the file to unload
+ * Unloads an object that was loaded from a temporary file copied from the
+ * virtual filesystem the native filesystem.
*
*----------------------------------------------------------------------
*/
static void
DivertUnloadFile(
- Tcl_LoadHandle loadHandle)
+ Tcl_LoadHandle loadHandle) /* A handle for the loaded object. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle;
- /*
- * This test should never trigger, since we give the client data in the
- * function above.
- */
-
if (tvdlPtr == NULL) {
+ /*
+ * tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here.
+ */
+
return;
}
originalHandle = tvdlPtr->loadHandle;
/*
- * Call the real 'unloadfile' proc we actually used. It is very important
- * that we call this first, so that the shared library is actually
- * unloaded by the OS. Otherwise, the following 'delete' may well fail
- * because the shared library is still in use.
+ * Call the real 'unloadfile' proc. This must be called first so that the
+ * shared library is actually unloaded by the OS. Otherwise, the following
+ * 'delete' may fail because the shared library is still in use.
*/
originalHandle->unloadFileProcPtr(originalHandle);
/*
- * What filesystem contains the temp copy of the library?
+ * Determine which filesystem contains the temporary copy of the file.
*/
if (tvdlPtr->divertedFilesystem == NULL) {
/*
- * It was the native filesystem, and we have a special function
- * available just for this purpose, which we know works even at this
- * late stage.
+ * Use the function for the native filsystem, which works works even at
+ * this late stage.
*/
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
- * Remove the temporary file we created. Note, we may crash here
- * because encodings have been taken down already.
+ * Remove the temporary file. If encodings have been cleaned up
+ * already, this may crash.
*/
if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
!= TCL_OK) {
/*
- * The above may have failed because the filesystem, or something
- * it depends upon (e.g. encodings) have been taken down because
- * Tcl is exiting.
- *
- * We may need to work out how to delete this file more robustly
- * (or give the filesystem the information it needs to delete the
- * file more robustly).
+ * This may have happened because Tcl is exiting, and encodings may
+ * have already been deleted or something else the filesystem
+ * depends on may be gone.
*
- * In particular, one problem might be that the filesystem cannot
- * extract the information it needs from the above path object
+ * TO DO: Figure out how to delete this file more robustly, or
+ * give the filesystem the information it needs to delete the file
+ * more robustly. One problem might be that the filesystem cannot
+ * extract the information it needs from the above pathname object
* because Tcl's entire filesystem apparatus (the code in this
- * file) has been finalized, and it refuses to pass the internal
- * representation to the filesystem.
+ * file) has been finalized and there is no way to get the native
+ * handle of the file.
*/
}
/*
- * And free up the allocations. This will also of course remove a
- * refCount from the Tcl_Filesystem to which this file belongs, which
- * could then free up the filesystem if we are exiting.
+ * This also decrements the refCount of the Tcl_Filesystem
+ * corresponding to this file. which might cause the filesystem to be
+ * deallocated if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
@@ -3644,23 +3559,23 @@ DivertUnloadFile(
*
* Tcl_FindSymbol --
*
- * Find a symbol in a loaded library
+ * Find a symbol in a loaded object.
*
- * Results:
- * Returns a pointer to the symbol if found. If not found, returns NULL
- * and leaves an error message in the interpreter result.
+ * Previously filesystem-specific, but has been made portable by having
+ * TclpDlopen return a structure that includes procedure pointers.
*
- * This function was once filesystem-specific, but has been made portable by
- * having TclpDlopen return a structure that includes procedure pointers.
+ * Results:
+ * Returns a pointer to the symbol if found. Otherwise, sets
+ * an error message in the interpreter result and returns NULL.
*
*----------------------------------------------------------------------
*/
void *
Tcl_FindSymbol(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_LoadHandle loadHandle, /* Handle to the loaded library */
- const char *symbol) /* Name of the symbol to resolve */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */
+ const char *symbol) /* The name name of the symbol to resolve. */
{
return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol);
}
@@ -3670,16 +3585,15 @@ Tcl_FindSymbol(
*
* Tcl_FSUnloadFile --
*
- * Unloads a library given its handle. Checks first that the library
- * supports unloading.
+ * Unloads a loaded object if unloading is supported for the object.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnloadFile(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_LoadHandle handle) /* Handle of the file to unload */
+ Tcl_Interp *interp, /* The relevant interpreter. */
+ Tcl_LoadHandle handle) /* A handle for the object to unload. */
{
if (handle->unloadFileProcPtr == NULL) {
if (interp != NULL) {
@@ -3700,52 +3614,59 @@ Tcl_FSUnloadFile(
*
* Tcl_FSLink --
*
- * This function replaces the library version of readlink() and can also
- * be used to make links. The appropriate function for the filesystem to
- * which pathPtr belongs will be called.
+ * Creates or inspects a link by calling 'linkProc' of the filesystem
+ * corresponding to the given pathname. Replaces the library version of
+ * readlink().
*
* Results:
- * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents
- * of the symbolic link given by 'pathPtr', or NULL if the symbolic link
- * could not be read. The result is owned by the caller, which should
- * call Tcl_DecrRefCount when the result is no longer needed.
+ * If toPtr is NULL, a Tcl_Obj containing the value the symbolic link for
+ * 'pathPtr', or NULL if a symbolic link was not accessible. The caller
+ * should Tcl_DecrRefCount on the result to release it. Otherwise NULL.
*
- * If toPtr is non-NULL, then the result is toPtr if the link action was
- * successful, or NULL if not. In this case the result has no additional
- * reference count, and need not be freed. The actual action to perform
- * is given by the 'linkAction' flags, which is an or'd combination of:
+ * In this case the result has no additional reference count and need not
+ * be freed. The actual action to perform is given by the 'linkAction'
+ * flags, which is a combination of:
*
* TCL_CREATE_SYMBOLIC_LINK
* TCL_CREATE_HARD_LINK
*
- * Note that most filesystems will not support linking across to
- * different filesystems, so this function will usually fail unless toPtr
- * is in the same FS as pathPtr.
+ * Most filesystems do not support linking across to different
+ * filesystems, so this function usually fails if the filesystem
+ * corresponding to toPtr is not the same as the filesystem corresponding
+ * to pathPtr.
*
* Side effects:
- * See readlink() documentation. A new filesystem link object may appear.
+ * Creates or sets a link if toPtr is not NULL.
+ *
+ * See readlink().
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(
- Tcl_Obj *pathPtr, /* Path of file to readlink or link. */
- Tcl_Obj *toPtr, /* NULL or path to be linked to. */
+ Tcl_Obj *pathPtr, /* Pathaname of file. */
+ Tcl_Obj *toPtr, /*
+ * NULL or the pathname of a file to link to.
+ */
int linkAction) /* Action to perform. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr != NULL && fsPtr->linkProc != NULL) {
- return fsPtr->linkProc(pathPtr, toPtr, linkAction);
+ if (fsPtr) {
+ if (fsPtr->linkProc == NULL) {
+ Tcl_SetErrno(ENOTSUP);
+ return NULL;
+ } else {
+ return fsPtr->linkProc(pathPtr, toPtr, linkAction);
+ }
}
/*
- * If S_IFLNK isn't defined it means that the machine doesn't support
- * symbolic links, so the file can't possibly be a symbolic link. Generate
- * an EINVAL error, which is what happens on machines that do support
- * symbolic links when you invoke readlink on a file that isn't a symbolic
- * link.
+ * If S_IFLNK isn't defined the machine doesn't support symbolic links, so
+ * the file can't possibly be a symbolic link. Generate an EINVAL error,
+ * which is what happens on machines that do support symbolic links when
+ * readlink is called for a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
@@ -3761,16 +3682,9 @@ Tcl_FSLink(
*
* Tcl_FSListVolumes --
*
- * Lists the currently mounted volumes. The chain of functions that have
- * been "inserted" into the filesystem will be called in succession; each
- * may return a list of volumes, all of which are added to the result
- * until all mounted file systems are listed.
- *
- * Notice that we assume the lists returned by each filesystem (if non
- * NULL) have been given a refCount for us already. However, we are NOT
- * allowed to hang on to the list itself (it belongs to the filesystem we
- * called). Therefore we quite naturally add its contents to the result
- * we are building, and then decrement the refCount.
+ * Lists the currently mounted volumes by calling `listVolumesProc` of
+ * each registered filesystem, and combining the results to form a list of
+ * volumes.
*
* Results:
* The list of volumes, in an object which has refCount 0.
@@ -3787,14 +3701,13 @@ Tcl_FSListVolumes(void)
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr;
- TclNewObj(resultPtr);
/*
- * Call each of the "listVolumes" function in succession. A non-NULL
- * return value indicates the particular function has succeeded. We call
- * all the functions registered, since we want a list of all drives from
- * all filesystems.
+ * Call each "listVolumes" function of each registered filesystem in
+ * succession. A non-NULL return value indicates the particular function
+ * has succeeded.
*/
+ TclNewObj(resultPtr);
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
@@ -3803,6 +3716,12 @@ Tcl_FSListVolumes(void)
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
+ /*
+ * The refCount of each list returned by a `listVolumesProc`
+ * is already incremented. Do not hang onto the list, though.
+ * It belongs to the filesystem. Add its contents to the
+ * result we are building, and then decrement the refCount.
+ */
Tcl_DecrRefCount(thisFsVolumes);
}
}
@@ -3818,22 +3737,21 @@ Tcl_FSListVolumes(void)
*
* FsListMounts --
*
- * List all mounts within the given directory, which match the given
- * pattern.
+ * Lists the mounts mathing the given pattern in the given directory.
*
* Results:
- * The list of mounts, in a list object which has refCount 0, or NULL if
- * we didn't even find any filesystems to try to list mounts.
+ * A list, having a refCount of 0, of the matching mounts, or NULL if no
+ * search was performed because no filesystem provided a search routine.
*
* Side effects:
- * None
+ * None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
FsListMounts(
- Tcl_Obj *pathPtr, /* Contains path to directory to search. */
+ Tcl_Obj *pathPtr, /* Pathname of directory to search. */
const char *pattern) /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
@@ -3841,10 +3759,8 @@ FsListMounts(
Tcl_Obj *resultPtr = NULL;
/*
- * Call each of the "matchInDirectory" functions in succession, with the
- * specific type information 'mountsOnly'. A non-NULL return value
- * indicates the particular function has succeeded. We call all the
- * functions registered, since we want a list from each filesystems.
+ * Call the matchInDirectory function of each registered filesystem,
+ * passing it 'mountsOnly'. Results accumulate in resultPtr.
*/
fsRecPtr = FsGetFirstFilesystem();
@@ -3870,34 +3786,32 @@ FsListMounts(
*
* Tcl_FSSplitPath --
*
- * This function takes the given Tcl_Obj, which should be a valid path,
- * and returns a Tcl List object containing each segment of that path as
- * an element.
+ * Splits a pathname into its components.
*
* Results:
- * Returns list object with refCount of zero. If the passed-in lenPtr is
- * non-NULL, we use it to return the number of elements in the returned
- * list.
+ * A list with refCount of zero.
*
* Side effects:
- * None.
+ * 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, /* Path to split. */
- int *lenPtr) /* int to store number of path elements. */
+ Tcl_Obj *pathPtr, /* The pathname to split. */
+ int *lenPtr) /* A place to hold the number of pathname
+ * elements. */
{
- Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
+ Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */
const Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
const char *p;
/*
- * Perform platform specific splitting.
+ * Perform platform-specific splitting.
*/
if (TclFSGetPathType(pathPtr, &fsPtr,
@@ -3909,9 +3823,7 @@ Tcl_FSSplitPath(
return TclpNativeSplitPath(pathPtr, lenPtr);
}
- /*
- * We assume separators are single characters.
- */
+ /* Assume each separator is a single character. */
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
@@ -3924,9 +3836,9 @@ Tcl_FSSplitPath(
}
/*
- * Place the drive name as first element of the result list. The drive
- * name may contain strange characters, like colons and multiple forward
- * slashes (for example 'ftp://' is a valid vfs drive name)
+ * Add the drive name as first element of the result. The drive name may
+ * contain strange characters like colons and sequences of forward slashes
+ * For example, 'ftp://' is a valid drive name.
*/
TclNewObj(result);
@@ -3936,7 +3848,7 @@ Tcl_FSSplitPath(
p += driveNameLength;
/*
- * Add the remaining path elements to the list.
+ * Add the remaining pathname elements to the list.
*/
for (;;) {
@@ -3963,12 +3875,8 @@ Tcl_FSSplitPath(
}
}
- /*
- * Compute the number of elements in the result.
- */
-
if (lenPtr != NULL) {
- TclListObjLength(NULL, result, lenPtr);
+ TclListObjLengthM(NULL, result, lenPtr);
}
return result;
}
@@ -3977,38 +3885,34 @@ Tcl_FSSplitPath(
*
* TclGetPathType --
*
- * Helper function used by FSGetPathType.
+ * Helper function used by TclFSGetPathType and TclJoinPath.
*
* Results:
- * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
- * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and
- * only if it is non-NULL and the function's return value is
- * TCL_PATH_ABSOLUTE.
+ * One of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
- * None.
+ * See **filesystemPtrptr, *driveNameLengthPtr and **driveNameRef,
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclGetPathType(
- Tcl_Obj *pathPtr, /* Path to determine type for. */
+ Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
- /* If absolute path and this is not NULL, then
- * set to the filesystem which claims this
- * path. */
- int *driveNameLengthPtr, /* If the path is absolute, and this is
- * non-NULL, then set to the length of the
- * driveName. */
- Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
- * non-NULL, then set to the name of the
- * drive, network-volume which contains the
- * path, already with a refCount for the
- * caller. */
+ /* If not NULL, a place in which to store a
+ * pointer to the filesystem for this pathname
+ * if it is absolute. */
+ int *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. */
{
int pathLen;
- const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
@@ -4029,14 +3933,14 @@ TclGetPathType(
*
* TclFSNonnativePathType --
*
- * Helper function used by TclGetPathType. Its purpose is to check
- * whether the given path starts with a string which corresponds to a
- * file volume in any registered filesystem except the native one. For
- * speed and historical reasons the native filesystem has special
- * hard-coded checks dotted here and there in the filesystem code.
+ * Helper function used by TclGetPathType. Checks whether the given
+ * pathname starts with a string which corresponds to a file volume in
+ * some registered filesystem other than the native one. For speed and
+ * historical reasons the native filesystem has special hard-coded checks
+ * dotted here and there in the filesystem code.
*
* Results:
- * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
+ * One of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
* reference will be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
@@ -4048,49 +3952,45 @@ TclGetPathType(
Tcl_PathType
TclFSNonnativePathType(
- const char *path, /* Path to determine type for. */
- int pathLen, /* Length of the path. */
+ const char *path, /* Pathname to determine the type of. */
+ int pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
- /* If absolute path and this is not NULL, then
- * set to the filesystem which claims this
- * path. */
- int *driveNameLengthPtr, /* If the path is absolute, and this is
- * non-NULL, then set to the length of the
- * driveName. */
- Tcl_Obj **driveNameRef) /* If the path is absolute, and this is
- * non-NULL, then set to the name of the
- * drive, network-volume which contains the
- * path, already with a refCount for the
- * caller. */
+ /* If not NULL, a place to store a pointer to
+ * the filesystem for this pathname when it is
+ * an absolute pathname. */
+ int *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. */
{
FilesystemRecord *fsRecPtr;
Tcl_PathType type = TCL_PATH_RELATIVE;
/*
- * Call each of the "listVolumes" function in succession, checking whether
- * the given path is an absolute path on any of the volumes returned (this
- * is done by checking whether the path's prefix matches).
+ * Determine whether the given pathname is an absolute pathname on some
+ * filesystem other than the native filesystem.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
/*
- * We want to skip the native filesystem in this loop because
- * otherwise we won't necessarily pass all the Tcl testsuite - this is
- * because some of the tests artificially change the current platform
- * (between Win, Unix) but the list of volumes we get by calling
- * fsRecPtr->fsPtr->listVolumesProc will reflect the current (real)
- * platform only and this may cause some tests to fail. In particular,
- * on Unix '/' will match the beginning of certain absolute Windows
- * paths starting '//' and those tests will go wrong.
+ * Skip the the native filesystem because otherwise some of the tests
+ * in the Tcl testsuite might fail because some of the tests
+ * artificially change the current platform (between win, unix) but the
+ * list of volumes obtained by calling fsRecPtr->fsPtr->listVolumesProc
+ * reflects the current (real) platform only. In particular, on Unix
+ * '/' matchs the beginning of certain absolute Windows pathnames
+ * starting '//' and those tests go wrong.
*
- * Besides these test-suite issues, there is one other reason to skip
- * the native filesystem - since the tclFilename.c code has nice fast
- * 'absolute path' checkers, we don't want to waste time repeating
- * that effort here, and this function is actually called quite often,
- * so if we can save the overhead of the native filesystem returning
- * us a list of volumes all the time, it is better.
+ * There is another reason to skip the native filesystem: Since the
+ * tclFilename.c code has nice fast 'absolute path' checkers, there is
+ * 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)
@@ -4099,16 +3999,15 @@ TclFSNonnativePathType(
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
- if (TclListObjLength(NULL, thisFsVolumes, &numVolumes)
+ if (TclListObjLengthM(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
* This is VERY bad; the listVolumesProc didn't return a
- * valid list. Set numVolumes to -1 so that we skip the
- * while loop below and just return with the current value
- * of 'type'.
+ * valid list. Set numVolumes to -1 to skip the loop below
+ * and just return with the current value of 'type'.
*
- * It would be better if we could signal an error here
- * (but Tcl_Panic seems a bit excessive).
+ * It would be better to signal an error here, but
+ * Tcl_Panic seems a bit excessive.
*/
numVolumes = -1;
@@ -4120,7 +4019,7 @@ TclFSNonnativePathType(
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
- strVol = Tcl_GetStringFromObj(vol,&len);
+ strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
@@ -4142,7 +4041,7 @@ TclFSNonnativePathType(
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/*
- * We don't need to examine any more filesystems.
+ * No need to to examine additional filesystems.
*/
break;
@@ -4160,12 +4059,13 @@ TclFSNonnativePathType(
*
* Tcl_FSRenameFile --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystems rename function. Otherwise we simply return the POSIX
- * error 'EXDEV', and -1.
+ * If the two pathnames correspond to the same filesystem, call
+ * 'renameFileProc' of that filesystem. Otherwise return the POSIX error
+ * 'EXDEV', and -1.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl error code if a rename function was called, or -1
+ * otherwise.
*
* Side effects:
* A file may be renamed.
@@ -4175,10 +4075,9 @@ TclFSNonnativePathType(
int
Tcl_FSRenameFile(
- Tcl_Obj *srcPathPtr, /* Pathname of file or dir to be renamed
- * (UTF-8). */
- Tcl_Obj *destPathPtr) /* New pathname of file or directory
- * (UTF-8). */
+ Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be
+ renamed. */
+ Tcl_Obj *destPathPtr) /* The new pathname for the file. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4201,27 +4100,27 @@ Tcl_FSRenameFile(
*
* Tcl_FSCopyFile --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystem's copy function. Otherwise we simply return the POSIX error
- * 'EXDEV', and -1.
+ * If both pathnames correspond to the same filesystem, calls
+ * 'copyFileProc' of that filesystem.
*
- * Note that in the native filesystems, 'copyFileProc' is defined to copy
- * soft links (i.e. it copies the links themselves, not the things they
- * point to).
+ * In the native filesystems, 'copyFileProc' copies a link itself, not the
+ * thing the link points to.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl return code if a copyFileProc was called, or -1
+ * otherwise.
*
* Side effects:
- * A file may be copied.
+ * A file might be copied. The POSIX error 'EXDEV' is set if a copy
+ * function was not called.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyFile(
- Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */
- Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */
+ Tcl_Obj *srcPathPtr, /* The pathname of file to be copied. */
+ Tcl_Obj *destPathPtr) /* The new pathname to copy the file to. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4243,15 +4142,14 @@ Tcl_FSCopyFile(
*
* TclCrossFilesystemCopy --
*
- * Helper for above function, and for Tcl_FSLoadFile, to copy files from
- * one filesystem to another. This function will overwrite the target
- * file if it already exists.
+ * Helper for Tcl_FSCopyFile and Tcl_FSLoadFile. Copies a file from one
+ * filesystem to another, overwiting any file that already exists.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code.
*
* Side effects:
- * A file may be created.
+ * A file may be copied.
*
*---------------------------------------------------------------------------
*/
@@ -4259,8 +4157,8 @@ Tcl_FSCopyFile(
int
TclCrossFilesystemCopy(
Tcl_Interp *interp, /* For error messages. */
- Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */
- Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */
+ Tcl_Obj *source, /* Pathname of file to be copied. */
+ Tcl_Obj *target) /* Pathname to copy the file to. */
{
int result = TCL_ERROR;
int prot = 0666;
@@ -4271,7 +4169,7 @@ TclCrossFilesystemCopy(
out = Tcl_FSOpenFileChannel(interp, target, "wb", prot);
if (out == NULL) {
/*
- * It looks like we cannot copy it over. Bail out...
+ * Failed to open an output channel. Bail out.
*/
goto done;
}
@@ -4279,7 +4177,7 @@ TclCrossFilesystemCopy(
in = Tcl_FSOpenFileChannel(interp, source, "rb", prot);
if (in == NULL) {
/*
- * This is very strange, caller should have checked this...
+ * Could not open an input channel. Why didn't the caller check this?
*/
Tcl_Close(interp, out);
@@ -4287,8 +4185,8 @@ TclCrossFilesystemCopy(
}
/*
- * Copy it synchronously. We might wish to add an asynchronous option to
- * support vfs's which are slow (e.g. network sockets).
+ * Copy the file synchronously. TO DO: Maybe add an asynchronous option
+ * to support virtual filesystems that are slow (e.g. network sockets).
*/
if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
@@ -4296,7 +4194,7 @@ TclCrossFilesystemCopy(
}
/*
- * If the copy failed, assume that copy channel left a good error message.
+ * If the copy failed, assume that copy channel left an error message.
*/
Tcl_Close(interp, in);
@@ -4321,11 +4219,11 @@ TclCrossFilesystemCopy(
*
* Tcl_FSDeleteFile --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'deleteFileProc' of the filesystem corresponding to the given
+ * pathname.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code.
*
* Side effects:
* A file may be deleted.
@@ -4338,11 +4236,17 @@ Tcl_FSDeleteFile(
Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ int err;
- if (fsPtr != NULL && fsPtr->deleteFileProc != NULL) {
- return fsPtr->deleteFileProc(pathPtr);
+ if (fsPtr == NULL) {
+ err = ENOENT;
+ } else {
+ if (fsPtr->deleteFileProc != NULL) {
+ return fsPtr->deleteFileProc(pathPtr);
+ }
+ err = ENOTSUP;
}
- Tcl_SetErrno(ENOENT);
+ Tcl_SetErrno(err);
return -1;
}
@@ -4351,14 +4255,15 @@ Tcl_FSDeleteFile(
*
* Tcl_FSCreateDirectory --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'createDirectoryProc' of the filesystem corresponding to the
+ * given pathname.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code, or -1 if no createDirectoryProc is found.
*
* Side effects:
- * A directory may be created.
+ * A directory may be created. POSIX error 'ENOENT' is set if no
+ * createDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
@@ -4368,11 +4273,17 @@ Tcl_FSCreateDirectory(
Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ int err;
- if (fsPtr != NULL && fsPtr->createDirectoryProc != NULL) {
- return fsPtr->createDirectoryProc(pathPtr);
+ if (fsPtr == NULL) {
+ err = ENOENT;
+ } else {
+ if (fsPtr->createDirectoryProc != NULL) {
+ return fsPtr->createDirectoryProc(pathPtr);
+ }
+ err = ENOTSUP;
}
- Tcl_SetErrno(ENOENT);
+ Tcl_SetErrno(err);
return -1;
}
@@ -4381,27 +4292,29 @@ Tcl_FSCreateDirectory(
*
* Tcl_FSCopyDirectory --
*
- * If the two paths given belong to the same filesystem, we call that
- * filesystems copy-directory function. Otherwise we simply return the
- * POSIX error 'EXDEV', and -1.
+ * If both pathnames correspond to the the same filesystem, calls
+ * 'copyDirectoryProc' of that filesystem.
*
* Results:
- * Standard Tcl error code if a function was called.
+ * A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found.
*
* Side effects:
- * A directory may be copied.
+ * A directory may be copied. POSIX error 'EXDEV' is set if no
+ * copyDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyDirectory(
- Tcl_Obj *srcPathPtr, /* Pathname of directory to be copied
- * (UTF-8). */
- Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */
- Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new
- * object containing name of file causing
- * error, with refCount 1. */
+ Tcl_Obj *srcPathPtr, /* The pathname of the directory to be
+ * copied. */
+ Tcl_Obj *destPathPtr, /* The pathname of the target directory. */
+ Tcl_Obj **errorPtr) /* If not NULL, and there is an error, a place
+ * to store a pointer to a new object, with
+ * its refCount already incremented, and
+ * containing the pathname name of file
+ * causing the error. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
@@ -4423,57 +4336,58 @@ Tcl_FSCopyDirectory(
*
* Tcl_FSRemoveDirectory --
*
- * The appropriate function for the filesystem to which pathPtr belongs
- * will be called.
+ * Calls 'removeDirectoryProc' of the filesystem corresponding to remove
+ * pathPtr.
*
* Results:
- * Standard Tcl error code.
+ * A standard Tcl return code, or -1 if no removeDirectoryProc is found.
*
* Side effects:
- * A directory may be deleted.
+ * A directory may be removed. POSIX error 'ENOENT' is set if no
+ * removeDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(
- Tcl_Obj *pathPtr, /* Pathname of directory to be removed
- * (UTF-8). */
- int recursive, /* If non-zero, removes directories that are
- * nonempty. Otherwise, will only remove empty
- * directories. */
- Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new
- * object containing name of file causing
- * error, with refCount 1. */
+ Tcl_Obj *pathPtr, /* The pathname of the directory to be removed.
+ */
+ int recursive, /* If zero, removes only an empty directory.
+ * Otherwise, removes the directory and all its
+ * contents. */
+ Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a
+ * place to store a a pointer to a new
+ * object having a refCount of 1 and containing
+ * the name of the file that produced an error.
+ * */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
- if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) {
+ if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
-
- /*
- * When working recursively, we check whether the cwd lies inside this
- * directory and move it if it does.
- */
+ if (fsPtr->removeDirectoryProc == NULL) {
+ Tcl_SetErrno(ENOTSUP);
+ return -1;
+ }
if (recursive) {
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
-
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
int cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
- normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
- cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ normPathStr = TclGetStringFromObj(normPath, &normLen);
+ cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
(size_t) normLen) == 0)) {
/*
- * The cwd is inside the directory, so we perform a 'cd
- * [file dirname $path]'.
+ * The cwd is inside the directory to be removed. Change
+ * the cwd to [file dirname $path].
*/
Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
@@ -4494,16 +4408,14 @@ Tcl_FSRemoveDirectory(
*
* Tcl_FSGetFileSystemForPath --
*
- * This function determines which filesystem to use for a particular path
- * object, and returns the filesystem which accepts this file. If no
- * filesystem will accept this object as a valid file path, then NULL is
- * returned.
+ * Produces the filesystem that corresponds to the given pathname.
*
* Results:
- * NULL or a filesystem which will accept this path.
+ * The corresponding Tcl_Filesystem, or NULL if the pathname is invalid.
*
* Side effects:
- * The object may be converted to a path type.
+ * The internal representation of fsPtrPtr is converted to fsPathType if
+ * needed, and that internal representation is updated as needed.
*
*---------------------------------------------------------------------------
*/
@@ -4520,41 +4432,38 @@ Tcl_FSGetFileSystemForPath(
return NULL;
}
- /*
- * If the object has a refCount of zero, we reject it. This is to avoid
- * possible segfaults or nondeterministic memory leaks (i.e. the user
- * doesn't know if they should decrement the ref count on return or not).
- */
-
if (pathPtr->refCount == 0) {
+ /*
+ * Avoid possible segfaults or nondeterministic memory leaks where the
+ * reference count has been incorreclty managed.
+ */
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
- /*
- * Check if the filesystem has changed in some way since this object's
- * internal representation was calculated. Before doing that, assure we
- * have the most up-to-date copy of the first filesystem. This is
- * accomplished by the FsGetFirstFilesystem() call.
- */
-
+ /* Start with an up-to-date copy of the filesystem. */
fsRecPtr = FsGetFirstFilesystem();
Claim();
+ /*
+ * Ensure that pathPtr is a valid pathname.
+ */
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
+ /* not a valid pathname */
Disclaim();
return NULL;
} else if (retVal != NULL) {
- /* TODO: Can this happen? */
+ /*
+ * Found the filesystem in the internal representation of pathPtr.
+ */
Disclaim();
return retVal;
}
/*
- * Call each of the "pathInFilesystem" functions in succession. A
- * non-return value of -1 indicates the particular function has succeeded.
+ * Call each of the "pathInFilesystem" functions in succession until the
+ * corresponding filesystem is found.
*/
-
for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) {
ClientData clientData = NULL;
@@ -4563,10 +4472,10 @@ Tcl_FSGetFileSystemForPath(
}
if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
- /*
- * We assume the type of pathPtr hasn't been changed by the above
- * call to the pathInFilesystemProc.
- */
+ /* This is the filesystem for pathPtr. Assume the type of pathPtr
+ * hasn't been changed by the above call to the
+ * pathInFilesystemProc, and cache this result in the internal
+ * representation of pathPtr. */
TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
Disclaim();
@@ -4583,26 +4492,7 @@ Tcl_FSGetFileSystemForPath(
*
* Tcl_FSGetNativePath --
*
- * This function is for use by the Win/Unix native filesystems, so that
- * they can easily retrieve the native (char* or WCHAR*) representation
- * of a path. Other filesystems will probably want to implement similar
- * functions. They basically act as a safety net around
- * Tcl_FSGetInternalRep. Normally your file-system functions will always
- * be called with path objects already converted to the correct
- * filesystem, but if for some reason they are called directly (i.e. by
- * functions not in this file), then one cannot necessarily guarantee
- * that the path object pointer is from the correct filesystem.
- *
- * Note: in the future it might be desirable to have separate versions
- * of this function with different signatures, for example
- * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
- * native paths are all string based, we use just one function.
- *
- * Results:
- * NULL or a valid native path.
- *
- * Side effects:
- * See Tcl_FSGetInternalRep.
+ * See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
@@ -4619,7 +4509,7 @@ Tcl_FSGetNativePath(
*
* NativeFreeInternalRep --
*
- * Free a native internal representation, which will be non-NULL.
+ * Free a native internal representation.
*
* Results:
* None.
@@ -4641,16 +4531,17 @@ NativeFreeInternalRep(
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
+ * Produce the type of a pathname and the type of its filesystem.
*
- * This function returns a list of two elements. The first element is the
- * name of the filesystem (e.g. "native" or "vfs"), and the second is the
- * particular type of the given path within that filesystem.
*
* Results:
- * A list of two elements.
+ * A list where the first item is the name of the filesystem (e.g.
+ * "native" or "vfs"), and the second item is the type of the given
+ * pathname within that filesystem.
*
* Side effects:
- * The object may be converted to a path type.
+ * The internal representation of pathPtr may be converted to a
+ * fsPathType.
*
*---------------------------------------------------------------------------
*/
@@ -4686,16 +4577,13 @@ Tcl_FSFileSystemInfo(
*
* Tcl_FSPathSeparator --
*
- * This function returns the separator to be used for a given path. The
- * object returned should have a refCount of zero
+ * Produces the separator for given pathname.
*
* Results:
- * A Tcl object, with a refCount of zero. If the caller needs to retain a
- * reference to the object, it should call Tcl_IncrRefCount, and should
- * otherwise free the object.
+ * A Tcl object having a refCount of zero.
*
* Side effects:
- * The path object may be converted to a path type.
+ * The internal representation of pathPtr may be converted to a fsPathType
*
*---------------------------------------------------------------------------
*/
@@ -4716,8 +4604,8 @@ Tcl_FSPathSeparator(
}
/*
- * Allow filesystems not to provide a filesystemSeparatorProc if they wish
- * to use the standard forward slash.
+ * Use the standard forward slash character if filesystem does not to
+ * provide a filesystemSeparatorProc.
*/
TclNewLiteralStringObj(resultObj, "/");
@@ -4729,11 +4617,11 @@ Tcl_FSPathSeparator(
*
* NativeFilesystemSeparator --
*
- * This function is part of the native filesystem support, and returns
- * the separator for the given path.
+ * This function, part of the native filesystem support, returns the
+ * separator for the given pathname.
*
* Results:
- * String object containing the separator character.
+ * The separator character.
*
* Side effects:
* None.
@@ -4743,9 +4631,9 @@ Tcl_FSPathSeparator(
static Tcl_Obj *
NativeFilesystemSeparator(
- Tcl_Obj *pathPtr)
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
- const char *separator = NULL; /* lint */
+ const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 89b19fd..efa29eb 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -5,9 +5,9 @@
* to lookup a keyword in a table of valid values and cache the index of
* the matching entry. Also provides table-based argv/argc processing.
*
- * Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 2006 Sam Bromley.
+ * Copyright © 1990-1994 The Regents of the University of California.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 2006 Sam Bromley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -25,15 +25,9 @@ static int GetIndexFromObjList(Tcl_Interp *interp,
static void UpdateStringOfIndex(Tcl_Obj *objPtr);
static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void FreeIndex(Tcl_Obj *objPtr);
-static int PrefixAllObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int PrefixLongestObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int PrefixMatchObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc PrefixAllObjCmd;
+static Tcl_ObjCmdProc PrefixLongestObjCmd;
+static Tcl_ObjCmdProc PrefixMatchObjCmd;
static void PrintUsage(Tcl_Interp *interp,
const Tcl_ArgvInfo *argTable);
@@ -42,7 +36,7 @@ static void PrintUsage(Tcl_Interp *interp,
* that can be invoked by generic object code.
*/
-static const Tcl_ObjType indexType = {
+const Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
@@ -60,8 +54,8 @@ static const Tcl_ObjType indexType = {
typedef struct {
void *tablePtr; /* Pointer to the table of strings */
- int offset; /* Offset between table entries */
- int index; /* Selected index into table. */
+ Tcl_Size offset; /* Offset between table entries */
+ Tcl_Size index; /* Selected index into table. */
} IndexRep;
/*
@@ -100,6 +94,7 @@ typedef struct {
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
@@ -113,6 +108,7 @@ Tcl_GetIndexFromObj(
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
+ if (!(flags & TCL_INDEX_TEMP_TABLE)) {
/*
* See if there is a valid cached result from a previous lookup (doing the
@@ -120,8 +116,10 @@ Tcl_GetIndexFromObj(
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
+
+ if (irPtr) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -134,9 +132,11 @@ Tcl_GetIndexFromObj(
return TCL_OK;
}
}
+ }
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -175,7 +175,8 @@ GetIndexFromObjList(
int *indexPtr) /* Place to store resulting integer index. */
{
- int objc, result, t;
+ Tcl_Size objc, t;
+ int result;
Tcl_Obj **objv;
const char **tablePtr;
@@ -184,7 +185,7 @@ GetIndexFromObjList(
* of the code there. This is a bit inefficient but simpler.
*/
- result = TclListObjGetElements(interp, tableObjPtr, &objc, &objv);
+ result = TclListObjGetElementsM(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
@@ -210,13 +211,8 @@ GetIndexFromObjList(
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
- sizeof(char *), msg, flags, indexPtr);
+ sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr);
- /*
- * The internal rep must be cleared since tablePtr will go away.
- */
-
- TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
@@ -234,11 +230,12 @@ GetIndexFromObjList(
* Results:
* If the value of objPtr is identical to or a unique abbreviation for
* one of the entries in tablePtr, then the return value is TCL_OK and
- * the index of the matching entry is stored at *indexPtr. If there isn't
- * a proper match, then TCL_ERROR is returned and an error message is
- * left in interp's result (unless interp is NULL). The msg argument is
- * used in the error message; for example, if msg has the value "option"
- * then the error message will say something like 'bad option "foo": must
+ * the index of the matching entry is stored at *indexPtr
+ * (unless indexPtr is NULL). If there isn't a proper match, then
+ * TCL_ERROR is returned and an error message is left in interp's
+ * result (unless interp is NULL). The msg argument is used in the
+ * error message; for example, if msg has the value "option" then
+ * the error message will say something like 'bad option "foo": must
* be ...'
*
* Side effects:
@@ -248,6 +245,7 @@ GetIndexFromObjList(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetIndexFromObjStruct
int
Tcl_GetIndexFromObjStruct(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
@@ -260,15 +258,16 @@ Tcl_GetIndexFromObjStruct(
int offset, /* The number of bytes between entries */
const char *msg, /* Identifying word to use in error
* messages. */
- int flags, /* 0 or TCL_EXACT */
- int *indexPtr) /* Place to store resulting integer index. */
+ int flags, /* 0, TCL_EXACT, TCL_NULL_OK or TCL_INDEX_TEMP_TABLE */
+ void *indexPtr) /* Place to store resulting index. */
{
- int index, idx, numAbbrev;
+ Tcl_Size index, idx, numAbbrev;
const char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ const Tcl_ObjInternalRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
@@ -278,15 +277,18 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr && (objPtr->typePtr == &indexType)) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
+ if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if ((indexRep->tablePtr == tablePtr)
&& (indexRep->offset == offset)
&& (indexRep->index >= 0)) {
- *indexPtr = indexRep->index;
- return TCL_OK;
+ index = indexRep->index;
+ goto uncachedDone;
}
}
+ }
/*
* Lookup the value of the object in the table. Accept unique
@@ -294,9 +296,12 @@ Tcl_GetIndexFromObjStruct(
*/
key = objPtr ? TclGetString(objPtr) : "";
- index = -1;
+ index = TCL_INDEX_NONE;
numAbbrev = 0;
+ if (!*key && (flags & TCL_NULL_OK)) {
+ goto uncachedDone;
+ }
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
@@ -341,21 +346,42 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr && (index >= 0)) {
- if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.twoPtrValue.ptr1;
- } else {
- TclFreeIntRep(objPtr);
- indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->typePtr = &indexType;
- }
- indexRep->tablePtr = (void *) tablePtr;
- indexRep->offset = offset;
- indexRep->index = index;
+ if (objPtr && (index >= 0) && !(flags & TCL_INDEX_TEMP_TABLE)) {
+ irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
+ if (irPtr) {
+ indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
+ } else {
+ Tcl_ObjInternalRep ir;
+
+ indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
+ ir.twoPtrValue.ptr1 = indexRep;
+ Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir);
+ }
+ indexRep->tablePtr = (void *) tablePtr;
+ indexRep->offset = offset;
+ indexRep->index = index;
}
- *indexPtr = index;
+ uncachedDone:
+ if (indexPtr != NULL) {
+ flags &= (30-(int)(sizeof(int)<<1));
+ if (flags) {
+ if (flags == sizeof(uint16_t)<<1) {
+ *(uint16_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(uint8_t)<<1)) {
+ *(uint8_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(int64_t)<<1)) {
+ *(int64_t *)indexPtr = index;
+ return TCL_OK;
+ } else if (flags == (int)(sizeof(int32_t)<<1)) {
+ *(int32_t *)indexPtr = index;
+ return TCL_OK;
+ }
+ }
+ *(int *)indexPtr = index;
+ }
return TCL_OK;
error:
@@ -373,26 +399,29 @@ Tcl_GetIndexFromObjStruct(
}
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
- msg, " \"", key, NULL);
+ msg, " \"", key, (void *)NULL);
if (*entryPtr == NULL) {
- Tcl_AppendStringsToObj(resultPtr, "\": no valid options", NULL);
+ Tcl_AppendStringsToObj(resultPtr, "\": no valid options", (void *)NULL);
} else {
Tcl_AppendStringsToObj(resultPtr, "\": must be ",
- *entryPtr, NULL);
+ *entryPtr, (void *)NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
- if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
+ if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) {
Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""),
- " or ", *entryPtr, NULL);
+ " or ", *entryPtr, (void *)NULL);
} else if (**entryPtr) {
- Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
+ Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, (void *)NULL);
count++;
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
+ if ((flags & TCL_NULL_OK)) {
+ Tcl_AppendStringsToObj(resultPtr, ", or \"\"", (void *)NULL);
+ }
}
Tcl_SetObjResult(interp, resultPtr);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, (void *)NULL);
}
return TCL_ERROR;
}
@@ -418,16 +447,10 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = (IndexRep *)objPtr->internalRep.twoPtrValue.ptr1;
- char *buf;
- unsigned len;
+ IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
- len = strlen(indexStr);
- buf = ckalloc(len + 1);
- memcpy(buf, indexStr, len+1);
- objPtr->bytes = buf;
- objPtr->length = len;
+ Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
@@ -453,12 +476,14 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = (IndexRep *)srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_ObjInternalRep ir;
IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep));
- memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1,
+ sizeof(IndexRep));
+
+ ir.twoPtrValue.ptr1 = dupIndexRep;
+ Tcl_StoreInternalRep(dupPtr, &tclIndexType, &ir);
}
/*
@@ -482,7 +507,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.twoPtrValue.ptr1);
+ ckfree(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -539,13 +564,13 @@ TclInitPrefixCmd(
static int
PrefixMatchObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int flags = 0, result, index;
- int dummyLength, i, errorLength;
+ int flags = 0, result, index, i;
+ Tcl_Size dummyLength, errorLength;
Tcl_Obj *errorPtr = NULL;
const char *message = "option";
Tcl_Obj *tablePtr, *objPtr, *resultPtr;
@@ -573,8 +598,8 @@ PrefixMatchObjCmd(
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "missing value for -message", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
+ "missing value for -message", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (void *)NULL);
return TCL_ERROR;
}
i++;
@@ -583,12 +608,12 @@ PrefixMatchObjCmd(
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "missing value for -error", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
+ "missing value for -error", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", (void *)NULL);
return TCL_ERROR;
}
i++;
- result = TclListObjLength(interp, objv[i], &errorLength);
+ result = TclListObjLengthM(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -596,7 +621,7 @@ PrefixMatchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", (void *)NULL);
return TCL_ERROR;
}
errorPtr = objv[i];
@@ -612,7 +637,7 @@ PrefixMatchObjCmd(
* error case regardless of level.
*/
- result = TclListObjLength(interp, tablePtr, &dummyLength);
+ result = TclListObjLengthM(interp, tablePtr, &dummyLength);
if (result != TCL_OK) {
return result;
}
@@ -632,7 +657,7 @@ PrefixMatchObjCmd(
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
- Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewWideIntObj(result));
return Tcl_SetReturnOptions(interp, errorPtr);
}
@@ -663,12 +688,13 @@ PrefixMatchObjCmd(
static int
PrefixAllObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int tableObjc, result, t, length, elemLength;
+ int result;
+ Tcl_Size length, elemLength, tableObjc, t;
const char *string, *elemString;
Tcl_Obj **tableObjv, *resultPtr;
@@ -677,15 +703,15 @@ PrefixAllObjCmd(
return TCL_ERROR;
}
- result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
- string = Tcl_GetStringFromObj(objv[2], &length);
+ string = TclGetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
- elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+ elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
@@ -720,12 +746,13 @@ PrefixAllObjCmd(
static int
PrefixLongestObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int tableObjc, result, i, t, length, elemLength, resultLength;
+ int result;
+ Tcl_Size i, length, elemLength, resultLength, tableObjc, t;
const char *string, *elemString, *resultString;
Tcl_Obj **tableObjv;
@@ -734,17 +761,17 @@ PrefixLongestObjCmd(
return TCL_ERROR;
}
- result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
+ result = TclListObjGetElementsM(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
- string = Tcl_GetStringFromObj(objv[2], &length);
+ string = TclGetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
- elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
+ elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
@@ -784,7 +811,7 @@ PrefixLongestObjCmd(
* Adjust in case we stopped in the middle of a UTF char.
*/
- resultLength = TclUtfPrev(&resultString[i+1],
+ resultLength = Tcl_UtfPrev(&resultString[i+1],
resultString) - resultString;
break;
}
@@ -840,7 +867,7 @@ PrefixLongestObjCmd(
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments to print from objv. */
+ Tcl_Size 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
@@ -848,9 +875,9 @@ Tcl_WrongNumArgs(
* NULL. */
{
Tcl_Obj *objPtr;
- int i, len, elemLen;
+ Tcl_Size i, len, elemLen;
char flags;
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
const char *elementStr;
/*
@@ -880,9 +907,9 @@ Tcl_WrongNumArgs(
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
- Tcl_AppendToObj(objPtr, " or \"", -1);
+ Tcl_AppendToObj(objPtr, " or \"", TCL_INDEX_NONE);
} else {
- Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
+ Tcl_AppendToObj(objPtr, "wrong # args: should be \"", TCL_INDEX_NONE);
}
/*
@@ -891,8 +918,8 @@ Tcl_WrongNumArgs(
*/
if (iPtr->ensembleRewrite.sourceObjs != NULL) {
- int toSkip = iPtr->ensembleRewrite.numInsertedObjs;
- int toPrint = iPtr->ensembleRewrite.numRemovedObjs;
+ Tcl_Size toSkip = iPtr->ensembleRewrite.numInsertedObjs;
+ Tcl_Size toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp);
/*
@@ -914,17 +941,17 @@ Tcl_WrongNumArgs(
objc -= toSkip;
/*
- * We assume no object is of index type.
+ * Assume no object is of index type.
*/
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
+ const Tcl_ObjInternalRep *irPtr;
- if (origObjv[i]->typePtr == &indexType) {
- IndexRep *indexRep =
- origObjv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
@@ -952,8 +979,8 @@ Tcl_WrongNumArgs(
* moderately complex condition here).
*/
- if (i<toPrint-1 || objc!=0 || message!=NULL) {
- Tcl_AppendStringsToObj(objPtr, " ", NULL);
+ if (i + 1 < toPrint || objc!=0 || message!=NULL) {
+ Tcl_AppendStringsToObj(objPtr, " ", (void *)NULL);
}
}
}
@@ -966,15 +993,16 @@ Tcl_WrongNumArgs(
addNormalArgumentsToMessage:
for (i = 0; i < objc; i++) {
/*
- * If the object is an index type use the index table which allows for
+ * If the object is an index type, use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
+ const Tcl_ObjInternalRep *irPtr;
- if (objv[i]->typePtr == &indexType) {
- IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(objv[i], &tclIndexType))) {
+ IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
- Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
+ Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (void *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
@@ -1003,8 +1031,8 @@ Tcl_WrongNumArgs(
* (either another element from objv, or the message string).
*/
- if (i<objc-1 || message!=NULL) {
- Tcl_AppendStringsToObj(objPtr, " ", NULL);
+ if (i + 1 < objc || message!=NULL) {
+ Tcl_AppendStringsToObj(objPtr, " ", (void *)NULL);
}
}
@@ -1015,10 +1043,10 @@ Tcl_WrongNumArgs(
*/
if (message != NULL) {
- Tcl_AppendStringsToObj(objPtr, message, NULL);
+ Tcl_AppendStringsToObj(objPtr, message, (void *)NULL);
}
- Tcl_AppendStringsToObj(objPtr, "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
+ Tcl_AppendStringsToObj(objPtr, "\"", (void *)NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (void *)NULL);
Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
@@ -1047,6 +1075,7 @@ Tcl_WrongNumArgs(
*----------------------------------------------------------------------
*/
+#undef Tcl_ParseArgsObjv
int
Tcl_ParseArgsObjv(
Tcl_Interp *interp, /* Place to store error message. */
@@ -1062,7 +1091,7 @@ Tcl_ParseArgsObjv(
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
- int nrem; /* Size of leftovers.*/
+ Tcl_Size nrem; /* Size of leftovers.*/
const Tcl_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
@@ -1074,13 +1103,13 @@ Tcl_ParseArgsObjv(
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
- int srcIndex; /* Location from which to read next argument
+ Tcl_Size srcIndex; /* Location from which to read next argument
* from objv. */
- int dstIndex; /* Used to keep track of current arguments
+ Tcl_Size dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
- int objc; /* # arguments in objv still to process. */
- int length; /* Number of characters in current argument */
+ Tcl_Size objc; /* # arguments in objv still to process. */
+ Tcl_Size length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
@@ -1109,7 +1138,7 @@ Tcl_ParseArgsObjv(
curArg = objv[srcIndex];
srcIndex++;
objc--;
- str = Tcl_GetStringFromObj(curArg, &length);
+ str = TclGetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
@@ -1117,7 +1146,7 @@ Tcl_ParseArgsObjv(
}
/*
- * Loop throught the argument descriptors searching for one with the
+ * Loop through the argument descriptors searching for one with the
* matching key string. If found, leave a pointer to it in matchPtr.
*/
@@ -1331,7 +1360,7 @@ PrintUsage(
width = 4;
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
- int length;
+ Tcl_Size length;
if (infoPtr->keyStr == NULL) {
continue;
@@ -1346,7 +1375,7 @@ PrintUsage(
* Now add the option information, with pretty-printing.
*/
- msg = Tcl_NewStringObj("Command-specific options:", -1);
+ msg = Tcl_NewStringObj("Command-specific options:", TCL_INDEX_NONE);
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
if ((infoPtr->type == TCL_ARGV_HELP) && (infoPtr->keyStr == NULL)) {
Tcl_AppendPrintfToObj(msg, "\n%s", infoPtr->helpStr);
@@ -1362,7 +1391,7 @@ PrintUsage(
}
numSpaces -= NUM_SPACES;
}
- Tcl_AppendToObj(msg, infoPtr->helpStr, -1);
+ Tcl_AppendToObj(msg, infoPtr->helpStr, TCL_INDEX_NONE);
switch (infoPtr->type) {
case TCL_ARGV_INT:
Tcl_AppendPrintfToObj(msg, "\n\t\tDefault value: %d",
@@ -1416,7 +1445,7 @@ TclGetCompletionCodeFromObj(
"ok", "error", "return", "break", "continue", NULL
};
- if ((value->typePtr != &indexType)
+ if (!TclHasInternalRep(value, &tclIndexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
@@ -1434,7 +1463,7 @@ TclGetCompletionCodeFromObj(
"bad completion code \"%s\": must be"
" ok, error, return, break, continue, or an integer",
TclGetString(value)));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_CODE", (void *)NULL);
}
return TCL_ERROR;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 993cc5d..62f7580 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -28,23 +28,23 @@ declare 3 {
void TclAllocateFreeObjects(void)
}
declare 5 {
- int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
+ int TclCleanupChildren(Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
- int TclCopyAndCollapse(int count, const char *src, char *dst)
+ Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
-declare 8 {
+declare 8 {deprecated {}} {
int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
- int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv,
+ Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
@@ -60,22 +60,22 @@ declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
declare 14 {
- int TclDumpMemoryInfo(ClientData clientData, int flags)
+ 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,
- int listLength, const char **elementPtr, const char **nextPtr,
- int *sizePtr, int *bracePtr)
+ Tcl_Size listLength, const char **elementPtr, const char **nextPtr,
+ Tcl_Size *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 {
- int TclFormatInt(char *buffer, long n)
+ Tcl_Size TclFormatInt(char *buffer, Tcl_WideInt n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
@@ -90,11 +90,11 @@ declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-declare 34 {
+declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-declare 37 {
+declare 37 {deprecated {}} {
int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
}
declare 38 {
@@ -113,9 +113,9 @@ declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
- CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
+ const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
-declare 44 {
+declare 44 {deprecated {}} {
int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
declare 45 {
@@ -124,20 +124,20 @@ declare 45 {
declare 46 {
int TclInExit(void)
}
-declare 50 {
+declare 50 {deprecated {}} {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
}
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-declare 53 {
- int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+declare 53 {deprecated {}} {
+ int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp,
+ Tcl_Size argc, const char **argv)
}
-declare 54 {
- int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
+declare 54 {deprecated {}} {
+ int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
@@ -156,19 +156,19 @@ declare 61 {
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
-declare 63 {
- int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
+declare 63 {deprecated {}} {
+ int TclObjInterpProc(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 64 {
- int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
+ int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
}
declare 69 {
- char *TclpAlloc(unsigned int size)
+ void *TclpAlloc(TCL_HASH_TYPE size)
}
declare 74 {
- void TclpFree(char *ptr)
+ void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
@@ -176,16 +176,14 @@ declare 75 {
declare 76 {
unsigned long TclpGetSeconds(void)
}
-
-# deprecated
-declare 77 {
+declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
declare 81 {
- char *TclpRealloc(char *ptr, unsigned int size)
+ void *TclpRealloc(void *ptr, TCL_HASH_TYPE size)
}
-declare 88 {
- char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
+declare 88 {deprecated {}} {
+ char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
}
declare 89 {
@@ -201,7 +199,7 @@ declare 92 {
const char *procName)
}
declare 93 {
- void TclProcDeleteProc(ClientData clientData)
+ void TclProcDeleteProc(void *clientData)
}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
@@ -213,8 +211,8 @@ declare 97 {
declare 98 {
int TclServiceIdle(void)
}
-declare 101 {
- CONST86 char *TclSetPreInitScript(const char *string)
+declare 101 {deprecated {Use Tcl_SetPreInitScript}} {
+ const char *TclSetPreInitScript(const char *string)
}
declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
@@ -223,7 +221,7 @@ declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
-declare 104 {
+declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
declare 108 {
@@ -233,7 +231,7 @@ declare 109 {
int TclUpdateReturnInfo(Interp *iPtr)
}
declare 110 {
- int TclSockMinimumBuffers(void *sock, int size)
+ int TclSockMinimumBuffers(void *sock, Tcl_Size size)
}
# Procedures used in conjunction with Tcl namespaces. They are
@@ -244,27 +242,27 @@ declare 111 {
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 112 {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+declare 112 {deprecated {Use Tcl_AppendExportList}} {
+ int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
-declare 113 {
- Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
- ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
+declare 113 {deprecated {Use Tcl_CreateNamespace}} {
+ Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
+ void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
-declare 114 {
- void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
+declare 114 {deprecated {Use Tcl_DeleteNamespace}} {
+ void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
-declare 115 {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+declare 115 {deprecated {Use Tcl_Export}} {
+ int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
-declare 116 {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+declare 116 {deprecated {Use Tcl_FindCommand}} {
+ Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 117 {
- Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name,
+declare 117 {deprecated {Use Tcl_FindNamespace}} {
+ Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
@@ -279,29 +277,29 @@ declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
-declare 121 {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+declare 121 {deprecated {Use Tcl_ForgetImport}} {
+ int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
-declare 122 {
- Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+declare 122 {deprecated {Use Tcl_GetCommandFromObj}} {
+ Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
-declare 123 {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+declare 123 {deprecated {Use Tcl_GetCommandFullName}} {
+ void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
-declare 124 {
- Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp)
+declare 124 {deprecated {Use Tcl_GetCurrentNamespace}} {
+ Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
-declare 125 {
- Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp)
+declare 125 {deprecated {Use Tcl_GetGlobalNamespace}} {
+ Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
-declare 127 {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+declare 127 {deprecated {Use }} {
+ int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
@@ -319,22 +317,22 @@ declare 131 {
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
-declare 132 {
+declare 132 {deprecated {}} {
int TclpHasSockets(Tcl_Interp *interp)
}
-declare 133 {
+declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
declare 138 {
- CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
+ const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
# This is used by TclX, but should otherwise be considered private
declare 141 {
- CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+ const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CompileHookProc *hookProc, ClientData clientData)
+ CompileHookProc *hookProc, void *clientData)
}
declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
@@ -363,8 +361,8 @@ declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
- void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr,
- int *endPtr)
+ void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr,
+ Tcl_Size *endPtr)
}
declare 152 {
void TclSetLibraryPath(Tcl_Obj *pathPtr)
@@ -379,12 +377,10 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 158 {
+declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 159 {
+declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
@@ -393,7 +389,7 @@ declare 161 {
Tcl_Obj *cmdObjPtr)
}
declare 162 {
- void TclChannelEventScriptInvoker(ClientData clientData, int flags)
+ void TclChannelEventScriptInvoker(void *clientData, int flags)
}
# ALERT: The result of 'TclGetInstructionTable' is actually a
@@ -421,16 +417,13 @@ declare 165 {
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
- int index, Tcl_Obj *valuePtr)
+ Tcl_Size index, Tcl_Obj *valuePtr)
}
-# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
-declare 167 {
+declare 167 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
-# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
-declare 168 {
+declare 168 {deprecated {use public Tcl_GetStartupScript()}} {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
@@ -439,20 +432,20 @@ declare 169 {
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
- int numChars, Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *const objv[])
+ Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 171 {
int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command,
- int numChars, Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *const objv[])
+ Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 172 {
int TclInThreadExit(void)
}
declare 173 {
- int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
- const Tcl_UniChar *pattern, int ptnLen, int flags)
+ int TclUniCharMatch(const Tcl_UniChar *string, Tcl_Size strLen,
+ const Tcl_UniChar *pattern, Tcl_Size ptnLen, int flags)
}
declare 175 {
int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
@@ -465,17 +458,16 @@ declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
-# TIP 338 made these public - now declared in tcl.h too
-declare 178 {
- void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+declare 178 {deprecated {}} {
+ void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
-declare 179 {
- Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+declare 179 {deprecated {}} {
+ Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
-declare 182 {
+declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
-declare 183 {
+declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
@@ -526,7 +518,7 @@ declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
- void *TclStackAlloc(Tcl_Interp *interp, int numBytes)
+ void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
@@ -538,9 +530,22 @@ declare 217 {
declare 218 {
void TclPopStackFrame(Tcl_Interp *interp)
}
+# TIP 431: temporary directory creation function
+declare 219 {
+ Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj)
+}
# for use in tclTest.c
+# TIP 625: for unit testing - create list objects with span
+declare 221 {
+ Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace)
+}
+# TIP 625: for unit testing - check list invariants
+declare 222 {
+ void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
+}
# Bug 7371b6270b
declare 223 {
void *TclGetCStackPtr(void)
@@ -550,13 +555,13 @@ declare 224 {
}
declare 225 {
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
- int keyc, Tcl_Obj *const keyv[], int flags)
+ Tcl_Size keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
- void TclSetNsPath(Namespace *nsPtr, int pathLength,
+ void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength,
Tcl_Namespace *pathAry[])
}
declare 229 {
@@ -590,9 +595,7 @@ declare 234 {
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
-
-# TIP 337 made this one public
-declare 236 {
+declare 236 {deprecated {use Tcl_BackgroundException}} {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
@@ -604,12 +607,12 @@ declare 237 {
# NRE functions for "rogue" extensions to exploit NRE; they will need to
# include NRE.h too.
declare 238 {
- int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
+ int TclNRInterpProc(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[])
}
declare 239 {
int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
- int skip, ProcErrorProc *errorProc)
+ Tcl_Size skip, ProcErrorProc *errorProc)
}
declare 240 {
int TclNRRunCallbacks(Tcl_Interp *interp, int result,
@@ -620,7 +623,7 @@ declare 241 {
const CmdFrame *invoker, int word)
}
declare 242 {
- int TclNREvalObjv(Tcl_Interp *interp, int objc,
+ int TclNREvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags, Command *cmdPtr)
}
@@ -637,8 +640,8 @@ declare 245 {
Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr)
}
declare 246 {
- int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
- int numInserted, Tcl_Obj *const *objv)
+ int TclInitRewriteEnsemble(Tcl_Interp *interp, Tcl_Size numRemoved,
+ Tcl_Size numInserted, Tcl_Obj *const *objv)
}
declare 247 {
void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble)
@@ -646,7 +649,7 @@ declare 247 {
declare 248 {
int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
- Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr)
+ Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr)
}
declare 249 {
@@ -655,13 +658,13 @@ declare 249 {
}
# TIP #285: Script cancellation support.
declare 250 {
- void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
+ void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
- char *bytes, int length, int flags)
+ const char *bytes, Tcl_Size length, int flags)
}
# Exporting of the internal API to variables.
@@ -690,8 +693,8 @@ declare 256 {
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags)
}
declare 257 {
- void TclStaticPackage(Tcl_Interp *interp, const char *prefix,
- Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
+ void TclStaticLibrary(Tcl_Interp *interp, const char *prefix,
+ Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
}
declare 261 {
@@ -736,7 +739,7 @@ declare 7 win {
const char *optval, int optlen)
}
declare 8 win {
- int TclpGetPid(Tcl_Pid pid)
+ Tcl_Size TclpGetPid(Tcl_Pid pid)
}
declare 9 win {
int TclWinGetPlatformId(void)
@@ -779,7 +782,7 @@ declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
- void TclWinAddProcess(HANDLE hProcess, DWORD id)
+ void TclWinAddProcess(void *hProcess, Tcl_Size id)
}
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
@@ -894,7 +897,7 @@ declare 22 {unix macosx} {
}
declare 29 {win unix} {
- int TclWinCPUID(unsigned int index, unsigned int *regs)
+ int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6550ab3..f696ad2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -26,6 +26,47 @@
#undef ACCEPT_NAN
/*
+ * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3.
+ * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them
+ * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+
+ * releases. Perhaps Tcl 8.7 will add even better public interfaces
+ * supporting all the re-invocation mechanisms extensions like Itcl 3
+ * need. As an absolute last resort, folks who must make Itcl 3 work
+ * unchanged with Tcl 8.7 can remove this line to regain the migration
+ * support. Tcl 9 will no longer offer even that option.
+ */
+
+#define AVOID_HACKS_FOR_ITCL 1
+
+
+/*
+ * Used to tag functions that are only to be visible within the module being
+ * built and not outside it (where this is supported by the linker).
+ * Also used in the platform-specific *Port.h files.
+ */
+
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+#ifndef JOIN
+# define JOIN(a,b) JOIN1(a,b)
+# define JOIN1(a,b) a##b
+#endif
+
+#if defined(__cplusplus)
+# define TCL_UNUSED(T) T
+#elif defined(__GNUC__) && (__GNUC__ > 2)
+# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused))
+#else
+# define TCL_UNUSED(T) T JOIN(dummy, __LINE__)
+#endif
+
+/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
@@ -38,22 +79,14 @@
#include <stdio.h>
#include <ctype.h>
-#ifdef NO_STDLIB_H
-# include "../compat/stdlib.h"
-#else
-# include <stdlib.h>
-#endif
+#include <stdlib.h>
+#include <stdint.h>
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include <string.h>
#endif
-#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
- || defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC)
-#include <stddef.h>
-#else
-typedef int ptrdiff_t;
-#endif
+#include <locale.h>
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
@@ -82,41 +115,22 @@ typedef int ptrdiff_t;
#endif
/*
- * Used to tag functions that are only to be visible within the module being
- * built and not outside it (where this is supported by the linker).
- */
-
-#ifndef MODULE_SCOPE
-# ifdef __cplusplus
-# define MODULE_SCOPE extern "C"
-# else
-# define MODULE_SCOPE extern
-# endif
-#endif
-
-/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
*/
-#if !defined(INT2PTR) && !defined(PTR2INT)
-# if defined(HAVE_INTPTR_T) || defined(intptr_t)
-# define INT2PTR(p) ((void *)(intptr_t)(p))
-# define PTR2INT(p) ((int)(intptr_t)(p))
-# else
-# define INT2PTR(p) ((void *)(p))
-# define PTR2INT(p) ((int)(p))
-# endif
+#if !defined(INT2PTR)
+# define INT2PTR(p) ((void *)(ptrdiff_t)(p))
#endif
-#if !defined(UINT2PTR) && !defined(PTR2UINT)
-# if defined(HAVE_UINTPTR_T) || defined(uintptr_t)
-# define UINT2PTR(p) ((void *)(uintptr_t)(p))
-# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p))
-# else
-# define UINT2PTR(p) ((void *)(p))
-# define PTR2UINT(p) ((unsigned int)(p))
-# endif
+#if !defined(PTR2INT)
+# define PTR2INT(p) ((ptrdiff_t)(p))
+#endif
+#if !defined(UINT2PTR)
+# define UINT2PTR(p) ((void *)(size_t)(p))
+#endif
+#if !defined(PTR2UINT)
+# define PTR2UINT(p) ((size_t)(p))
#endif
#if defined(_WIN32) && defined(_MSC_VER)
@@ -124,6 +138,26 @@ typedef int ptrdiff_t;
# define snprintf _snprintf
#endif
+#if !defined(TCL_THREADS)
+# define TCL_THREADS 1
+#endif
+#if !TCL_THREADS
+# undef TCL_DECLARE_MUTEX
+# define TCL_DECLARE_MUTEX(name)
+# undef Tcl_MutexLock
+# define Tcl_MutexLock(mutexPtr)
+# undef Tcl_MutexUnlock
+# define Tcl_MutexUnlock(mutexPtr)
+# undef Tcl_MutexFinalize
+# define Tcl_MutexFinalize(mutexPtr)
+# undef Tcl_ConditionNotify
+# define Tcl_ConditionNotify(condPtr)
+# undef Tcl_ConditionWait
+# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+# undef Tcl_ConditionFinalize
+# define Tcl_ConditionFinalize(condPtr)
+#endif
+
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -148,13 +182,13 @@ typedef struct Tcl_ResolvedVarInfo {
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
- CONST84 char *name, int length, Tcl_Namespace *context,
+ const char *name, Tcl_Size length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
-typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name,
+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, CONST84 char *name,
+typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
typedef struct Tcl_ResolverInfo {
@@ -236,7 +270,7 @@ typedef struct Namespace {
* synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
- ClientData clientData; /* An arbitrary value associated with this
+ void *clientData; /* An arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure invoked when deleting the
@@ -253,16 +287,16 @@ typedef struct Namespace {
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
- long nsId; /* Unique id for the namespace. */
- Tcl_Interp *interp; /* The interpreter containing this
+ unsigned long 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. */
- int activationCount; /* Number of "activations" or active call
+ Tcl_Size activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
* freed until activationCount becomes zero. */
- int refCount; /* Count of references by namespaceName
+ Tcl_Size refCount; /* Count of references by namespaceName
* objects. The namespace can't be freed until
* refCount becomes zero. */
Tcl_HashTable cmdTable; /* Contains all the commands currently
@@ -283,16 +317,16 @@ typedef struct Namespace {
* commands; however, no namespace qualifiers
* are allowed. NULL if no export patterns are
* registered. */
- int numExportPatterns; /* Number of export patterns currently
+ Tcl_Size numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
- int maxExportPatterns; /* Number of export patterns for which space
+ Tcl_Size maxExportPatterns; /* Number of export patterns for which space
* is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
+ Tcl_Size 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. */
- int resolverEpoch; /* Incremented whenever (a) the name
+ Tcl_Size 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
@@ -319,7 +353,7 @@ typedef struct Namespace {
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
- int exportLookupEpoch; /* Incremented whenever a command is added to
+ Tcl_Size exportLookupEpoch; /* Incremented whenever a command is added to
* a namespace, removed from a namespace or
* the exports of a namespace are changed.
* Allows TIP#112-driven command lists to be
@@ -330,7 +364,7 @@ typedef struct Namespace {
Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
* resolution in this namespace fails. TIP
* 181. */
- int commandPathLength; /* The length of the explicit path. */
+ Tcl_Size commandPathLength; /* The length of the explicit path. */
NamespacePathEntry *commandPathArray;
/* The explicit path of the namespace as an
* array. */
@@ -368,21 +402,19 @@ struct NamespacePathEntry {
* Flags used to represent the status of a namespace:
*
* NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace but there are still active call frames on the Tcl
+ * namespace. There may still be active call frames on the Tcl
* stack that refer to the namespace. When the last call frame
- * referring to it has been popped, it's variables and command
- * will be destroyed and it will be marked "dead" (NS_DEAD). The
- * namespace can no longer be looked up by name.
+ * referring to it has been popped, its remaining variables and
+ * commands are destroyed and it is marked "dead" (NS_DEAD).
+ * NS_TEARDOWN -1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942].
* NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the
- * namespace and no call frames still refer to it. Its variables
- * and command have already been destroyed. This bit allows the
- * namespace resolution code to recognize that the namespace is
- * "deleted". When the last namespaceName object in any byte code
- * unit that refers to the namespace has been freed (i.e., when
- * the namespace's refCount is 0), the namespace's storage will
- * be freed.
- * NS_KILLED - 1 means that TclTeardownNamespace has already been called on
- * this namespace and it should not be called again [Bug 1355942]
+ * namespace and no call frames still refer to it. It is no longer
+ * accessible by name. Its variables and commands have already
+ * been destroyed. When the last namespaceName object in any byte
+ * code unit that refers to the namespace has been freed (i.e.,
+ * when the namespace's refCount is 0), the namespace's storage
+ * will be freed.
* NS_SUPPRESS_COMPILATION -
* Marks the commands in this namespace for not being compiled,
* forcing them to be looked up every time.
@@ -390,7 +422,8 @@ struct NamespacePathEntry {
#define NS_DYING 0x01
#define NS_DEAD 0x02
-#define NS_KILLED 0x04
+#define NS_TEARDOWN 0x04
+#define NS_KILLED 0x04 /* Same as NS_TEARDOWN (Deprecated) */
#define NS_SUPPRESS_COMPILATION 0x08
/*
@@ -420,7 +453,7 @@ typedef struct EnsembleConfig {
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
- int epoch; /* The epoch at which this ensemble's table of
+ Tcl_Size 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
@@ -477,7 +510,7 @@ typedef struct EnsembleConfig {
* core, presumably because the ensemble
* itself has been updated. */
Tcl_Obj *parameterList; /* List of ensemble parameter names. */
- int numParameters; /* Cached number of parameters. This is either
+ Tcl_Size 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. */
@@ -507,7 +540,7 @@ typedef struct EnsembleConfig {
typedef struct VarTrace {
Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
* flags are performed on variable. */
- ClientData clientData; /* Argument to pass to proc. */
+ void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
@@ -526,14 +559,14 @@ typedef struct CommandTrace {
Tcl_CommandTraceProc *traceProc;
/* Procedure to call when operations given by
* flags are performed on command. */
- ClientData clientData; /* Argument to pass to proc. */
+ 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. */
- int refCount; /* Used to ensure this structure is not
+ Tcl_Size 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. */
@@ -606,7 +639,7 @@ typedef struct Var {
typedef struct VarInHash {
Var var;
- int refCount; /* Counts number of active uses of this
+ Tcl_Size refCount; /* Counts number of active uses of this
* variable: 1 for the entry in the hash
* table, 1 for each additional variable whose
* linkPtr points here, 1 for each nested
@@ -841,23 +874,29 @@ typedef struct VarInHash {
#define VarHashRefCount(varPtr) \
((VarInHash *) (varPtr))->refCount
+#define VarHashGetKey(varPtr) \
+ (((VarInHash *)(varPtr))->entry.key.objPtr)
+
/*
* Macros for direct variable access by TEBC.
*/
-#define TclIsVarDirectReadable(varPtr) \
- ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \
- && (varPtr)->value.objPtr)
+#define TclIsVarTricky(varPtr,trickyFlags) \
+ ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags))
+
+#define TclIsVarDirectReadable(varPtr) \
+ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \
+ && (varPtr)->value.objPtr)
#define TclIsVarDirectWritable(varPtr) \
- !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+ (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH))
#define TclIsVarDirectUnsettable(varPtr) \
- !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
+ (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
#define TclIsVarDirectModifyable(varPtr) \
- ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
- && (varPtr)->value.objPtr)
+ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \
+ && (varPtr)->value.objPtr)
#define TclIsVarDirectReadable2(varPtr, arrayPtr) \
(TclIsVarDirectReadable(varPtr) &&\
@@ -911,9 +950,9 @@ typedef struct CompiledLocal {
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
- int nameLength; /* The number of bytes in local variable's name.
+ Tcl_Size nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
- int frameIndex; /* Index in the array of compiler-assigned
+ Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
@@ -945,7 +984,7 @@ typedef struct CompiledLocal {
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command is
* defined. */
- int refCount; /* Reference count: 1 if still present in
+ Tcl_Size refCount; /* Reference count: 1 if still present in
* command table plus 1 for each call to the
* procedure that is currently active. This
* structure can be freed when refCount
@@ -956,8 +995,8 @@ typedef struct Proc {
* procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
- int numArgs; /* Number of formal parameters. */
- int numCompiledLocals; /* Count of local variables recognized by the
+ Tcl_Size numArgs; /* Number of formal parameters. */
+ Tcl_Size numCompiledLocals; /* Count of local variables recognized by the
* compiler including arguments and
* temporaries. */
CompiledLocal *firstLocalPtr;
@@ -984,10 +1023,10 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
*/
typedef struct Trace {
- int level; /* Only trace commands at nesting level less
+ Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
- ClientData clientData; /* Arbitrary value to pass to proc. */
+ void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
@@ -1030,6 +1069,20 @@ typedef struct ActiveInterpTrace {
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
+MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *,
+ Tcl_Size index);
+MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr);
+MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp,
+ Tcl_Obj **arithSeriesObj, int useDoubles,
+ Tcl_Obj *startObj, Tcl_Obj *endObj,
+ Tcl_Obj *stepObj, Tcl_Obj *lenObj);
+
/*
* The structure below defines an entry in the assocData hash table which is
* associated with an interpreter. The entry contains a pointer to a function
@@ -1039,7 +1092,7 @@ typedef struct ActiveInterpTrace {
typedef struct AssocData {
Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
- ClientData clientData; /* Value to pass to proc. */
+ void *clientData; /* Value to pass to proc. */
} AssocData;
/*
@@ -1062,8 +1115,8 @@ typedef struct AssocData {
*/
typedef struct LocalCache {
- int refCount;
- int numVars;
+ Tcl_Size refCount;
+ Tcl_Size numVars;
Tcl_Obj *varName0;
} LocalCache;
@@ -1083,7 +1136,7 @@ typedef struct CallFrame {
* If FRAME_IS_PROC is set, the frame was
* pushed to execute a Tcl procedure and may
* have local vars. */
- int objc; /* This and objv below describe the arguments
+ Tcl_Size objc; /* This and objv below describe the arguments
* for this procedure call. */
Tcl_Obj *const *objv; /* Array of argument objects. */
struct CallFrame *callerPtr;
@@ -1097,7 +1150,7 @@ typedef struct CallFrame {
* callerPtr unless an "uplevel" command or
* something equivalent was active in the
* caller). */
- int level; /* Level of this procedure, for "uplevel"
+ Tcl_Size 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. */
@@ -1111,13 +1164,13 @@ typedef struct CallFrame {
* recognized by the compiler, or created at
* execution time through, e.g., upvar.
* Initially NULL and created if needed. */
- int numCompiledLocals; /* Count of local variables recognized
+ Tcl_Size 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. */
- ClientData clientData; /* Pointer to some context that is used by
+ 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
* sets it, and it should only ever be set by
@@ -1141,6 +1194,10 @@ typedef struct CallFrame {
* field contains an Object reference that has
* been confirmed to refer to a class. Part of
* TIP#257. */
+#define FRAME_IS_PRIVATE_DEFINE 0x10
+ /* Marks this frame as being used for private
+ * declarations with [oo::define]. Usually
+ * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */
/*
* TIP #280
@@ -1168,8 +1225,8 @@ typedef struct CmdFrame {
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. */
- int nline;
+ Tcl_Size *line; /* Lines the words of the command start on. */
+ Tcl_Size nline;
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
@@ -1213,7 +1270,7 @@ typedef struct CmdFrame {
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
- int len; /* ... and its length. */
+ Tcl_Size len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
@@ -1223,16 +1280,16 @@ typedef struct CmdFrame {
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
- int word; /* Index of the word in the command. */
- int refCount; /* Number of times the word is on the
+ Tcl_Size word; /* Index of the word in the command. */
+ Tcl_Size refCount; /* Number of times the word is on the
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
- int pc; /* Instruction pointer of a command in
+ Tcl_Size pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
- int word; /* Index of word in
+ Tcl_Size 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
@@ -1261,9 +1318,9 @@ typedef struct CFWordBC {
#define CLL_END (-1)
typedef struct ContLineLoc {
- int num; /* Number of entries in loc, not counting the
+ Tcl_Size num; /* Number of entries in loc, not counting the
* final -1 marker entry. */
- int loc[TCLFLEXARRAY];/* Table of locations, as character offsets.
+ Tcl_Size 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
@@ -1301,17 +1358,17 @@ typedef struct ContLineLoc {
* by [info frame]. Contains a sub-structure for each extra field.
*/
-typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
+typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData);
typedef struct {
const char *name; /* Name of this field. */
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
- ClientData clientData; /* Context for above function, or Tcl_Obj* if
+ void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
- int length; /* Length of array. */
+ Tcl_Size length; /* Length of array. */
ExtraFrameInfoField fields[2];
/* Really as long as necessary, but this is
* long enough for nearly anything. */
@@ -1352,7 +1409,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
*/
#define TCL_TSD_INIT(keyPtr) \
- (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
/*
*----------------------------------------------------------------
@@ -1389,7 +1446,9 @@ struct CompileEnv;
* sake of old code only.
*/
-#define TCL_OUT_LINE_COMPILE TCL_ERROR
+#ifndef TCL_NO_DEPRECATED
+# define TCL_OUT_LINE_COMPILE TCL_ERROR
+#endif
typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
@@ -1400,7 +1459,7 @@ typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
*/
typedef int (CompileHookProc)(Tcl_Interp *interp,
- struct CompileEnv *compEnvPtr, ClientData clientData);
+ struct CompileEnv *compEnvPtr, void *clientData);
/*
* The data structure for a (linked list of) execution stacks.
@@ -1442,13 +1501,18 @@ typedef struct CoroutineData {
CorContext running;
Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
void *stackLevel;
- int auxNumLevels; /* While the coroutine is running the
+ Tcl_Size auxNumLevels; /* While the coroutine is running the
* numLevels of the create/resume command is
* stored here; for suspended coroutines it
* holds the nesting numLevels at yield. */
- int nargs; /* Number of args required for resuming this
- * coroutine; -2 means "0 or 1" (default), -1
- * means "any" */
+ Tcl_Size nargs; /* Number of args required for resuming this
+ * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1"
+ * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */
+ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in
+ * order to reset splice point in
+ * TclNRCoroutineActivateCallback if the
+ * coroutine is busy.
+ */
} CoroutineData;
typedef struct ExecEnv {
@@ -1487,11 +1551,11 @@ typedef struct LiteralEntry {
* NULL if end of chain. */
Tcl_Obj *objPtr; /* Points to Tcl object that holds the
* literal's bytes and length. */
- int refCount; /* If in an interpreter's global literal
+ Tcl_Size refCount; /* If in an interpreter's global literal
* table, the number of ByteCode structures
* that share the literal object; the literal
* entry can be freed when refCount drops to
- * 0. If in a local literal table, -1. */
+ * 0. If in a local literal table, TCL_INDEX_NONE. */
Namespace *nsPtr; /* Namespace in which this literal is used. We
* try to avoid sharing literal non-FQ command
* names among different namespaces to reduce
@@ -1505,13 +1569,13 @@ typedef struct LiteralTable {
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
- int numBuckets; /* Total number of buckets allocated at
+ TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at
* **buckets. */
- int numEntries; /* Total number of entries present in
+ TCL_HASH_TYPE numEntries; /* Total number of entries present in
* table. */
- int rebuildSize; /* Enlarge table when numEntries gets to be
+ TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
- int mask; /* Mask value used in hashing function. */
+ TCL_HASH_TYPE mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
@@ -1522,10 +1586,10 @@ typedef struct LiteralTable {
#ifdef TCL_COMPILE_STATS
typedef struct ByteCodeStats {
- long numExecutions; /* Number of ByteCodes executed. */
- long numCompilations; /* Number of ByteCodes created. */
- long numByteCodesFreed; /* Number of ByteCodes destroyed. */
- long instructionCount[256]; /* Number of times each instruction was
+ size_t numExecutions; /* Number of ByteCodes executed. */
+ size_t numCompilations; /* Number of ByteCodes created. */
+ size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */
+ size_t instructionCount[256]; /* Number of times each instruction was
* executed. */
double totalSrcBytes; /* Total source bytes ever compiled. */
@@ -1533,10 +1597,10 @@ typedef struct ByteCodeStats {
double currentSrcBytes; /* Src bytes for all current ByteCodes. */
double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
- long srcCount[32]; /* Source size distribution: # of srcs of
+ size_t srcCount[32]; /* Source size distribution: # of srcs of
* size [2**(n-1)..2**n), n in [0..32). */
- long byteCodeCount[32]; /* ByteCode size distribution. */
- long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
+ size_t byteCodeCount[32]; /* ByteCode size distribution. */
+ size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
double currentInstBytes; /* Instruction bytes-current ByteCodes. */
double currentLitBytes; /* Current literal bytes. */
@@ -1544,11 +1608,11 @@ typedef struct ByteCodeStats {
double currentAuxBytes; /* Current auxiliary information bytes. */
double currentCmdMapBytes; /* Current src<->code map bytes. */
- long numLiteralsCreated; /* Total literal objects ever compiled. */
+ size_t numLiteralsCreated; /* Total literal objects ever compiled. */
double totalLitStringBytes; /* Total string bytes in all literals. */
double currentLitStringBytes;
/* String bytes in current literals. */
- long literalCount[32]; /* Distribution of literal string sizes. */
+ size_t literalCount[32]; /* Distribution of literal string sizes. */
} ByteCodeStats;
#endif /* TCL_COMPILE_STATS */
@@ -1563,7 +1627,7 @@ typedef struct {
Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
CompileProc *compileProc; /* The compiler for the subcommand. */
Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
- ClientData clientData; /* Any clientData to give the command. */
+ void *clientData; /* Any clientData to give the command. */
int unsafe; /* Whether this command is to be hidden by
* default in a safe interpreter. */
} EnsembleImplMap;
@@ -1629,24 +1693,24 @@ typedef struct Command {
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
- int refCount; /* 1 if in command hashtable plus 1 for each
+ Tcl_Size refCount; /* 1 if in command hashtable plus 1 for each
* reference from a CmdName Tcl object
* representing a command's name in a ByteCode
* instruction sequence. This structure can be
* freed when refCount becomes zero. */
- int cmdEpoch; /* Incremented to invalidate any references
+ Tcl_Size cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
- ClientData objClientData; /* Arbitrary value passed to object proc. */
+ void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
- ClientData clientData; /* Arbitrary value passed to string proc. */
+ void *clientData; /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Procedure invoked when deleting command to,
* e.g., free all client data. */
- ClientData deleteData; /* Arbitrary value passed to deleteProc. */
+ void *deleteData; /* Arbitrary value passed to deleteProc. */
int flags; /* Miscellaneous bits of information about
* command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
@@ -1664,7 +1728,7 @@ typedef struct Command {
/*
* Flag bits for commands.
*
- * CMD_IS_DELETED - If 1 the command is in the process of
+ * CMD_DYING - If 1 the command is in the process of
* being deleted (its deleteProc is currently
* executing). Other attempts to delete the
* command should be ignored.
@@ -1685,7 +1749,10 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x01
+#define CMD_DYING 0x01
+#ifndef TCL_NO_DEPRECATED
+# define CMD_IS_DELETED 0x01 /* Same as CMD_DYING */
+#endif
#define CMD_TRACE_ACTIVE 0x02
#define CMD_HAS_EXEC_TRACES 0x04
#define CMD_COMPILES_EXPANDED 0x08
@@ -1755,7 +1822,7 @@ typedef struct AllocCache {
struct Cache *nextPtr; /* Linked list of cache entries. */
Tcl_ThreadId owner; /* Which thread's cache is this? */
Tcl_Obj *firstObjPtr; /* List of free objects for thread. */
- int numObjects; /* Number of objects for thread. */
+ size_t numObjects; /* Number of objects for thread. */
} AllocCache;
/*
@@ -1813,7 +1880,7 @@ typedef struct Interp {
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
- ClientData interpInfo; /* Information used by tclInterp.c to keep
+ void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
union {
@@ -1829,12 +1896,12 @@ typedef struct Interp {
* tclVar.c for usage.
*/
- int numLevels; /* Keeps track of how many nested calls to
+ Tcl_Size numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
* interpreter. It's used to delay deletion of
* the table until all Tcl_Eval invocations
* are completed. */
- int maxNestingDepth; /* If numLevels exceeds this value then Tcl
+ Tcl_Size maxNestingDepth; /* If numLevels exceeds this value then Tcl
* assumes that infinite recursion has
* occurred and it generates an error. */
CallFrame *framePtr; /* Points to top-most in stack of all nested
@@ -1857,6 +1924,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
+#if !defined(TCL_NO_DEPRECATED)
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1864,6 +1932,11 @@ typedef struct Interp {
* partialResult. */
int appendUsed; /* Number of non-null bytes currently stored
* at partialResult. */
+#else
+ char *appendResultDontUse;
+ int appendAvlDontUse;
+ int appendUsedDontUse;
+#endif
/*
* Information about packages. Used only in tclPkg.c.
@@ -1881,7 +1954,7 @@ typedef struct Interp {
* Miscellaneous information:
*/
- int cmdCount; /* Total number of times a command procedure
+ Tcl_Size 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
@@ -1893,7 +1966,7 @@ typedef struct Interp {
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
- int compileEpoch; /* Holds the current "compilation epoch" for
+ Tcl_Size 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
@@ -1925,8 +1998,12 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
- char resultSpace[TCL_RESULT_SIZE+1];
+#if !defined(TCL_NO_DEPRECATED)
+ char resultSpace[TCL_DSTRING_STATIC_SIZE+1];
/* Static space holding small results. */
+#else
+ 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. */
@@ -1939,7 +2016,7 @@ typedef struct Interp {
/* First in list of active traces for interp,
* or NULL if no active traces. */
- int tracesForbiddingInline; /* Count of traces (in the list headed by
+ Tcl_Size tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation. */
@@ -1969,7 +2046,7 @@ typedef struct Interp {
* as flag values the same as the 'active'
* field. */
- int cmdCount; /* Limit for how many commands to execute in
+ Tcl_Size cmdCount; /* Limit for how many commands to execute in
* the interpreter. */
LimitHandler *cmdHandlers;
/* Handlers to execute when the limit is
@@ -2005,9 +2082,9 @@ typedef struct Interp {
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
- int numRemovedObjs; /* How many arguments have been stripped off
+ Tcl_Size numRemovedObjs; /* How many arguments have been stripped off
* because of ensemble processing. */
- int numInsertedObjs; /* How many of the current arguments were
+ Tcl_Size numInsertedObjs; /* How many of the current arguments were
* inserted by an ensemble. */
} ensembleRewrite;
@@ -2302,22 +2379,41 @@ typedef struct Interp {
#endif
/*
- * This macro is used to determine the offset needed to safely allocate any
+ * 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 8-byte boundary so that any data
- * structure can be placed at the resulting offset without fear of an
- * alignment error.
+ * 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 4
- * or 2. Only use it for offsets or sizes.
+ * 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.
*/
-#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
+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)))
/*
* The following enum values are used to specify the runtime platform setting
@@ -2362,66 +2458,191 @@ typedef enum TclEolTranslation {
#define TCL_INVOKE_NO_TRACEBACK (1<<2)
/*
- * The structure used as the internal representation of Tcl list objects. This
- * struct is grown (reallocated and copied) as necessary to hold all the
- * list's element pointers. The struct might contain more slots than currently
- * used to hold all element pointers. This is done to make append operations
- * faster.
+ * 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 List {
- int refCount;
- int maxElemCount; /* Total number of element array slots. */
- int elemCount; /* Current number of list elements. */
- int canonicalFlag; /* Set if the string representation was
- * derived from the list representation. May
- * be ignored if there is no string rep at
- * all.*/
- Tcl_Obj *elements; /* First list element; the struct is grown to
- * accommodate all elements. */
-} List;
-
-#define LIST_MAX \
- (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
-#define LIST_SIZE(numElems) \
- (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
+typedef struct ListStore {
+ Tcl_Size firstUsed; /* Index of first slot in use within slots[] */
+ Tcl_Size numUsed; /* Number of slots in use (starting firstUsed) */
+ Tcl_Size 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 \
+ ((Tcl_Size)(((size_t)TCL_SIZE_MAX - offsetof(ListStore, slots)) \
+ / sizeof(Tcl_Obj *)))
+/* Memory size needed for a ListStore to hold numSlots_ elements */
+#define LIST_SIZE(numSlots_) \
+ ((Tcl_Size)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))))
+
+/*
+ * ListSpan --
+ * See comments above for ListStore
+ */
+typedef struct ListSpan {
+ Tcl_Size spanStart; /* Starting index of the span */
+ Tcl_Size 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
/*
- * Macro used to get the elements of a list object.
+ * 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;
-#define ListRepPtr(listPtr) \
- ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
+/*
+ * 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)
-/* Not used any more */
-#define ListSetIntRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
+/* Returns the length of the list */
+#define ListObjLength(listObj_, len_) \
+ ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \
+ : ListObjStorePtr(listObj_)->numUsed)
-#define ListObjGetElements(listPtr, objc, objv) \
- ((objv) = &(ListRepPtr(listPtr)->elements), \
- (objc) = ListRepPtr(listPtr)->elemCount)
+/* Returns the starting slot index of this list's elements in the ListStore */
+#define ListObjStart(listObj_) \
+ (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \
+ : ListObjStorePtr(listObj_)->firstUsed)
-#define ListObjLength(listPtr, len) \
- ((len) = ListRepPtr(listPtr)->elemCount)
+/* 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_))))
-#define ListObjIsCanonical(listPtr) \
- (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag)
-#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
- : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+/*
+ * 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)
-#define TclListObjLength(interp, listPtr, lenPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
- : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+/*
+ * 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 under certain
+ * conditions (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)
-#define TclListObjIsCanonical(listPtr) \
- (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+/*
+ * 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,
@@ -2432,40 +2653,45 @@ typedef struct List {
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
- * Macros providing a faster path to integers: Tcl_GetLongFromObj,
- * Tcl_GetIntFromObj and TclGetIntForIndex.
+ * Macros providing a faster path to booleans and integers:
+ * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
+ * and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
+#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
+ : ((objPtr)->typePtr == &tclBooleanType) \
+ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
+ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
+
+#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
-
-#if (LONG_MAX == INT_MAX)
-#define TclGetIntFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
-#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
#else
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
+ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+#endif
+
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \
- && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
+ ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- (((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= INT_MIN \
- && (objPtr)->internalRep.longValue <= INT_MAX) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
-#endif
+ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
+ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \
+ ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
@@ -2475,21 +2701,11 @@ typedef struct List {
* Tcl_WideInt *wideIntPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
+ ? (*(wideIntPtr) = \
+ ((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
-#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
- (((objPtr)->typePtr == &tclWideIntType) \
- ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
- ((objPtr)->typePtr == &tclIntType) \
- ? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
- Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Flag values for TclTraceDictPath().
@@ -2532,7 +2748,7 @@ typedef struct List {
*/
#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2)
-typedef ClientData (TclFSGetCwdProc2)(ClientData clientData);
+typedef void *(TclFSGetCwdProc2)(void *clientData);
typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
@@ -2566,10 +2782,12 @@ typedef struct TclFile_ *TclFile;
* combination of the following values:
*/
-#define TCL_GLOBMODE_NO_COMPLAIN 1
-#define TCL_GLOBMODE_JOIN 2
-#define TCL_GLOBMODE_DIR 4
-#define TCL_GLOBMODE_TAILS 8
+#ifndef TCL_NO_DEPRECATED
+# define TCL_GLOBMODE_NO_COMPLAIN 1
+# define TCL_GLOBMODE_JOIN 2
+# define TCL_GLOBMODE_DIR 4
+# define TCL_GLOBMODE_TAILS 8
+#endif
typedef enum Tcl_PathPart {
TCL_PATH_DIRNAME,
@@ -2595,8 +2813,10 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
*----------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
typedef Tcl_CmdProc *TclCmdProcType;
typedef Tcl_ObjCmdProc *TclObjCmdProcType;
+#endif
/*
*----------------------------------------------------------------
@@ -2604,7 +2824,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
-typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2616,9 +2836,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
*/
typedef struct ProcessGlobalValue {
- int epoch; /* Epoch counter to detect changes in the
+ Tcl_Size epoch; /* Epoch counter to detect changes in the
* global value. */
- int numBytes; /* Length of the global string. */
+ 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. */
@@ -2654,18 +2874,26 @@ typedef struct ProcessGlobalValue {
/* Reject leading/trailing whitespace. */
#define TCL_PARSE_BINARY_ONLY 64
/* Parse binary even without prefix. */
+#define TCL_PARSE_NO_UNDERSCORE 128
+ /* Reject underscore digit separator */
+
/*
*----------------------------------------------------------------------
- * Type values TclGetNumberFromObj
+ * Internal convenience macros for manipulating encoding flags. See
+ * TCL_ENCODING_PROFILE_* in tcl.h
*----------------------------------------------------------------------
*/
-#define TCL_NUMBER_LONG 1
-#define TCL_NUMBER_WIDE 2
-#define TCL_NUMBER_BIG 3
-#define TCL_NUMBER_DOUBLE 4
-#define TCL_NUMBER_NAN 5
+#define ENCODING_PROFILE_MASK 0xFF000000
+#define ENCODING_PROFILE_GET(flags_) (((flags_) & TCL_ENCODING_PROFILE_STRICT) ? \
+ TCL_ENCODING_PROFILE_STRICT : (((flags_) & ENCODING_PROFILE_MASK) ? \
+ ((flags_) & ENCODING_PROFILE_MASK) : TCL_ENCODING_PROFILE_TCL8))
+#define ENCODING_PROFILE_SET(flags_, profile_) \
+ do { \
+ (flags_) &= ~(ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \
+ (flags_) |= (profile_) & (ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \
+ } while (0)
/*
*----------------------------------------------------------------
@@ -2677,9 +2905,20 @@ MODULE_SCOPE char *tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
MODULE_SCOPE char *tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
-MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks;
+
+/*
+ * Declarations related to internal encoding functions.
+ */
MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
+MODULE_SCOPE Tcl_Encoding tclUtf8Encoding;
+MODULE_SCOPE int
+TclEncodingProfileNameToId(Tcl_Interp *interp,
+ const char *profileName,
+ int *profilePtr);
+MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp,
+ int profileId);
+MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp);
/*
* TIP #233 (Virtualized Time)
@@ -2688,7 +2927,7 @@ MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr;
MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr;
-MODULE_SCOPE ClientData tclTimeClientData;
+MODULE_SCOPE void *tclTimeClientData;
/*
* Variables denoting the Tcl object types defined in the core.
@@ -2699,17 +2938,15 @@ MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
-MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
+MODULE_SCOPE const Tcl_ObjType tclIndexType;
MODULE_SCOPE const Tcl_ObjType tclListType;
+MODULE_SCOPE const Tcl_ObjType tclArithSeriesType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
-MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
+MODULE_SCOPE const Tcl_ObjType tclUniCharStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
-#ifndef TCL_WIDE_INT_IS_LONG
-MODULE_SCOPE const Tcl_ObjType tclWideIntType;
-#endif
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
MODULE_SCOPE Tcl_ObjType tclCmdNameType;
@@ -2730,10 +2967,10 @@ MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
MODULE_SCOPE Tcl_Obj * tclFreeObjList;
#ifdef TCL_COMPILE_STATS
-MODULE_SCOPE long tclObjsAlloced;
-MODULE_SCOPE long tclObjsFreed;
+MODULE_SCOPE size_t tclObjsAlloced;
+MODULE_SCOPE size_t tclObjsFreed;
#define TCL_MAX_SHARED_OBJ_STATS 5
-MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
+MODULE_SCOPE size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */
/*
@@ -2742,7 +2979,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
* shared by all new objects allocated by Tcl_NewObj.
*/
-MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
enum CheckEmptyStringResult {
@@ -2805,7 +3041,7 @@ typedef struct ForIterData {
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
- int word; /* Index of the body script in the command */
+ Tcl_Size word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
@@ -2815,7 +3051,7 @@ typedef struct ForIterData {
typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
const char* symbol);
struct Tcl_LoadHandle_ {
- ClientData clientData; /* Client data is the load handle in the
+ void *clientData; /* Client data is the load handle in the
* native filesystem if a module was loaded
* there, or an opaque pointer to a structure
* for further bookkeeping on load-from-VFS
@@ -2829,29 +3065,19 @@ struct Tcl_LoadHandle_ {
/* Flags for conversion of doubles to digit strings */
-#define TCL_DD_SHORTEST 0x4
- /* Use the shortest possible string */
-#define TCL_DD_STEELE 0x5
- /* Use the original Steele&White algorithm */
#define TCL_DD_E_FORMAT 0x2
/* Use a fixed-length string of digits,
* suitable for E format*/
#define TCL_DD_F_FORMAT 0x3
/* Use a fixed number of digits after the
* decimal point, suitable for F format */
-
-#define TCL_DD_SHORTEN_FLAG 0x4
- /* Allow return of a shorter digit string
- * if it converts losslessly */
+#define TCL_DD_SHORTEST 0x4
+ /* Use the shortest possible string */
#define TCL_DD_NO_QUICK 0x8
/* Debug flag: forbid quick FP conversion */
#define TCL_DD_CONVERSION_TYPE_MASK 0x3
/* Mask to isolate the conversion type */
-#define TCL_DD_STEELE0 0x1
- /* 'Steele&White' after masking */
-#define TCL_DD_SHORTEST0 0x0
- /* 'Shortest possible' after masking */
/*
*----------------------------------------------------------------
@@ -2860,10 +3086,10 @@ struct Tcl_LoadHandle_ {
*/
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
- const unsigned char *bytes, int len);
-MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
+ const unsigned char *bytes, Tcl_Size len);
+MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
int loc);
-MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
+MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start,
const char *end);
MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc, CmdFrame *cf);
@@ -2871,18 +3097,22 @@ 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, int pc);
+ void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd, Tcl_Size 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 double TclBignumToDouble(const mp_int *bignum);
+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,
- int strLen, const unsigned char *pattern,
- int ptnLen, int flags);
-MODULE_SCOPE double TclCeil(const mp_int *a);
+ Tcl_Size strLen, const unsigned char *pattern,
+ Tcl_Size 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 TclChannelGetBlockingMode(Tcl_Channel chan);
MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *name, int index);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
@@ -2892,31 +3122,34 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
-MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
- int *loc);
+MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
+ Tcl_Obj *value2Ptr);
+MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num,
+ Tcl_Size *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
- int start, int *clNext);
+ Tcl_Size start, Tcl_Size *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
-MODULE_SCOPE int TclConvertElement(const char *src, int length,
+MODULE_SCOPE Tcl_Size TclConvertElement(const char *src, Tcl_Size length,
char *dst, int flags);
MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
const char *cmdName, Tcl_Namespace *nsPtr,
- Tcl_ObjCmdProc *proc, ClientData clientData,
+ 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, int dictLength,
+ const char *dict, Tcl_Size dictLength,
const char **elementPtr, const char **nextPtr,
- int *sizePtr, int *literalPtr);
+ Tcl_Size *sizePtr, int *literalPtr);
/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
- int numBytes, int flags, int line,
- int *clNextOuter, const char *outerScript);
+ Tcl_Size numBytes, int flags, Tcl_Size line,
+ Tcl_Size *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
@@ -2924,18 +3157,20 @@ 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,
- ClientData clientData);
+ void *clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
- ClientData clientData);
+ 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, int objc, int *objcPtr);
+ Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr);
MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr);
@@ -2956,18 +3191,19 @@ MODULE_SCOPE void TclFinalizeNotifier(void);
MODULE_SCOPE void TclFinalizeObjects(void);
MODULE_SCOPE void TclFinalizePreserve(void);
MODULE_SCOPE void TclFinalizeSynchronization(void);
+MODULE_SCOPE void TclInitThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAllocThread(void);
MODULE_SCOPE void TclFinalizeThreadData(int quick);
MODULE_SCOPE void TclFinalizeThreadObjects(void);
-MODULE_SCOPE double TclFloor(const mp_int *a);
+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,
- ClientData clientData, Tcl_CmdDeleteProc *deleteProc);
+ void *clientData, Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
const char *encodingName);
MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
@@ -2978,9 +3214,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp,
MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr);
MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp,
Tcl_Obj *value, int *code);
-MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr, ClientData *clientDataPtr,
- int *typePtr);
+MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr);
MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
const char *modeString, int *seekFlagPtr,
int *binaryPtr);
@@ -2988,10 +3223,12 @@ 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,
- unsigned int *sizePtr);
-MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
- Tcl_Obj *unquotedPrefix, int globFlags,
- Tcl_GlobTypeData *types);
+ 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 TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
@@ -3013,29 +3250,38 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE const char *TclInitSubsystems(void);
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int TclIsBareword(int byte);
-MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[],
+MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[],
int forceRelative);
+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,
- int indexCount, Tcl_Obj *const indexArray[]);
+ Tcl_Size indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
-MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n,
- int *lines, Tcl_Obj *const *elems);
+MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n,
+ Tcl_Size *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
+MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp,
+ Tcl_Obj *toObj, Tcl_Size elemCount,
+ Tcl_Obj *const elemObjv[]);
+MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Size fromIdx, Tcl_Size 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,
- int indexCount, Tcl_Obj *const indexArray[],
+ Tcl_Size 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, int numBytes,
+MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes,
const char **endPtr);
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
@@ -3053,36 +3299,52 @@ MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp,
MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
MODULE_SCOPE int TclParseBackslash(const char *src,
- int numBytes, int *readPtr, char *dst);
+ Tcl_Size numBytes, Tcl_Size *readPtr, char *dst);
MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *expected, const char *bytes,
- int numBytes, const char **endPtrPtr, int flags);
+ Tcl_Size numBytes, const char **endPtrPtr, int flags);
MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string,
- int numBytes, Tcl_Parse *parsePtr);
-MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes);
+ Tcl_Size numBytes, Tcl_Parse *parsePtr);
+MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
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 * TclpTempFileNameForLibrary(Tcl_Interp *interp,
+ Tcl_Obj* pathPtr);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
- int len);
+ Tcl_Size 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);
+#ifdef _WIN32
+MODULE_SCOPE void TclInitSockets(void);
+#else
+#define TclInitSockets() /* do nothing */
+#endif
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, ClientData clientData,
- int stackSize, int flags);
-MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
+ Tcl_ThreadCreateProc *proc, void *clientData,
+ TCL_HASH_TYPE stackSize, int flags);
+MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
- int *lengthPtr, Tcl_Encoding *encodingPtr);
+ 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);
@@ -3091,15 +3353,15 @@ MODULE_SCOPE void TclpGlobalUnlock(void);
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, int *lenPtr);
+MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr);
MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
- int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
+ Tcl_Size *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 ClientData TclpGetNativeCwd(ClientData clientData);
+MODULE_SCOPE void *TclpGetNativeCwd(void *clientData);
MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
int linkType);
@@ -3107,6 +3369,9 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
+MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp,
+ const char *fileName);
+MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
@@ -3115,21 +3380,22 @@ MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
void *data);
-MODULE_SCOPE void TclpThreadExit(int status);
+MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
- int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
+ Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
int *quantifiersFoundPtr);
-MODULE_SCOPE unsigned int TclScanElement(const char *string, int length,
+MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length,
char *flagPtr);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumInternalRep(Tcl_Obj *objPtr,
- mp_int *bignumValue);
-MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+ void *bignumValue);
+MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
@@ -3137,58 +3403,42 @@ 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, int objc, int subIdx,
+ Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
- int numBytes);
-
+ TCL_HASH_TYPE 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, int 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, int strLen,
+MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
+ int checkEq, int nocase, Tcl_Size reqlength);
+MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
-MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
- int numBytes, int flags, int line,
+ Tcl_Size numBytes, int flags, Tcl_Size line,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts,
+MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts,
Tcl_Obj *const opts[], int *flagPtr);
MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
- int numBytes, int flags, Tcl_Parse *parsePtr,
+ Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr,
Tcl_InterpState *statePtr);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
- int count, int *tokensLeftPtr, int line,
- int *clNextOuter, const char *outerScript);
-MODULE_SCOPE int TclTrim(const char *bytes, int numBytes,
- const char *trim, int numTrim, int *trimRight);
-MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
- const char *trim, int numTrim);
-MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
- const char *trim, int numTrim);
+ Tcl_Size count, int *tokensLeftPtr, Tcl_Size line,
+ Tcl_Size *clNextOuter, const char *outerScript);
+MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes,
+ const char *trim, Tcl_Size numTrim, Tcl_Size *trimRight);
+MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes,
+ const char *trim, Tcl_Size numTrim);
+MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes,
+ const char *trim, Tcl_Size numTrim);
+MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
+MODULE_SCOPE void TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr);
+MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
-MODULE_SCOPE int TclUtfToUCS4(const char *, int *);
-MODULE_SCOPE int TclUCS4ToUtf(int, char *);
-MODULE_SCOPE int TclUCS4ToLower(int ch);
-#if TCL_UTF_MAX == 4
- MODULE_SCOPE int TclGetUCS4(Tcl_Obj *, int);
- MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *, int *);
-#else
-# define TclGetUCS4 Tcl_GetUniChar
-# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
-#endif
-
-/*
- * Bytes F0-F4 are start-bytes for 4-byte sequences.
- * Byte 0xED can be the start-byte of an upper surrogate. In that case,
- * TclUtfToUCS4() might read the lower surrogate following it too.
- */
-# define TclUCS4Complete(src, length) (((unsigned)(UCHAR(*(src)) - 0xF0) < 5) \
- ? ((length) >= 4) : (UCHAR(*(src)) == 0xED) ? ((length) >= 6) : Tcl_UtfCharComplete((src), (length)))
-MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
+MODULE_SCOPE int TclUtfCount(int ch);
+MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
@@ -3204,27 +3454,20 @@ MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
-/* TclWideMUInt -- wide integer used for measurement calculations: */
-#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400))
-# define TclWideMUInt Tcl_WideUInt
-#else
-/* older MSVS may not allow conversions between unsigned __int64 and double) */
-# define TclWideMUInt Tcl_WideInt
-#endif
#ifdef TCL_WIDE_CLICKS
-MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
-MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
+MODULE_SCOPE long long TclpGetWideClicks(void);
+MODULE_SCOPE double TclpWideClicksToNanoseconds(long long clicks);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
#else
# ifdef _WIN32
# define TCL_WIDE_CLICKS 1
-MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
+MODULE_SCOPE long long TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
# define TclpWideClicksToNanoseconds(clicks) \
((double)(clicks) * TclpWideClickInMicrosec() * 1000)
# endif
#endif
-MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);
+MODULE_SCOPE long long TclpGetMicroseconds(void);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
@@ -3232,7 +3475,18 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr);
MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr);
MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp,
- const char *msg, int length);
+ const char *msg, Tcl_Size length);
+/* Tip 430 */
+MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp);
+MODULE_SCOPE int TclIsZipfsPath(const char *path);
+MODULE_SCOPE void TclZipfsFinalize(void);
+
+MODULE_SCOPE int *TclGetUnicodeFromObj(Tcl_Obj *, int *);
+MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int);
+MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int);
+MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, unsigned long);
+MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int);
+MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, unsigned long);
/*
* Many parsing tasks need a common definition of whitespace.
@@ -3256,7 +3510,9 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd;
MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd;
+#if !defined(TCL_NO_DEPRECATED)
MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd;
+#endif
MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd;
MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp);
@@ -3271,7 +3527,7 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd;
MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler(
Tcl_Time *timePtr, Tcl_TimerProc *proc,
- ClientData clientData);
+ void *clientData);
MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd;
MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
@@ -3279,14 +3535,13 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
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,
- int pathc, Tcl_Obj *const pathv[]);
+ Tcl_Size pathc, Tcl_Obj *const pathv[]);
MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd;
/* Assemble command function */
MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd;
MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd;
@@ -3297,7 +3552,6 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd;
MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp);
-MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd;
@@ -3313,17 +3567,21 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_InterpObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_JoinObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LappendObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LassignObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LeditObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LindexObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LinsertObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LlengthObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_ListObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LmapObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LoadObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LpopObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrangeObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LremoveObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd;
MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
@@ -3385,6 +3643,7 @@ MODULE_SCOPE CompileProc TclCompileDictCreateCmd;
MODULE_SCOPE CompileProc TclCompileDictExistsCmd;
MODULE_SCOPE CompileProc TclCompileDictForCmd;
MODULE_SCOPE CompileProc TclCompileDictGetCmd;
+MODULE_SCOPE CompileProc TclCompileDictGetWithDefaultCmd;
MODULE_SCOPE CompileProc TclCompileDictIncrCmd;
MODULE_SCOPE CompileProc TclCompileDictLappendCmd;
MODULE_SCOPE CompileProc TclCompileDictMapCmd;
@@ -3439,6 +3698,7 @@ MODULE_SCOPE CompileProc TclCompileStringCmpCmd;
MODULE_SCOPE CompileProc TclCompileStringEqualCmd;
MODULE_SCOPE CompileProc TclCompileStringFirstCmd;
MODULE_SCOPE CompileProc TclCompileStringIndexCmd;
+MODULE_SCOPE CompileProc TclCompileStringInsertCmd;
MODULE_SCOPE CompileProc TclCompileStringIsCmd;
MODULE_SCOPE CompileProc TclCompileStringLastCmd;
MODULE_SCOPE CompileProc TclCompileStringLenCmd;
@@ -3478,6 +3738,7 @@ MODULE_SCOPE CompileProc TclCompileBasicMin2ArgCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd;
MODULE_SCOPE CompileProc TclCompileInvertOpCmd;
+
MODULE_SCOPE Tcl_ObjCmdProc TclNotOpCmd;
MODULE_SCOPE CompileProc TclCompileNotOpCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclAddOpCmd;
@@ -3516,10 +3777,37 @@ MODULE_SCOPE CompileProc TclCompileGreaterOpCmd;
MODULE_SCOPE CompileProc TclCompileGeqOpCmd;
MODULE_SCOPE CompileProc TclCompileEqOpCmd;
MODULE_SCOPE CompileProc TclCompileStreqOpCmd;
+MODULE_SCOPE CompileProc TclCompileStrLtOpCmd;
+MODULE_SCOPE CompileProc TclCompileStrLeOpCmd;
+MODULE_SCOPE CompileProc TclCompileStrGtOpCmd;
+MODULE_SCOPE CompileProc TclCompileStrGeOpCmd;
MODULE_SCOPE CompileProc TclCompileAssembleCmd;
/*
+ * Routines that provide the [string] ensemble functionality. Possible
+ * candidates for public interface.
+ */
+
+MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, Tcl_Size objc,
+ Tcl_Obj *const objv[], int flags);
+MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
+ Tcl_Size start);
+MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
+ Tcl_Size last);
+MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Size count, int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr,
+ int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags);
+
+/* Flag values for the [string] ensemble functions. */
+
+#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */
+#define TCL_STRING_IN_PLACE (1<<1)
+
+/*
* Functions defined in generic/tclVar.c and currently exported only for use
* by the bytecode compiler and engine. Some of these could later be placed in
* the public interface.
@@ -3570,26 +3858,97 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
-MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
+MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
+ * Just for the purposes of command-type registration.
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclChildObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd;
+
+/*
+ * TIP #462.
+ */
+
+/*
+ * The following enum values give the status of a spawned process.
+ */
+
+typedef enum TclProcessWaitStatus {
+ TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */
+ TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */
+ TCL_PROCESS_EXITED = 1, /* Process has exited. */
+ TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */
+ TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */
+ TCL_PROCESS_UNKNOWN_STATUS = 4
+ /* Child wait status didn't make sense. */
+} TclProcessWaitStatus;
+
+MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
+MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid);
+MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
+ int *codePtr, Tcl_Obj **msgObjPtr,
+ Tcl_Obj **errorObjPtr);
+
+/*
+ * TIP #508: [array default]
+ */
+
+MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr);
+MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr);
+
+/*
* Utility routines for encoding index values as integers. Used by both
* some of the command compilers and by [lsort] and [lsearch].
*/
MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
int before, int after, int *indexPtr);
-MODULE_SCOPE int TclIndexDecode(int encoded, int endValue);
-
-MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
+MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue);
/* Constants used in index value encoding routines. */
-#define TCL_INDEX_END (-2)
-#define TCL_INDEX_BEFORE (-1)
-#define TCL_INDEX_START (0)
-#define TCL_INDEX_AFTER (INT_MAX)
+#define TCL_INDEX_END ((Tcl_Size)-2)
+#define TCL_INDEX_START ((Tcl_Size)0)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclScaleTime --
+ *
+ * TIP #233 (Virtualized Time): Wrapper around the time virutalisation
+ * rescale function to hide the binding of the clientData.
+ *
+ * This is static inline code; it's like a macro, but a function. It's
+ * used because this is a piece of code that ends up in places that are a
+ * bit performance sensitive.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Updates the time structure (given as an argument) with what the time
+ * should be after virtualisation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline void
+TclScaleTime(
+ Tcl_Time *timePtr)
+{
+ if (timePtr != NULL) {
+ tclScaleTimeProcPtr(timePtr, tclTimeClientData);
+ }
+}
/*
*----------------------------------------------------------------
@@ -3648,7 +4007,7 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
@@ -3656,7 +4015,7 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering) with
- * 'length == -1'.
+ * 'length == TCL_INDEX_NONE'.
* Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
*/
@@ -3665,10 +4024,10 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *)(objPtr)->bytes); \
+ && ((objPtr)->bytes != &tclEmptyString)) { \
+ ckfree((objPtr)->bytes); \
} \
- (objPtr)->length = -1; \
+ (objPtr)->length = TCL_INDEX_NONE; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} else { \
@@ -3676,6 +4035,10 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
} \
}
+#if TCL_THREADS && !defined(USE_THREAD_ALLOC)
+# define USE_THREAD_ALLOC 1
+#endif
+
#if defined(PURIFY)
/*
@@ -3689,11 +4052,11 @@ MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
(objPtr) = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
- ckfree((char *)(objPtr))
+ ckfree(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#elif TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
@@ -3707,6 +4070,7 @@ MODULE_SCOPE void TclFreeAllocCache(void *);
MODULE_SCOPE void * TclpGetAllocCache(void);
MODULE_SCOPE void TclpSetAllocCache(void *);
MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE void TclpInitAllocCache(void);
MODULE_SCOPE void TclpFreeAllocCache(void *);
/*
@@ -3757,7 +4121,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
# define USE_TCLALLOC 0
#endif
-#ifdef TCL_THREADS
+#if TCL_THREADS
/* declared in tclObj.c */
MODULE_SCOPE Tcl_Mutex tclObjMutex;
#endif
@@ -3802,38 +4166,57 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
# define TclDecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
-# define TclNewListObjDirect(objc, objv) \
- TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
-
#undef USE_THREAD_ALLOC
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------
- * Macro used by the Tcl core to set a Tcl_Obj's string representation to a
- * copy of the "len" bytes starting at "bytePtr". This code works even if the
- * byte array contains NULLs as long as the length is correct. Because "len"
- * is referenced multiple times, it should be as simple an expression as
- * possible. The ANSI C "prototype" for this macro is:
+ * Macros used by the Tcl core to set a Tcl_Obj's string representation to a
+ * copy of the "len" bytes starting at "bytePtr". The value of "len" must
+ * not be negative. When "len" is 0, then it is acceptable to pass
+ * "bytePtr" = NULL. When "len" > 0, "bytePtr" must not be NULL, and it
+ * must point to a location from which "len" bytes may be read. These
+ * constraints are not checked here. The validity of the bytes copied
+ * as a value string representation is also not verififed. This macro
+ * must not be called while "objPtr" is being freed or when "objPtr"
+ * already has a string representation. The caller must use
+ * this macro properly. Improper use can lead to dangerous results.
+ * Because "len" is referenced multiple times, take care that it is an
+ * expression with the same value each use.
+ *
+ * The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
+ * MODULE_SCOPE void TclInitEmptyStringRep(Tcl_Obj *objPtr);
+ * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
+ * MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len);
*
- * This macro should only be called on an unshared objPtr where
- * objPtr->typePtr->freeIntRepProc == NULL
*----------------------------------------------------------------
*/
+#define TclInitEmptyStringRep(objPtr) \
+ ((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
+
+
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
- (objPtr)->length = 0; \
+ TclInitEmptyStringRep(objPtr); \
} else { \
- (objPtr)->bytes = (char *) ckalloc((unsigned int)(len) + 1U); \
- memcpy((objPtr)->bytes, (bytePtr), (len)); \
+ (objPtr)->bytes = (char *)ckalloc((len) + 1U); \
+ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
+#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
+ ((((len) == 0) ? ( \
+ TclInitEmptyStringRep(objPtr) \
+ ) : ( \
+ (objPtr)->bytes = (char *)attemptckalloc((len) + 1U), \
+ (objPtr)->length = ((objPtr)->bytes) ? \
+ (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \
+ (objPtr)->bytes[len] = '\0', (len)) : (-1) \
+ )), (objPtr)->bytes)
+
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
@@ -3852,7 +4235,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
- : Tcl_GetStringFromObj((objPtr), (lenPtr)))
+ : (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
@@ -3860,11 +4243,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
* representation. Does not actually reset the rep's bytes. The ANSI C
* "prototype" for this macro is:
*
- * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr);
+ * MODULE_SCOPE void TclFreeInternalRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
-#define TclFreeIntRep(objPtr) \
+#define TclFreeInternalRep(objPtr) \
if ((objPtr)->typePtr != NULL) { \
if ((objPtr)->typePtr->freeIntRepProc != NULL) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
@@ -3872,6 +4255,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
(objPtr)->typePtr = NULL; \
}
+#if !defined(TCL_NO_DEPRECATED)
+# define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr)
+#endif
+
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's string representation.
@@ -3885,7 +4272,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
do { \
Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \
if (_isobjPtr->bytes != NULL) { \
- if (_isobjPtr->bytes != tclEmptyStringRep) { \
+ if (_isobjPtr->bytes != &tclEmptyString) { \
ckfree((char *)_isobjPtr->bytes); \
} \
_isobjPtr->bytes = NULL; \
@@ -3893,6 +4280,21 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
} while (0)
/*
+ * These form part of the native filesystem support. They are needed here
+ * because we have a few native filesystem functions (which are the same for
+ * win/unix) in this file.
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+MODULE_SCOPE const char *const tclpFileAttrStrings[];
+MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
+#ifdef __cplusplus
+}
+#endif
+
+/*
*----------------------------------------------------------------
* Macro used by the Tcl core to test whether an object has a
* string representation (or is a 'pure' internal value).
@@ -3907,6 +4309,31 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
/*
*----------------------------------------------------------------
+ * Macro used by the Tcl core to get the bignum out of the bignum
+ * representation of a Tcl_Obj.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
+ *----------------------------------------------------------------
+ */
+
+#define TclUnpackBignum(objPtr, bignum) \
+ do { \
+ Tcl_Obj *bignumObj = (objPtr); \
+ int bignumPayload = \
+ PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
+ if (bignumPayload == -1) { \
+ (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
+ } else { \
+ (bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
+ (bignum).sign = bignumPayload >> 30; \
+ (bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \
+ (bignum).used = bignumPayload & 0x7FFF; \
+ } \
+ } while (0)
+
+/*
+ *----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
* "prototype" for this macro is:
@@ -4000,28 +4427,24 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
* of counting along a string of all one-byte characters. The ANSI C
* "prototype" for this macro is:
*
- * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes,
- * int numBytes);
+ * MODULE_SCOPE void TclNumUtfCharsM(Tcl_Size numChars, const char *bytes,
+ * Tcl_Size numBytes);
+ * numBytes must be >= 0
*----------------------------------------------------------------
*/
-#define TclNumUtfChars(numChars, bytes, numBytes) \
+#define TclNumUtfCharsM(numChars, bytes, numBytes) \
do { \
- int _count, _i = (numBytes); \
+ Tcl_Size _count, _i = (numBytes); \
unsigned char *_str = (unsigned char *) (bytes); \
- while (_i && (*_str < 0xC0)) { _i--; _str++; } \
+ while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
- _count += Tcl_NumUtfChars((bytes) + _count, _i); \
+ _count += TclNumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
-#define TclUtfPrev(src, start) \
- (((src) < (start)+2) ? (start) : \
- (UCHAR(*((src) - 1))) < 0x80 ? (src)-1 : \
- Tcl_UtfPrev(src, start))
-
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
@@ -4037,31 +4460,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
-#define TclIsPureByteArray(objPtr) \
- (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
+MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
(((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType))
+#define TclHasInternalRep(objPtr, type) \
+ ((objPtr)->typePtr == (type))
+#define TclFetchInternalRep(objPtr, type) \
+ (TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL)
-#define TclIsPureList(objPtr) \
- (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclListType))
-
-/*
- *----------------------------------------------------------------
- * Macro used by the Tcl core to compare Unicode strings. On big-endian
- * systems we can use the more efficient memcmp, but this would not be
- * lexically correct on little-endian systems. The ANSI C "prototype" for
- * this macro is:
- *
- * MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *cs,
- * const Tcl_UniChar *ct, unsigned long n);
- *----------------------------------------------------------------
- */
-
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
-# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
-#else /* !WORDS_BIGENDIAN */
-# define TclUniCharNcmp Tcl_UniCharNcmp
-#endif /* WORDS_BIGENDIAN */
/*
*----------------------------------------------------------------
@@ -4088,7 +4494,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
+MODULE_SCOPE Tcl_LibraryInitProc TclTommath_Init;
/*
*----------------------------------------------------------------------
@@ -4100,11 +4506,12 @@ MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
*----------------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit;
-MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init;
-MODULE_SCOPE Tcl_PackageInitProc TclThread_Init;
-MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init;
-MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
+MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit;
+MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init;
+MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init;
+MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init;
+MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
+
/*
*----------------------------------------------------------------
@@ -4125,51 +4532,25 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* core. They should only be called on unshared objects. The ANSI C
* "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue);
- * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue);
- * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, int intValue);
- * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
-#define TclSetLongObj(objPtr, i) \
+#define TclSetIntObj(objPtr, i) \
do { \
+ Tcl_ObjInternalRep ir; \
+ ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.longValue = (long)(i); \
- (objPtr)->typePtr = &tclIntType; \
+ Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
} while (0)
-#define TclSetIntObj(objPtr, l) \
- TclSetLongObj(objPtr, l)
-
-/*
- * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
- * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
- * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
- * value of strings like: "yes", "no", "true", "false", "on", "off".
- */
-
-#define TclSetBooleanObj(objPtr, b) \
- TclSetLongObj(objPtr, (b)!=0);
-
-#ifndef TCL_WIDE_INT_IS_LONG
-#define TclSetWideIntObj(objPtr, w) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclWideIntType; \
- } while (0)
-#endif
-
#define TclSetDoubleObj(objPtr, d) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType; \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.doubleValue = (double) d; \
+ TclInvalidateStringRep(objPtr); \
+ Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
@@ -4178,38 +4559,48 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
- * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
- * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
- * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
- * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
- * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
+ * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len);
+ * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
-#define TclNewLongObj(objPtr, i) \
+#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
- (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewIntObj(objPtr, l) \
- TclNewLongObj(objPtr, l)
+#define TclNewUIntObj(objPtr, uw) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ Tcl_WideUInt uw_ = (uw); \
+ if (uw_ > WIDE_MAX) { \
+ mp_int bignumValue_; \
+ if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \
+ Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
+ } \
+ TclSetBignumInternalRep((objPtr), &bignumValue_); \
+ } else { \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
+ (objPtr)->typePtr = &tclIntType; \
+ } \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
-/*
- * NOTE: There is to be no such thing as a "pure" boolean.
- * See comment above TclSetBooleanObj macro above.
- */
-#define TclNewBooleanObj(objPtr, b) \
- TclNewLongObj((objPtr), (b)!=0)
+#define TclNewIndexObj(objPtr, w) \
+ TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
do { \
@@ -4233,14 +4624,26 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewIntObj(objPtr, i) \
- (objPtr) = Tcl_NewIntObj(i)
+#define TclNewIntObj(objPtr, w) \
+ (objPtr) = Tcl_NewWideIntObj(w)
-#define TclNewLongObj(objPtr, l) \
- (objPtr) = Tcl_NewLongObj(l)
+#define TclNewUIntObj(objPtr, uw) \
+ do { \
+ Tcl_WideUInt uw_ = (uw); \
+ if (uw_ > WIDE_MAX) { \
+ mp_int bignumValue_; \
+ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \
+ (objPtr) = Tcl_NewBignumObj(&bignumValue_); \
+ } else { \
+ (objPtr) = NULL; \
+ } \
+ } else { \
+ (objPtr) = Tcl_NewWideIntObj(uw_); \
+ } \
+ } while (0)
-#define TclNewBooleanObj(objPtr, b) \
- (objPtr) = Tcl_NewBooleanObj(b)
+#define TclNewIndexObj(objPtr, w) \
+ TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
@@ -4274,34 +4677,28 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
- * The ANSI C "prototypes" for these macros are:
+ * (deprecated) The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE int TclIsInfinite(double d);
* MODULE_SCOPE int TclIsNaN(double d);
*/
-#ifdef _MSC_VER
-# define TclIsInfinite(d) (!(_finite((d))))
-# define TclIsNaN(d) (_isnan((d)))
-#else
-# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX)
-# ifdef NO_ISNAN
-# define TclIsNaN(d) ((d) != (d))
-# else
-# define TclIsNaN(d) (isnan(d))
-# endif
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+# define TclIsInfinite(d) isinf(d)
+# define TclIsNaN(d) isnan(d)
#endif
/*
- * ----------------------------------------------------------------------
- * Macro to use to find the offset of a field in a structure. Computes number
- * of bytes from beginning of structure to a given field.
+ * Macro to use to find the offset of a field in astructure.
+ * Computes number of bytes from beginning of structure to a given field.
*/
-#ifdef offsetof
-#define TclOffset(type, field) ((int) offsetof(type, field))
-#else
-#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field))
+#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl)
+# define TclOffset(type, field) ((int) offsetof(type, field))
+#endif
+/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */
+#ifndef offsetof
+# define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field))
#endif
/*
@@ -4328,6 +4725,24 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} \
} while (0)
+
+/*
+ * inside this routine crement refCount first incase cmdPtr is replacing itself
+ */
+#define TclRoutineAssign(location, cmdPtr) \
+ do { \
+ (cmdPtr)->refCount++; \
+ if ((location) != NULL \
+ && (location--) <= 1) { \
+ ckfree(((location))); \
+ } \
+ (location) = (cmdPtr); \
+ } while (0)
+
+
+#define TclRoutineHasName(cmdPtr) \
+ ((cmdPtr)->hPtr != NULL)
+
/*
*----------------------------------------------------------------
* Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
@@ -4453,7 +4868,7 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
- ClientData data[4];
+ void *data[4];
struct NRE_callback *nextPtr;
} NRE_callback;
@@ -4468,10 +4883,10 @@ typedef struct NRE_callback {
NRE_callback *_callbackPtr; \
TCLNR_ALLOC((interp), (_callbackPtr)); \
_callbackPtr->procPtr = (postProcPtr); \
- _callbackPtr->data[0] = (ClientData)(data0); \
- _callbackPtr->data[1] = (ClientData)(data1); \
- _callbackPtr->data[2] = (ClientData)(data2); \
- _callbackPtr->data[3] = (ClientData)(data3); \
+ _callbackPtr->data[0] = (void *)(data0); \
+ _callbackPtr->data[1] = (void *)(data1); \
+ _callbackPtr->data[2] = (void *)(data2); \
+ _callbackPtr->data[3] = (void *)(data3); \
_callbackPtr->nextPtr = TOP_CB(interp); \
TOP_CB(interp) = _callbackPtr; \
} while (0)
@@ -4483,7 +4898,7 @@ typedef struct NRE_callback {
#else
#define TCLNR_ALLOC(interp, ptr) \
((ptr) = (void *)ckalloc(sizeof(NRE_callback)))
-#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
@@ -4494,7 +4909,6 @@ typedef struct NRE_callback {
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
-#include "tclTomMathDecls.h"
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc TclpAlloc
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index cb13327..3ebe2eb 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -27,21 +27,22 @@
# endif
#endif
-/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_CreateNamespace
-#undef Tcl_DeleteNamespace
-#undef Tcl_AppendExportList
-#undef Tcl_Export
-#undef Tcl_Import
-#undef Tcl_ForgetImport
-#undef Tcl_GetCurrentNamespace
-#undef Tcl_GetGlobalNamespace
-#undef Tcl_FindNamespace
-#undef Tcl_FindCommand
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
-#undef Tcl_SetStartupScript
-#undef Tcl_GetStartupScript
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+# define tclGetIntForIndex tcl_GetIntForIndex
+/* Those macro's are especially for Itcl 3.4 compatibility */
+# define tclCreateNamespace tcl_CreateNamespace
+# define tclDeleteNamespace tcl_DeleteNamespace
+# define tclAppendExportList tcl_AppendExportList
+# define tclExport tcl_Export
+# define tclImport tcl_Import
+# define tclForgetImport tcl_ForgetImport
+# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace
+# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace
+# define tclFindNamespace tcl_FindNamespace
+# define tclFindCommand tcl_FindCommand
+# define tclGetCommandFromObj tcl_GetCommandFromObj
+# define tclGetCommandFullName tcl_GetCommandFullName
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -66,19 +67,21 @@ extern "C" {
EXTERN void TclAllocateFreeObjects(void);
/* Slot 4 is reserved */
/* 5 */
-EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids,
- Tcl_Pid *pidPtr, Tcl_Channel errorChan);
+EXTERN int TclCleanupChildren(Tcl_Interp *interp,
+ Tcl_Size numPids, Tcl_Pid *pidPtr,
+ Tcl_Channel errorChan);
/* 6 */
EXTERN void TclCleanupCommand(Command *cmdPtr);
/* 7 */
-EXTERN int TclCopyAndCollapse(int count, const char *src,
+EXTERN Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src,
char *dst);
/* 8 */
-EXTERN int TclCopyChannelOld(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
/* 9 */
-EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc,
+EXTERN Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc,
const char **argv, Tcl_Pid **pidArrayPtr,
TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr);
@@ -94,7 +97,7 @@ EXTERN void TclDeleteVars(Interp *iPtr,
TclVarHashTable *tablePtr);
/* Slot 13 is reserved */
/* 14 */
-EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags);
+EXTERN int TclDumpMemoryInfo(void *clientData, int flags);
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
@@ -105,14 +108,14 @@ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
/* Slot 21 is reserved */
/* 22 */
EXTERN int TclFindElement(Tcl_Interp *interp,
- const char *listStr, int listLength,
+ const char *listStr, Tcl_Size listLength,
const char **elementPtr,
- const char **nextPtr, int *sizePtr,
+ const char **nextPtr, Tcl_Size *sizePtr,
int *bracePtr);
/* 23 */
EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
-EXTERN int TclFormatInt(char *buffer, long n);
+EXTERN Tcl_Size TclFormatInt(char *buffer, Tcl_WideInt n);
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
/* Slot 26 is reserved */
@@ -128,12 +131,14 @@ EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr);
/* Slot 33 is reserved */
/* 34 */
-EXTERN int TclGetIntForIndex(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_GetIntForIndex")
+int TclGetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr);
/* Slot 35 is reserved */
/* Slot 36 is reserved */
/* 37 */
-EXTERN int TclGetLoadedPackages(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int TclGetLoadedPackages(Tcl_Interp *interp,
const char *targetName);
/* 38 */
EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp,
@@ -150,11 +155,12 @@ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str,
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command);
/* 42 */
-EXTERN CONST86 char * TclpGetUserHome(const char *name,
+EXTERN const char * TclpGetUserHome(const char *name,
Tcl_DString *bufferPtr);
/* Slot 43 is reserved */
/* 44 */
-EXTERN int TclGuessPackageName(const char *fileName,
+TCL_DEPRECATED("")
+int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
/* 45 */
EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp);
@@ -164,18 +170,21 @@ EXTERN int TclInExit(void);
/* Slot 48 is reserved */
/* Slot 49 is reserved */
/* 50 */
-EXTERN void TclInitCompiledLocals(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+void TclInitCompiledLocals(Tcl_Interp *interp,
CallFrame *framePtr, Namespace *nsPtr);
/* 51 */
EXTERN int TclInterpInit(Tcl_Interp *interp);
/* Slot 52 is reserved */
/* 53 */
-EXTERN int TclInvokeObjectCommand(ClientData clientData,
- Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+TCL_DEPRECATED("")
+int TclInvokeObjectCommand(void *clientData,
+ Tcl_Interp *interp, Tcl_Size argc,
+ const char **argv);
/* 54 */
-EXTERN int TclInvokeStringCommand(ClientData clientData,
- Tcl_Interp *interp, int objc,
+TCL_DEPRECATED("")
+int TclInvokeStringCommand(void *clientData,
+ Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 55 */
EXTERN Proc * TclIsProc(Command *cmdPtr);
@@ -194,35 +203,37 @@ EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr);
/* 62 */
EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr);
/* 63 */
-EXTERN int TclObjInterpProc(ClientData clientData,
- Tcl_Interp *interp, int objc,
+TCL_DEPRECATED("")
+int TclObjInterpProc(void *clientData,
+ Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[]);
/* 64 */
-EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
+EXTERN int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags);
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* Slot 67 is reserved */
/* Slot 68 is reserved */
/* 69 */
-EXTERN char * TclpAlloc(unsigned int size);
+EXTERN void * TclpAlloc(TCL_HASH_TYPE size);
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
/* 74 */
-EXTERN void TclpFree(char *ptr);
+EXTERN void TclpFree(void *ptr);
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
-EXTERN void TclpGetTime(Tcl_Time *time);
+TCL_DEPRECATED("")
+void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
-EXTERN char * TclpRealloc(char *ptr, unsigned int size);
+EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size);
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
@@ -230,7 +241,8 @@ EXTERN char * TclpRealloc(char *ptr, unsigned int size);
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
-EXTERN char * TclPrecTraceProc(ClientData clientData,
+TCL_DEPRECATED("")
+char * TclPrecTraceProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
/* 89 */
@@ -245,7 +257,7 @@ EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
const char *description,
const char *procName);
/* 93 */
-EXTERN void TclProcDeleteProc(ClientData clientData);
+EXTERN void TclProcDeleteProc(void *clientData);
/* Slot 94 is reserved */
/* Slot 95 is reserved */
/* 96 */
@@ -259,14 +271,16 @@ EXTERN int TclServiceIdle(void);
/* Slot 99 is reserved */
/* Slot 100 is reserved */
/* 101 */
-EXTERN CONST86 char * TclSetPreInitScript(const char *string);
+TCL_DEPRECATED("Use Tcl_SetPreInitScript")
+const char * TclSetPreInitScript(const char *string);
/* 102 */
EXTERN void TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
const char *proto, int *portPtr);
/* 104 */
-EXTERN int TclSockMinimumBuffersOld(int sock, int size);
+TCL_DEPRECATED("")
+int TclSockMinimumBuffersOld(int sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
@@ -275,7 +289,7 @@ EXTERN void TclTeardownNamespace(Namespace *nsPtr);
/* 109 */
EXTERN int TclUpdateReturnInfo(Interp *iPtr);
/* 110 */
-EXTERN int TclSockMinimumBuffers(void *sock, int size);
+EXTERN int TclSockMinimumBuffers(void *sock, Tcl_Size size);
/* 111 */
EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
const char *name,
@@ -283,22 +297,28 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
-EXTERN int Tcl_AppendExportList(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_AppendExportList")
+int TclAppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
/* 113 */
-EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp,
- const char *name, ClientData clientData,
+TCL_DEPRECATED("Use Tcl_CreateNamespace")
+Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
+ const char *name, void *clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
-EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr);
+TCL_DEPRECATED("Use Tcl_DeleteNamespace")
+void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
-EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+TCL_DEPRECATED("Use Tcl_Export")
+int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst);
/* 116 */
-EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name,
+TCL_DEPRECATED("Use Tcl_FindCommand")
+Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
-EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_FindNamespace")
+Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
@@ -313,23 +333,29 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
-EXTERN int Tcl_ForgetImport(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_ForgetImport")
+int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
-EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_GetCommandFromObj")
+Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
-EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_GetCommandFullName")
+void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
-EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp);
+TCL_DEPRECATED("Use Tcl_GetCurrentNamespace")
+Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
-EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp);
+TCL_DEPRECATED("Use Tcl_GetGlobalNamespace")
+Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp);
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
/* 127 */
-EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+TCL_DEPRECATED("Use ")
+int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
@@ -347,25 +373,25 @@ EXTERN void Tcl_SetNamespaceResolvers(
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 132 */
-EXTERN int TclpHasSockets(Tcl_Interp *interp);
+TCL_DEPRECATED("")
+int TclpHasSockets(Tcl_Interp *interp);
/* 133 */
-EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT);
+TCL_DEPRECATED("")
+struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
-EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
- Tcl_DString *valuePtr);
+EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr);
/* Slot 139 is reserved */
/* Slot 140 is reserved */
/* 141 */
-EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
- Tcl_DString *cwdPtr);
+EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
- ClientData clientData);
+ void *clientData);
/* 143 */
EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr,
Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
@@ -385,8 +411,8 @@ EXTERN void TclHandleRelease(TclHandle handle);
/* 150 */
EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re);
/* 151 */
-EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, int index,
- int *startPtr, int *endPtr);
+EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index,
+ Tcl_Size *startPtr, Tcl_Size *endPtr);
/* 152 */
EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr);
/* 153 */
@@ -400,15 +426,17 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
/* 158 */
-EXTERN void TclSetStartupScriptFileName(const char *filename);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptFileName(const char *filename);
/* 159 */
-EXTERN const char * TclGetStartupScriptFileName(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
/* 162 */
-EXTERN void TclChannelEventScriptInvoker(ClientData clientData,
+EXTERN void TclChannelEventScriptInvoker(void *clientData,
int flags);
/* 163 */
EXTERN const void * TclGetInstructionTable(void);
@@ -418,31 +446,33 @@ EXTERN void TclExpandCodeArray(void *envPtr);
EXTERN void TclpSetInitialEncodings(void);
/* 166 */
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
- Tcl_Obj *listPtr, int index,
+ Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj *valuePtr);
/* 167 */
-EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+TCL_DEPRECATED("use public Tcl_SetStartupScript()")
+void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
/* 168 */
-EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
+TCL_DEPRECATED("use public Tcl_GetStartupScript()")
+Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
/* 170 */
EXTERN int TclCheckInterpTraces(Tcl_Interp *interp,
- const char *command, int numChars,
+ const char *command, Tcl_Size numChars,
Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 171 */
EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp,
- const char *command, int numChars,
+ const char *command, Tcl_Size numChars,
Command *cmdPtr, int result, int traceFlags,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 172 */
EXTERN int TclInThreadExit(void);
/* 173 */
EXTERN int TclUniCharMatch(const Tcl_UniChar *string,
- int strLen, const Tcl_UniChar *pattern,
- int ptnLen, int flags);
+ Tcl_Size strLen, const Tcl_UniChar *pattern,
+ Tcl_Size ptnLen, int flags);
/* Slot 174 is reserved */
/* 175 */
EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr,
@@ -456,16 +486,20 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
/* 178 */
-EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+TCL_DEPRECATED("")
+void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
-EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
+TCL_DEPRECATED("")
+Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
-EXTERN struct tm * TclpLocaltime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
-EXTERN struct tm * TclpGmtime(const time_t *clock);
+TCL_DEPRECATED("")
+struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
@@ -518,7 +552,8 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void);
EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name,
Tcl_Encoding encoding);
/* 215 */
-EXTERN void * TclStackAlloc(Tcl_Interp *interp, int numBytes);
+EXTERN void * TclStackAlloc(Tcl_Interp *interp,
+ TCL_HASH_TYPE numBytes);
/* 216 */
EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr);
/* 217 */
@@ -528,22 +563,28 @@ EXTERN int TclPushStackFrame(Tcl_Interp *interp,
int isProcCallFrame);
/* 218 */
EXTERN void TclPopStackFrame(Tcl_Interp *interp);
-/* Slot 219 is reserved */
+/* 219 */
+EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj);
/* Slot 220 is reserved */
-/* Slot 221 is reserved */
-/* Slot 222 is reserved */
+/* 221 */
+EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace,
+ size_t endSpace);
+/* 222 */
+EXTERN void TclListObjValidate(Tcl_Interp *interp,
+ Tcl_Obj *listObj);
/* 223 */
EXTERN void * TclGetCStackPtr(void);
/* 224 */
EXTERN TclPlatformType * TclGetPlatform(void);
/* 225 */
EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp,
- Tcl_Obj *rootPtr, int keyc,
+ Tcl_Obj *rootPtr, Tcl_Size keyc,
Tcl_Obj *const keyv[], int flags);
/* 226 */
EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr);
/* 227 */
-EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength,
+EXTERN void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength,
Tcl_Namespace *pathAry[]);
/* Slot 228 is reserved */
/* 229 */
@@ -569,16 +610,16 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
/* 236 */
-EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
+TCL_DEPRECATED("use Tcl_BackgroundException")
+void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
-EXTERN int TclNRInterpProc(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
/* 239 */
EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int skip,
+ Tcl_Obj *procNameObj, Tcl_Size skip,
ProcErrorProc *errorProc);
/* 240 */
EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result,
@@ -587,7 +628,7 @@ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result,
EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags, const CmdFrame *invoker, int word);
/* 242 */
-EXTERN int TclNREvalObjv(Tcl_Interp *interp, int objc,
+EXTERN int TclNREvalObjv(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], int flags,
Command *cmdPtr);
/* 243 */
@@ -598,7 +639,7 @@ EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr);
EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr);
/* 246 */
EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp,
- int numRemoved, int numInserted,
+ Tcl_Size numRemoved, Tcl_Size numInserted,
Tcl_Obj *const *objv);
/* 247 */
EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp,
@@ -606,16 +647,16 @@ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp,
/* 248 */
EXTERN int TclCopyChannel(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
- Tcl_WideInt toRead, Tcl_Obj *cmdPtr);
+ long long toRead, Tcl_Obj *cmdPtr);
/* 249 */
EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
int *decpt, int *signum, char **endPtr);
/* 250 */
-EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
+EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags,
int force);
/* 251 */
-EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
- int length, int flags);
+EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes,
+ Tcl_Size length, int flags);
/* 252 */
EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
@@ -639,10 +680,10 @@ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags);
/* 257 */
-EXTERN void TclStaticPackage(Tcl_Interp *interp,
+EXTERN void TclStaticLibrary(Tcl_Interp *interp,
const char *prefix,
- Tcl_PackageInitProc *initProc,
- Tcl_PackageInitProc *safeInitProc);
+ Tcl_LibraryInitProc *initProc,
+ Tcl_LibraryInitProc *safeInitProc);
/* Slot 258 is reserved */
/* Slot 259 is reserved */
/* Slot 260 is reserved */
@@ -658,16 +699,16 @@ typedef struct TclIntStubs {
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
- int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
+ int (*tclCleanupChildren) (Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
- int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */
- int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
- int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
+ Tcl_Size (*tclCopyAndCollapse) (Tcl_Size count, const char *src, char *dst); /* 7 */
+ TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
+ Tcl_Size (*tclCreatePipeline) (Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
void (*reserved13)(void);
- int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */
+ int (*tclDumpMemoryInfo) (void *clientData, int flags); /* 14 */
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);
@@ -675,9 +716,9 @@ typedef struct TclIntStubs {
void (*reserved19)(void);
void (*reserved20)(void);
void (*reserved21)(void);
- int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
+ int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, Tcl_Size listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 22 */
Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
- int (*tclFormatInt) (char *buffer, long n); /* 24 */
+ Tcl_Size (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
@@ -687,27 +728,27 @@ typedef struct TclIntStubs {
const char * (*tclGetExtension) (const char *name); /* 31 */
int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
void (*reserved33)(void);
- int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
+ TCL_DEPRECATED_API("Use Tcl_GetIntForIndex") int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
void (*reserved35)(void);
void (*reserved36)(void);
- int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
+ TCL_DEPRECATED_API("") int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
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 */
- CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
+ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
void (*reserved43)(void);
- int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
+ TCL_DEPRECATED_API("") int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
void (*reserved47)(void);
void (*reserved48)(void);
void (*reserved49)(void);
- void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
+ TCL_DEPRECATED_API("") void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
void (*reserved52)(void);
- int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */
- int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
+ TCL_DEPRECATED_API("") int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size argc, const char **argv); /* 53 */
+ TCL_DEPRECATED_API("") int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
void (*reserved57)(void);
@@ -716,37 +757,37 @@ typedef struct TclIntStubs {
int (*tclNeedSpace) (const char *start, const char *end); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
- int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */
- int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */
+ TCL_DEPRECATED_API("") int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 63 */
+ int (*tclObjInvoke) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 64 */
void (*reserved65)(void);
void (*reserved66)(void);
void (*reserved67)(void);
void (*reserved68)(void);
- char * (*tclpAlloc) (unsigned int size); /* 69 */
+ void * (*tclpAlloc) (TCL_HASH_TYPE size); /* 69 */
void (*reserved70)(void);
void (*reserved71)(void);
void (*reserved72)(void);
void (*reserved73)(void);
- void (*tclpFree) (char *ptr); /* 74 */
+ void (*tclpFree) (void *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
- void (*tclpGetTime) (Tcl_Time *time); /* 77 */
+ TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
- char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
+ void * (*tclpRealloc) (void *ptr, TCL_HASH_TYPE size); /* 81 */
void (*reserved82)(void);
void (*reserved83)(void);
void (*reserved84)(void);
void (*reserved85)(void);
void (*reserved86)(void);
void (*reserved87)(void);
- char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */
+ TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */
int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */
void (*reserved90)(void);
void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */
int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */
- void (*tclProcDeleteProc) (ClientData clientData); /* 93 */
+ void (*tclProcDeleteProc) (void *clientData); /* 93 */
void (*reserved94)(void);
void (*reserved95)(void);
int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
@@ -754,48 +795,48 @@ typedef struct TclIntStubs {
int (*tclServiceIdle) (void); /* 98 */
void (*reserved99)(void);
void (*reserved100)(void);
- CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
+ TCL_DEPRECATED_API("Use Tcl_SetPreInitScript") const char * (*tclSetPreInitScript) (const char *string); /* 101 */
void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
- int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
+ TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
void (*reserved105)(void);
void (*reserved106)(void);
void (*reserved107)(void);
void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
- int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
+ int (*tclSockMinimumBuffers) (void *sock, Tcl_Size size); /* 110 */
void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
- int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
- void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
- int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
- Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
+ TCL_DEPRECATED_API("Use Tcl_AppendExportList") int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
+ TCL_DEPRECATED_API("Use Tcl_CreateNamespace") Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
+ TCL_DEPRECATED_API("Use Tcl_DeleteNamespace") void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
+ TCL_DEPRECATED_API("Use Tcl_Export") int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
+ TCL_DEPRECATED_API("Use Tcl_FindCommand") Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
+ TCL_DEPRECATED_API("Use Tcl_FindNamespace") Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
- int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
- Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
- void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
- Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */
- Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */
+ TCL_DEPRECATED_API("Use Tcl_ForgetImport") int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
+ TCL_DEPRECATED_API("Use Tcl_GetCommandFromObj") Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
+ TCL_DEPRECATED_API("Use Tcl_GetCommandFullName") void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
+ TCL_DEPRECATED_API("Use Tcl_GetCurrentNamespace") Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
+ TCL_DEPRECATED_API("Use Tcl_GetGlobalNamespace") Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
- int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
+ TCL_DEPRECATED_API("Use ") int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */
- int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
- struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
+ TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
void (*reserved134)(void);
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
- CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
+ const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
- CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
- int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
+ const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
+ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */
int (*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 */
@@ -804,39 +845,39 @@ typedef struct TclIntStubs {
TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
void (*tclHandleRelease) (TclHandle handle); /* 149 */
int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */
- void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */
+ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */
void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */
Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
void (*reserved154)(void);
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
- const char * (*tclGetStartupScriptFileName) (void); /* 159 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
- void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
+ 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, int index, Tcl_Obj *valuePtr); /* 166 */
- void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
- Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
+ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* 166 */
+ TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
- int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
- int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
+ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 170 */
+ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
- int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
+ int (*tclUniCharMatch) (const Tcl_UniChar *string, Tcl_Size strLen, const Tcl_UniChar *pattern, Tcl_Size ptnLen, int flags); /* 173 */
void (*reserved174)(void);
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
- Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
+ TCL_DEPRECATED_API("") void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ TCL_DEPRECATED_API("") Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
- struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
- struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
+ TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
@@ -868,19 +909,19 @@ typedef struct TclIntStubs {
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
- void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */
+ void * (*tclStackAlloc) (Tcl_Interp *interp, TCL_HASH_TYPE numBytes); /* 215 */
void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
- void (*reserved219)(void);
+ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 219 */
void (*reserved220)(void);
- void (*reserved221)(void);
- void (*reserved222)(void);
+ Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 221 */
+ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 222 */
void * (*tclGetCStackPtr) (void); /* 223 */
TclPlatformType * (*tclGetPlatform) (void); /* 224 */
- Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
+ Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, Tcl_Size keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
- void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */
+ void (*tclSetNsPath) (Namespace *nsPtr, Tcl_Size pathLength, Tcl_Namespace *pathAry[]); /* 227 */
void (*reserved228)(void);
int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */
@@ -889,28 +930,28 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
+ TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
- int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
- int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
+ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 238 */
+ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Size skip, ProcErrorProc *errorProc); /* 239 */
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
- int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
+ int (*tclNREvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
- int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */
+ int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, Tcl_Size numRemoved, Tcl_Size 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, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
+ 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 (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
- int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
+ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
+ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, Tcl_Size 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 (*tclStaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
+ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
void (*reserved258)(void);
void (*reserved259)(void);
void (*reserved260)(void);
@@ -1102,38 +1143,38 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */
#define Tcl_AddInterpResolvers \
(tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
-#define Tcl_AppendExportList \
- (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
-#define Tcl_CreateNamespace \
- (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
-#define Tcl_DeleteNamespace \
- (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
-#define Tcl_Export \
- (tclIntStubsPtr->tcl_Export) /* 115 */
-#define Tcl_FindCommand \
- (tclIntStubsPtr->tcl_FindCommand) /* 116 */
-#define Tcl_FindNamespace \
- (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
+#define TclAppendExportList \
+ (tclIntStubsPtr->tclAppendExportList) /* 112 */
+#define TclCreateNamespace \
+ (tclIntStubsPtr->tclCreateNamespace) /* 113 */
+#define TclDeleteNamespace \
+ (tclIntStubsPtr->tclDeleteNamespace) /* 114 */
+#define TclExport \
+ (tclIntStubsPtr->tclExport) /* 115 */
+#define TclFindCommand \
+ (tclIntStubsPtr->tclFindCommand) /* 116 */
+#define TclFindNamespace \
+ (tclIntStubsPtr->tclFindNamespace) /* 117 */
#define Tcl_GetInterpResolvers \
(tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#define Tcl_GetNamespaceResolvers \
(tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#define Tcl_FindNamespaceVar \
(tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
-#define Tcl_ForgetImport \
- (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
-#define Tcl_GetCommandFromObj \
- (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
-#define Tcl_GetCommandFullName \
- (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
-#define Tcl_GetCurrentNamespace \
- (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
-#define Tcl_GetGlobalNamespace \
- (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
+#define TclForgetImport \
+ (tclIntStubsPtr->tclForgetImport) /* 121 */
+#define TclGetCommandFromObj \
+ (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */
+#define TclGetCommandFullName \
+ (tclIntStubsPtr->tclGetCommandFullName) /* 123 */
+#define TclGetCurrentNamespace_ \
+ (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */
+#define TclGetGlobalNamespace_ \
+ (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */
#define Tcl_GetVariableFullName \
(tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
-#define Tcl_Import \
- (tclIntStubsPtr->tcl_Import) /* 127 */
+#define TclImport \
+ (tclIntStubsPtr->tclImport) /* 127 */
#define Tcl_PopCallFrame \
(tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#define Tcl_PushCallFrame \
@@ -1224,10 +1265,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-#define Tcl_SetStartupScript \
- (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
-#define Tcl_GetStartupScript \
- (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
+#define TclSetStartupScript \
+ (tclIntStubsPtr->tclSetStartupScript) /* 178 */
+#define TclGetStartupScript \
+ (tclIntStubsPtr->tclGetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
@@ -1286,10 +1327,13 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPushStackFrame) /* 217 */
#define TclPopStackFrame \
(tclIntStubsPtr->tclPopStackFrame) /* 218 */
-/* Slot 219 is reserved */
+#define TclpCreateTemporaryDirectory \
+ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 219 */
/* Slot 220 is reserved */
-/* Slot 221 is reserved */
-/* Slot 222 is reserved */
+#define TclListTestObj \
+ (tclIntStubsPtr->tclListTestObj) /* 221 */
+#define TclListObjValidate \
+ (tclIntStubsPtr->tclListObjValidate) /* 222 */
#define TclGetCStackPtr \
(tclIntStubsPtr->tclGetCStackPtr) /* 223 */
#define TclGetPlatform \
@@ -1343,8 +1387,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCopyChannel) /* 248 */
#define TclDoubleDigits \
(tclIntStubsPtr->tclDoubleDigits) /* 249 */
-#define TclSetSlaveCancelFlags \
- (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */
+#define TclSetChildCancelFlags \
+ (tclIntStubsPtr->tclSetChildCancelFlags) /* 250 */
#define TclRegisterLiteral \
(tclIntStubsPtr->tclRegisterLiteral) /* 251 */
#define TclPtrGetVar \
@@ -1357,8 +1401,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
#define TclPtrUnsetVar \
(tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
-#define TclStaticPackage \
- (tclIntStubsPtr->tclStaticPackage) /* 257 */
+#define TclStaticLibrary \
+ (tclIntStubsPtr->tclStaticLibrary) /* 257 */
/* Slot 258 is reserved */
/* Slot 259 is reserved */
/* Slot 260 is reserved */
@@ -1372,63 +1416,43 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#undef TclGetStartupScriptFileName
-#undef TclSetStartupScriptFileName
-#undef TclGetStartupScriptPath
-#undef TclSetStartupScriptPath
-#undef TclBackgroundException
+#if defined(USE_TCL_STUBS)
+# undef TclGetStartupScriptFileName
+# undef TclSetStartupScriptFileName
+# undef TclGetStartupScriptPath
+# undef TclSetStartupScriptPath
+# undef TclBackgroundException
+# undef TclSetStartupScript
+# undef TclGetStartupScript
+# undef TclGetIntForIndex
+# undef TclCreateNamespace
+# undef TclDeleteNamespace
+# undef TclAppendExportList
+# undef TclExport
+# undef TclImport
+# undef TclForgetImport
+# undef TclGetCurrentNamespace_
+# undef TclGetGlobalNamespace_
+# undef TclFindNamespace
+# undef TclFindCommand
+# undef TclGetCommandFromObj
+# undef TclGetCommandFullName
+# undef TclCopyChannelOld
+# undef TclSockMinimumBuffersOld
+# undef Tcl_StaticLibrary
+# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary)
+#endif
+
#undef TclUnusedStubEntry
+#undef TclGuessPackageName
+#undef TclSetPreInitScript
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
+#define TclObjInterpProc2 TclObjInterpProc
-#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
-# undef Tcl_SetStartupScript
-# define Tcl_SetStartupScript \
- (tclStubsPtr->tcl_SetStartupScript) /* 622 */
-# undef Tcl_GetStartupScript
-# define Tcl_GetStartupScript \
- (tclStubsPtr->tcl_GetStartupScript) /* 623 */
-# undef Tcl_CreateNamespace
-# define Tcl_CreateNamespace \
- (tclStubsPtr->tcl_CreateNamespace) /* 506 */
-# undef Tcl_DeleteNamespace
-# define Tcl_DeleteNamespace \
- (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
-# undef Tcl_AppendExportList
-# define Tcl_AppendExportList \
- (tclStubsPtr->tcl_AppendExportList) /* 508 */
-# undef Tcl_Export
-# define Tcl_Export \
- (tclStubsPtr->tcl_Export) /* 509 */
-# undef Tcl_Import
-# define Tcl_Import \
- (tclStubsPtr->tcl_Import) /* 510 */
-# undef Tcl_ForgetImport
-# define Tcl_ForgetImport \
- (tclStubsPtr->tcl_ForgetImport) /* 511 */
-# undef Tcl_GetCurrentNamespace
-# define Tcl_GetCurrentNamespace \
- (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
-# undef Tcl_GetGlobalNamespace
-# define Tcl_GetGlobalNamespace \
- (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
-# undef Tcl_FindNamespace
-# define Tcl_FindNamespace \
- (tclStubsPtr->tcl_FindNamespace) /* 514 */
-# undef Tcl_FindCommand
-# define Tcl_FindCommand \
- (tclStubsPtr->tcl_FindCommand) /* 515 */
-# undef Tcl_GetCommandFromObj
-# define Tcl_GetCommandFromObj \
- (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
-# undef Tcl_GetCommandFullName
-# define Tcl_GetCommandFullName \
- (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+#ifndef TCL_NO_DEPRECATED
+# define TclSetPreInitScript Tcl_SetPreInitScript
+# define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0)
#endif
-#undef TclCopyChannelOld
-#undef TclSockMinimumBuffersOld
-
-#define TclSetChildCancelFlags TclSetSlaveCancelFlags
-
#endif /* _TCLINTDECLS */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 5bd4828..1a43e15 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -110,7 +110,7 @@ EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -137,7 +137,7 @@ EXTERN unsigned short TclWinNToHS(unsigned short ns);
EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen);
/* 8 */
-EXTERN int TclpGetPid(Tcl_Pid pid);
+EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid);
/* 9 */
EXTERN int TclWinGetPlatformId(void);
/* 10 */
@@ -169,7 +169,7 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
-EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id);
+EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id);
/* 21 */
EXTERN char * TclpInetNtoa(struct in_addr addr);
/* 22 */
@@ -185,7 +185,7 @@ EXTERN void TclWinFlushDirtyChannels(void);
/* 28 */
EXTERN void TclWinResetInterfaces(void);
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -261,7 +261,7 @@ EXTERN TclFile TclpCreateTempFile_(const char *contents);
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -302,7 +302,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
@@ -314,7 +314,7 @@ typedef struct TclIntPlatStubs {
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
- int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
+ Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
@@ -326,7 +326,7 @@ typedef struct TclIntPlatStubs {
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
- void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
+ void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
@@ -335,7 +335,7 @@ typedef struct TclIntPlatStubs {
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -368,7 +368,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
@@ -570,6 +570,11 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
+#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# undef TclWinConvertError
+# define TclWinConvertError Tcl_WinConvertError
+#endif
+
#undef TclpInetNtoa
#define TclpInetNtoa inet_ntoa
@@ -588,13 +593,21 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
# undef TclWinGetServByName
# undef TclWinGetSockOpt
# undef TclWinSetSockOpt
-# define TclWinNToHS ntohs
-# define TclWinGetServByName getservbyname
-# define TclWinGetSockOpt getsockopt
-# define TclWinSetSockOpt setsockopt
+# undef TclWinGetPlatformId
+# undef TclWinResetInterfaces
+# undef TclWinSetInterfaces
+# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define TclWinNToHS ntohs
+# define TclWinGetServByName getservbyname
+# define TclWinGetSockOpt getsockopt
+# define TclWinSetSockOpt setsockopt
+# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# define TclWinResetInterfaces() /* nop */
+# define TclWinSetInterfaces(dummy) /* nop */
+# endif /* TCL_NO_DEPRECATED */
#else
# undef TclpGetPid
-# define TclpGetPid(pid) ((unsigned long) (pid))
+# define TclpGetPid(pid) ((Tcl_Size)(size_t)(pid))
#endif
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index f33aeed..3d2c009 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -4,14 +4,15 @@
* This file implements the "interp" command which allows creation and
* manipulation of Tcl interpreters from within Tcl scripts.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 2004 Donal K. Fellows
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2004 Donal K. Fellows
*
* 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>
/*
* A pointer to a string that holds an initialization script that if non-NULL
@@ -186,7 +187,7 @@ struct LimitHandler {
int flags; /* The state of this particular handler. */
Tcl_LimitHandlerProc *handlerProc;
/* The handler callback. */
- ClientData clientData; /* Opaque argument to the handler callback. */
+ void *clientData; /* Opaque argument to the handler callback. */
Tcl_LimitHandlerDeleteProc *deleteProc;
/* How to delete the clientData. */
LimitHandler *prevPtr; /* Previous item in linked list of
@@ -222,9 +223,6 @@ static int AliasDelete(Tcl_Interp *interp,
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *childInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
static Tcl_ObjCmdProc AliasNRCmd;
static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;
static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
@@ -251,11 +249,9 @@ static int ChildHidden(Tcl_Interp *interp,
static int ChildInvokeHidden(Tcl_Interp *interp,
Tcl_Interp *childInterp,
const char *namespaceName,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Size objc, Tcl_Obj *const objv[]);
static int ChildMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *childInterp);
-static int ChildObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
static Tcl_CmdDeleteProc ChildObjCmdDeleteProc;
static int ChildRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *childInterp, int objc,
@@ -270,12 +266,12 @@ static void InheritLimitsFromParent(Tcl_Interp *childInterp,
Tcl_Interp *parentInterp);
static void SetScriptLimitCallback(Tcl_Interp *interp, int type,
Tcl_Interp *targetInterp, Tcl_Obj *scriptObj);
-static void CallScriptLimitCallback(ClientData clientData,
+static void CallScriptLimitCallback(void *clientData,
Tcl_Interp *interp);
-static void DeleteScriptLimitCallback(ClientData clientData);
+static void DeleteScriptLimitCallback(void *clientData);
static void RunLimitHandlers(LimitHandler *handlerPtr,
Tcl_Interp *interp);
-static void TimeLimitCallback(ClientData clientData);
+static void TimeLimitCallback(void *clientData);
/* NRE enabling */
static Tcl_NRPostProc NRPostInvokeHidden;
@@ -286,7 +282,7 @@ static Tcl_ObjCmdProc NRChildCmd;
/*
*----------------------------------------------------------------------
*
- * TclSetPreInitScript --
+ * Tcl_SetPreInitScript --
*
* This routine is used to change the value of the internal variable,
* tclPreInitScript.
@@ -301,7 +297,7 @@ static Tcl_ObjCmdProc NRChildCmd;
*/
const char *
-TclSetPreInitScript(
+Tcl_SetPreInitScript(
const char *string) /* Pointer to a script. */
{
const char *prevString = tclPreInitScript;
@@ -328,13 +324,24 @@ TclSetPreInitScript(
*----------------------------------------------------------------------
*/
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being initialized. */
+ char name[4];
+} PkgName;
+
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
+ PkgName pkgName = {NULL, "tcl"};
+ PkgName **names = (PkgName **)TclInitPkgFiles(interp);
+ int result = TCL_ERROR;
+
+ pkgName.nextPtr = *names;
+ *names = &pkgName;
if (tclPreInitScript != NULL) {
- if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return TCL_ERROR;
+ if (Tcl_EvalEx(interp, tclPreInitScript, TCL_INDEX_NONE, 0) == TCL_ERROR) {
+ goto end;
}
}
@@ -379,7 +386,7 @@ Tcl_Init(
* alternate tclInit command before calling Tcl_Init().
*/
- return Tcl_Eval(interp,
+ result = Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
" proc tclInit {} {\n"
" global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -395,6 +402,7 @@ Tcl_Init(
"if {$tail eq [info tclversion]} continue\n"
"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
" }\n"
+" lappend scripts {::tcl::zipfs::tcl_library_init}\n"
" if {[info exists tclDefaultLibrary]} {\n"
" lappend scripts {set tclDefaultLibrary}\n"
" } else {\n"
@@ -407,6 +415,7 @@ Tcl_Init(
" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
" {file join $parentDir library} \\\n"
" {file join $grandParentDir library} \\\n"
+" {file join $grandParentDir tcl[info tclversion] library} \\\n"
" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
" {\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
@@ -441,7 +450,11 @@ Tcl_Init(
" error $msg\n"
" }\n"
"}\n"
-"tclInit");
+"tclInit", TCL_INDEX_NONE, 0);
+
+end:
+ *names = (*names)->nextPtr;
+ return result;
}
/*
@@ -510,7 +523,7 @@ TclInterpInit(
static void
InterpInfoDeleteProc(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* child interps should already be deleted. */
{
@@ -589,7 +602,7 @@ InterpInfoDeleteProc(
int
Tcl_InterpObjCmd(
- ClientData clientData, /* Unused. */
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -599,7 +612,7 @@ Tcl_InterpObjCmd(
static int
NRInterpCmd(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -609,27 +622,38 @@ NRInterpCmd(
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
+ "eval", "exists", "expose", "hide",
+ "hidden", "issafe", "invokehidden",
+ "limit", "marktrusted", "recursionlimit",
+ "share", "slaves", "target", "transfer",
+ NULL
+ };
+ static const char *const optionsNoSlaves[] = {
+ "alias", "aliases", "bgerror", "cancel",
+ "children", "create", "debug", "delete",
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
- "slaves", "share", "target", "transfer",
- NULL
+ "share", "target", "transfer", NULL
};
enum interpOptionEnum {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE,
- OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
- OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
- OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
- OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
+ OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
+ OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
+ OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
+ OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], options,
+ "option", 0, &index) != TCL_OK) {
+ /* Don't report the "slaves" option as possibility */
+ Tcl_GetIndexFromObj(interp, objv[1], optionsNoSlaves,
+ "option", 0, &index);
return TCL_ERROR;
}
switch ((enum interpOptionEnum)index) {
@@ -639,7 +663,7 @@ NRInterpCmd(
if (objc < 4) {
aliasArgs:
Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?");
+ "childPath childCmd ?parentPath parentCmd? ?arg ...?");
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
@@ -845,7 +869,7 @@ NRInterpCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot delete the current interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "DELETESELF", NULL);
+ "DELETESELF", (void *)NULL);
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) childInterp)->interpInfo;
@@ -1087,9 +1111,9 @@ NRInterpCmd(
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
- aliasName, Tcl_GetString(objv[2])));
+ aliasName, TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
@@ -1098,7 +1122,7 @@ NRInterpCmd(
"target interpreter for alias \"%s\" in path \"%s\" is "
"not my descendant", aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "TARGETSHROUDED", NULL);
+ "TARGETSHROUDED", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1167,12 +1191,12 @@ Tcl_CreateAlias(
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
- int argc, /* How many additional arguments? */
+ Tcl_Size argc, /* How many additional arguments? */
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
Tcl_Obj **objv;
- int i;
+ Tcl_Size i;
int result;
objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc);
@@ -1222,7 +1246,7 @@ Tcl_CreateAliasObj(
const char *childCmd, /* Command to install in child. */
Tcl_Interp *targetInterp, /* Interpreter for target command. */
const char *targetCmd, /* Name of target command. */
- int objc, /* How many additional arguments? */
+ Tcl_Size objc, /* How many additional arguments? */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Tcl_Obj *childObjPtr, *targetObjPtr;
@@ -1278,7 +1302,7 @@ Tcl_GetAlias(
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (void *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
@@ -1340,7 +1364,7 @@ Tcl_GetAliasObj(
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (void *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
@@ -1401,7 +1425,8 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd
+ && cmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
@@ -1446,7 +1471,7 @@ TclPreventAliasLoop(
"cannot define or rename alias \"%s\": would create a loop",
Tcl_GetCommandName(cmdInterp, cmd)));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "ALIASLOOP", NULL);
+ "ALIASLOOP", (void *)NULL);
return TCL_ERROR;
}
@@ -1456,7 +1481,8 @@ TclPreventAliasLoop(
* Otherwise we do not have a loop.
*/
- if (aliasCmdPtr->objProc != AliasObjCmd) {
+ if (aliasCmdPtr->objProc != TclAliasObjCmd
+ && aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *)aliasCmdPtr->objClientData;
@@ -1520,12 +1546,12 @@ AliasCreate(
if (childInterp == parentInterp) {
aliasPtr->childCmd = Tcl_NRCreateCommand(childInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd,
+ aliasPtr, AliasObjCmdDeleteProc);
} else {
- aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ aliasPtr->childCmd = Tcl_CreateObjCommand(childInterp,
+ TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, childInterp,
@@ -1666,7 +1692,7 @@ AliasDelete(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", TclGetString(namePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
- TclGetString(namePtr), NULL);
+ TclGetString(namePtr), (void *)NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
@@ -1762,7 +1788,7 @@ AliasList(
/*
*----------------------------------------------------------------------
*
- * AliasObjCmd --
+ * TclAliasObjCmd, TclLocalAliasObjCmd --
*
* This is the function that services invocations of aliases in a child
* interpreter. One such command exists for each alias. When invoked,
@@ -1770,6 +1796,11 @@ AliasList(
* parent interpreter as designated by the Alias record associated with
* this command.
*
+ * TclLocalAliasObjCmd is a stripped down version used when the source
+ * and target interpreters of the alias are the same. That lets a number
+ * of safety precautions be avoided: the state is much more precisely
+ * known.
+ *
* Results:
* A standard Tcl result.
*
@@ -1783,7 +1814,7 @@ AliasList(
static int
AliasNRCmd(
- ClientData clientData, /* Alias record. */
+ void *clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
@@ -1792,7 +1823,7 @@ AliasNRCmd(
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
- List *listRep;
+ ListRep listRep;
int flags = TCL_EVAL_INVOKE;
/*
@@ -1804,10 +1835,15 @@ AliasNRCmd(
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
+ /* TODO - encapsulate this into tclListObj.c */
listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = listPtr->internalRep.twoPtrValue.ptr1;
- listRep->elemCount = cmdc;
- cmdv = &listRep->elements;
+ 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 *));
@@ -1829,9 +1865,9 @@ AliasNRCmd(
return Tcl_NREvalObj(interp, listPtr, flags);
}
-static int
-AliasObjCmd(
- ClientData clientData, /* Alias record. */
+int
+TclAliasObjCmd(
+ void *clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
@@ -1919,6 +1955,73 @@ AliasObjCmd(
return result;
#undef ALIAS_CMDV_PREALLOC
}
+
+int
+TclLocalAliasObjCmd(
+ void *clientData, /* Alias record. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument vector. */
+{
+#define ALIAS_CMDV_PREALLOC 10
+ Alias *aliasPtr = (Alias *)clientData;
+ int result, prefc, cmdc, i;
+ Tcl_Obj **prefv, **cmdv;
+ Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
+ Interp *iPtr = (Interp *) interp;
+ int isRootEnsemble;
+
+ /*
+ * Append the arguments to the command prefix and invoke the command in
+ * the global namespace.
+ */
+
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+ if (cmdc <= ALIAS_CMDV_PREALLOC) {
+ cmdv = cmdArr;
+ } else {
+ cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
+ }
+
+ 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:
+ * only the source command should show, not the full target prefix.
+ */
+
+ isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv);
+
+ /*
+ * Execute the target command in the target interpreter.
+ */
+
+ result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE);
+
+ /*
+ * Clean up the ensemble rewrite info if we set it in the first place.
+ */
+
+ if (isRootEnsemble) {
+ TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1);
+ }
+
+ for (i=0; i<cmdc; i++) {
+ Tcl_DecrRefCount(cmdv[i]);
+ }
+ if (cmdv != cmdArr) {
+ TclStackFree(interp, cmdv);
+ }
+ return result;
+#undef ALIAS_CMDV_PREALLOC
+}
/*
*----------------------------------------------------------------------
@@ -1940,7 +2043,7 @@ AliasObjCmd(
static void
AliasObjCmdDeleteProc(
- ClientData clientData) /* The alias record for this alias. */
+ void *clientData) /* The alias record for this alias. */
{
Alias *aliasPtr = (Alias *)clientData;
Target *targetPtr;
@@ -2172,7 +2275,7 @@ Tcl_GetInterpPath(
InterpInfo *iiPtr;
if (targetInterp == interp) {
- Tcl_SetObjResult(interp, Tcl_NewObj());
+ Tcl_ResetResult(interp);
return TCL_OK;
}
if (targetInterp == NULL) {
@@ -2214,11 +2317,11 @@ GetInterp(
Tcl_HashEntry *hPtr; /* Search element. */
Child *childPtr; /* Interim child record. */
Tcl_Obj **objv;
- int objc, i;
+ Tcl_Size objc, i;
Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
InterpInfo *parentInfoPtr;
- if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
@@ -2241,7 +2344,7 @@ GetInterp(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not find interpreter \"%s\"", TclGetString(pathPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
- TclGetString(pathPtr), NULL);
+ TclGetString(pathPtr), (void *)NULL);
}
return searchInterp;
}
@@ -2272,14 +2375,14 @@ ChildBgerror(
Tcl_Obj *const objv[]) /* Argument strings. */
{
if (objc) {
- int length;
+ Tcl_Size length;
- if (TCL_ERROR == TclListObjLength(NULL, objv[0], &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);
+ "BGERRORFORMAT", (void *)NULL);
return TCL_ERROR;
}
TclSetBgErrorHandler(childInterp, objv[0]);
@@ -2318,10 +2421,11 @@ ChildCreate(
InterpInfo *parentInfoPtr;
Tcl_HashEntry *hPtr;
const char *path;
- int isNew, objc;
+ int isNew;
+ Tcl_Size objc;
Tcl_Obj **objv;
- if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ if (TclListObjGetElementsM(interp, pathPtr, &objc, &objv) != TCL_OK) {
return NULL;
}
if (objc < 2) {
@@ -2358,10 +2462,10 @@ ChildCreate(
childPtr->childEntryPtr = hPtr;
childPtr->childInterp = childInterp;
childPtr->interpCmd = Tcl_NRCreateCommand(parentInterp, path,
- ChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc);
+ TclChildObjCmd, NRChildCmd, childInterp, ChildObjCmdDeleteProc);
Tcl_InitHashTable(&childPtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, childPtr);
- Tcl_SetVar(childInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(childInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY);
/*
* Inherit the recursion limit.
@@ -2371,7 +2475,7 @@ ChildCreate(
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
- if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
+ if (TclMakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
@@ -2426,7 +2530,7 @@ ChildCreate(
/*
*----------------------------------------------------------------------
*
- * ChildObjCmd --
+ * TclChildObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each child interpreter.
@@ -2440,9 +2544,9 @@ ChildCreate(
*----------------------------------------------------------------------
*/
-static int
-ChildObjCmd(
- ClientData clientData, /* Child interpreter. */
+int
+TclChildObjCmd(
+ void *clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2452,7 +2556,7 @@ ChildObjCmd(
static int
NRChildCmd(
- ClientData clientData, /* Child interpreter. */
+ void *clientData, /* Child interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2473,7 +2577,7 @@ NRChildCmd(
};
if (childInterp == NULL) {
- Tcl_Panic("ChildObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclChildObjCmd: interpreter has been deleted");
}
if (objc < 2) {
@@ -2658,7 +2762,7 @@ NRChildCmd(
static void
ChildObjCmdDeleteProc(
- ClientData clientData) /* The ChildRecord for the command. */
+ void *clientData) /* The ChildRecord for the command. */
{
Child *childPtr; /* Interim storage for Child record. */
Tcl_Interp *childInterp = (Tcl_Interp *)clientData;
@@ -2850,7 +2954,7 @@ ChildExpose(
"permission denied: safe interpreter cannot expose commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -2895,7 +2999,7 @@ ChildRecursionLimit(
Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
"safe interpreters cannot change recursion limit", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
@@ -2905,7 +3009,7 @@ ChildRecursionLimit(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"recursion limit must be > 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_SetRecursionLimit(childInterp, limit);
@@ -2913,14 +3017,14 @@ ChildRecursionLimit(
if (interp == childInterp && iPtr->numLevels > limit) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"falling back due to new recursion limit", -1));
- Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RECURSION", (void *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[0]);
return TCL_OK;
} else {
limit = Tcl_SetRecursionLimit(childInterp, 0);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit));
return TCL_OK;
}
}
@@ -2956,7 +3060,7 @@ ChildHide(
"permission denied: safe interpreter cannot hide commands",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -3031,7 +3135,7 @@ ChildInvokeHidden(
Tcl_Interp *childInterp, /* The child interpreter in which command will
* be invoked. */
const char *namespaceName, /* The namespace to use, if any. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result;
@@ -3041,7 +3145,7 @@ ChildInvokeHidden(
"not allowed to invoke hidden commands from safe interpreter",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
@@ -3075,7 +3179,7 @@ ChildInvokeHidden(
static int
NRPostInvokeHidden(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -3118,7 +3222,7 @@ ChildMarkTrusted(
"permission denied: safe interpreter cannot mark trusted",
-1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
((Interp *) childInterp)->flags &= ~SAFE_INTERP;
@@ -3156,7 +3260,7 @@ Tcl_IsSafe(
/*
*----------------------------------------------------------------------
*
- * Tcl_MakeSafe --
+ * TclMakeSafe --
*
* Makes its argument interpreter contain only functionality that is
* defined to be part of Safe Tcl. Unsafe commands are hidden, the env
@@ -3173,7 +3277,7 @@ Tcl_IsSafe(
*/
int
-Tcl_MakeSafe(
+TclMakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
@@ -3190,12 +3294,8 @@ Tcl_MakeSafe(
* Assume these functions all work. [Bug 2895741]
*/
- (void) Tcl_Eval(interp,
- "namespace eval ::tcl {namespace eval mathfunc {}}");
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", parent,
- "::tcl::mathfunc::min", 0, NULL);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", parent,
- "::tcl::mathfunc::max", 0, NULL);
+ (void) Tcl_EvalEx(interp,
+ "namespace eval ::tcl {namespace eval mathfunc {}}", TCL_INDEX_NONE, 0);
}
iPtr->flags |= SAFE_INTERP;
@@ -3209,7 +3309,7 @@ Tcl_MakeSafe(
* No env array in a safe interpreter.
*/
- Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
@@ -3225,9 +3325,9 @@ Tcl_MakeSafe(
* nameofexecutable])
*/
- Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tclDefaultLibrary", NULL, TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters do
@@ -3376,7 +3476,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command count limit exceeded", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", (void *)NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -3402,7 +3502,7 @@ Tcl_LimitCheck(
} else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"time limit exceeded", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", (void *)NULL);
Tcl_Release(interp);
return TCL_ERROR;
}
@@ -3512,7 +3612,7 @@ Tcl_LimitAddHandler(
Tcl_Interp *interp,
int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData,
+ void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
{
Interp *iPtr = (Interp *) interp;
@@ -3586,7 +3686,7 @@ Tcl_LimitRemoveHandler(
Tcl_Interp *interp,
int type,
Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData)
+ void *clientData)
{
Interp *iPtr = (Interp *) interp;
LimitHandler *handlerPtr;
@@ -3889,7 +3989,7 @@ Tcl_LimitTypeReset(
void
Tcl_LimitSetCommands(
Tcl_Interp *interp,
- int commandLimit)
+ Tcl_Size commandLimit)
{
Interp *iPtr = (Interp *) interp;
@@ -3985,7 +4085,7 @@ Tcl_LimitSetTime(
static void
TimeLimitCallback(
- ClientData clientData)
+ void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Interp *iPtr = (Interp *)clientData;
@@ -4129,7 +4229,7 @@ Tcl_LimitGetGranularity(
static void
DeleteScriptLimitCallback(
- ClientData clientData)
+ void *clientData)
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
@@ -4160,8 +4260,8 @@ DeleteScriptLimitCallback(
static void
CallScriptLimitCallback(
- ClientData clientData,
- Tcl_Interp *interp) /* Interpreter which failed the limit */
+ void *clientData,
+ TCL_UNUSED(Tcl_Interp *))
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
int code;
@@ -4414,7 +4514,7 @@ ChildCommandLimitCmd(
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", (void *)NULL);
return TCL_ERROR;
}
@@ -4442,12 +4542,12 @@ ChildCommandLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_COMMANDS)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
} else {
Tcl_Obj *empty;
@@ -4475,13 +4575,13 @@ ChildCommandLimitCmd(
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_COMMANDS)));
break;
case OPT_VAL:
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) {
Tcl_SetObjResult(interp,
- Tcl_NewIntObj(Tcl_LimitGetCommands(childInterp)));
+ Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp)));
}
break;
}
@@ -4490,7 +4590,8 @@ ChildCommandLimitCmd(
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
- int i, scriptLen = 0, limitLen = 0;
+ int i;
+ Tcl_Size scriptLen = 0, limitLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
int gran = 0, limit = 0;
@@ -4502,7 +4603,7 @@ ChildCommandLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(scriptObj, &scriptLen);
+ (void) TclGetStringFromObj(scriptObj, &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4513,13 +4614,13 @@ ChildCommandLimitCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
+ "BADVALUE", (void *)NULL);
return TCL_ERROR;
}
break;
case OPT_VAL:
limitObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
+ (void) TclGetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
@@ -4530,7 +4631,7 @@ ChildCommandLimitCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command limit value must be at least 0", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
+ "BADVALUE", (void *)NULL);
return TCL_ERROR;
}
break;
@@ -4602,7 +4703,7 @@ ChildTimeLimitCmd(
if (interp == childInterp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"limits on current interpreter inaccessible", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", (void *)NULL);
return TCL_ERROR;
}
@@ -4629,7 +4730,7 @@ ChildTimeLimitCmd(
Tcl_NewStringObj(options[0], -1), empty);
}
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(childInterp,
+ Tcl_NewWideIntObj(Tcl_LimitGetGranularity(childInterp,
TCL_LIMIT_TIME)));
if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_TIME)) {
@@ -4637,9 +4738,9 @@ ChildTimeLimitCmd(
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
- Tcl_NewLongObj(limitMoment.sec));
+ Tcl_NewWideIntObj(limitMoment.sec));
} else {
Tcl_Obj *empty;
@@ -4669,7 +4770,7 @@ ChildTimeLimitCmd(
}
break;
case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_LimitGetGranularity(childInterp, TCL_LIMIT_TIME)));
break;
case OPT_MILLI:
@@ -4678,7 +4779,7 @@ ChildTimeLimitCmd(
Tcl_LimitGetTime(childInterp, &limitMoment);
Tcl_SetObjResult(interp,
- Tcl_NewLongObj(limitMoment.usec/1000));
+ Tcl_NewWideIntObj(limitMoment.usec/1000));
}
break;
case OPT_SEC:
@@ -4695,12 +4796,13 @@ ChildTimeLimitCmd(
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
- int i, scriptLen = 0, milliLen = 0, secLen = 0;
+ int i;
+ Tcl_Size scriptLen = 0, milliLen = 0, secLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL;
Tcl_Obj *milliObj = NULL, *secObj = NULL;
int gran = 0;
Tcl_Time limitMoment;
- int tmp;
+ Tcl_WideInt tmp;
Tcl_LimitGetTime(childInterp, &limitMoment);
for (i=consumedObjc ; i<objc ; i+=2) {
@@ -4711,7 +4813,7 @@ ChildTimeLimitCmd(
switch ((enum Options) index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
+ (void) TclGetStringFromObj(objv[i+1], &scriptLen);
break;
case OPT_GRAN:
granObj = objv[i+1];
@@ -4722,55 +4824,47 @@ ChildTimeLimitCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"granularity must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
+ "BADVALUE", (void *)NULL);
return TCL_ERROR;
}
break;
case OPT_MILLI:
milliObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
+ (void) TclGetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
- if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
- if (tmp < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "milliseconds must be at least 0", -1));
+ if (tmp < 0 || tmp > LONG_MAX) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "milliseconds must be between 0 and %ld", LONG_MAX));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
+ "BADVALUE", (void *)NULL);
return TCL_ERROR;
}
- limitMoment.usec = ((long) tmp)*1000;
+ limitMoment.usec = ((long)tmp)*1000;
break;
- case OPT_SEC: {
- Tcl_WideInt sec;
+ case OPT_SEC:
secObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
+ (void) TclGetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
- if (TclGetWideIntFromObj(interp, objv[i+1], &sec) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
- if (sec > LONG_MAX) {
+ if (tmp < 0 || tmp > LONG_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seconds must be between 0 and %ld", LONG_MAX));
- goto badValue;
- }
- if (sec < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "seconds must be at least 0", -1));
- badValue:
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
+ "BADVALUE", (void *)NULL);
return TCL_ERROR;
}
- limitMoment.sec = sec;
+ limitMoment.sec = (long)tmp;
break;
}
- }
}
if (milliObj != NULL || secObj != NULL) {
if (milliObj != NULL) {
@@ -4784,7 +4878,7 @@ ChildTimeLimitCmd(
"may only set -milliseconds if -seconds is not "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADUSAGE", NULL);
+ "BADUSAGE", (void *)NULL);
return TCL_ERROR;
}
if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
@@ -4792,7 +4886,7 @@ ChildTimeLimitCmd(
"may only reset -milliseconds if -seconds is "
"also being reset", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADUSAGE", NULL);
+ "BADUSAGE", (void *)NULL);
return TCL_ERROR;
}
}
diff --git a/generic/tclLink.c b/generic/tclLink.c
index b845032..9443db4 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -6,14 +6,18 @@
* Andreas Stolcke and this implementation is based heavily on a
* prototype implementation provided by him.
*
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2008 Rene Zaumseil
+ * Copyright © 2019 Donal K. Fellows
*
* 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 "tclTomMath.h"
+#include <math.h>
/*
* For each linked variable there is a data structure of the following type,
@@ -28,7 +32,12 @@ typedef struct Link {
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
- char *addr; /* Location of C variable. */
+ void *addr; /* Location of C variable. */
+ int bytes; /* Size of C variable array. This is 0 when
+ * single variables, and >0 used for array
+ * variables. */
+ int numElems; /* Number of elements in C variable array.
+ * Zero for single variables. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
char c;
@@ -37,12 +46,27 @@ typedef struct Link {
unsigned int ui;
short s;
unsigned short us;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
long l;
unsigned long ul;
+#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
double d;
+ void *aryPtr; /* Generic array. */
+ char *cPtr; /* char array */
+ unsigned char *ucPtr; /* unsigned char array */
+ short *sPtr; /* short array */
+ unsigned short *usPtr; /* unsigned short array */
+ int *iPtr; /* int array */
+ unsigned int *uiPtr; /* unsigned int array */
+ long *lPtr; /* long array */
+ unsigned long *ulPtr; /* unsigned long array */
+ Tcl_WideInt *wPtr; /* wide (long long) array */
+ Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */
+ float *fPtr; /* float array */
+ double *dPtr; /* double array */
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below for
@@ -56,21 +80,42 @@ typedef struct Link {
* LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is
* in progress for this variable, so trace
* callbacks on the variable should be ignored.
+ * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the
+ * heap.
+ * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on
+ * the heap.
*/
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
+#define LINK_ALLOC_ADDR 4
+#define LINK_ALLOC_LAST 8
/*
* Forward references to functions defined later in this file:
*/
-static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
+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 GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
-static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
+static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+ double *doublePtr);
+static int SetInvalidRealFromAny(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+
+/*
+ * A marker type used to flag weirdnesses so we can pass them around right.
+ */
+
+static Tcl_ObjType invalidRealType = {
+ "invalidReal", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -107,7 +152,7 @@ int
Tcl_LinkVar(
Tcl_Interp *interp, /* Interpreter in which varName exists. */
const char *varName, /* Name of a global variable in interp. */
- char *addr, /* Address of a C variable to be linked to
+ void *addr, /* Address of a C variable to be linked to
* varName. */
int type) /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
@@ -119,30 +164,40 @@ Tcl_LinkVar(
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
- TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
+ TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
- linkPtr = ckalloc(sizeof(Link));
+ linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
+ linkPtr->bytes = 0;
+ linkPtr->numElems = 0;
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
return TCL_ERROR;
}
@@ -155,8 +210,196 @@ Tcl_LinkVar(
LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
- TclNsDecrRefCount(linkPtr->nsPtr);
- ckfree(linkPtr);
+ LinkFree(linkPtr);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LinkArray --
+ *
+ * Link a C variable array to a Tcl variable so that changes to either
+ * one causes the other to change.
+ *
+ * Results:
+ * The return value is TCL_OK if everything went well or TCL_ERROR if an
+ * error occurred (the interp's result is also set after errors).
+ *
+ * Side effects:
+ * The value at *addr is linked to the Tcl variable "varName", using
+ * "type" to convert between string values for Tcl and binary values for
+ * *addr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LinkArray(
+ Tcl_Interp *interp, /* Interpreter in which varName exists. */
+ const char *varName, /* Name of a global variable in interp. */
+ void *addr, /* Address of a C variable to be linked to
+ * varName. If NULL then the necessary space
+ * will be allocated and returned as the
+ * interpreter result. */
+ int type, /* Type of C variable: TCL_LINK_INT, etc. Also
+ * may have TCL_LINK_READ_ONLY OR'ed in. */
+ int size) /* Size of C variable array, >1 if array */
+{
+ Tcl_Obj *objPtr;
+ Link *linkPtr;
+ Namespace *dummy;
+ const char *name;
+ int code;
+
+ if (size < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong array size given", -1));
+ return TCL_ERROR;
+ }
+
+ linkPtr = (Link *)ckalloc(sizeof(Link));
+ linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
+ linkPtr->numElems = size;
+ if (type & TCL_LINK_READ_ONLY) {
+ linkPtr->flags = LINK_READ_ONLY;
+ } else {
+ linkPtr->flags = 0;
+ }
+
+ switch (linkPtr->type) {
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ linkPtr->bytes = size * sizeof(int);
+ break;
+ case TCL_LINK_DOUBLE:
+ linkPtr->bytes = size * sizeof(double);
+ break;
+ case TCL_LINK_WIDE_INT:
+ linkPtr->bytes = size * sizeof(Tcl_WideInt);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ linkPtr->bytes = size * sizeof(Tcl_WideUInt);
+ break;
+ case TCL_LINK_CHAR:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ case TCL_LINK_UCHAR:
+ linkPtr->bytes = size * sizeof(unsigned char);
+ break;
+ case TCL_LINK_SHORT:
+ linkPtr->bytes = size * sizeof(short);
+ break;
+ case TCL_LINK_USHORT:
+ linkPtr->bytes = size * sizeof(unsigned short);
+ break;
+ case TCL_LINK_UINT:
+ linkPtr->bytes = size * sizeof(unsigned int);
+ break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
+ case TCL_LINK_LONG:
+ linkPtr->bytes = size * sizeof(long);
+ break;
+ case TCL_LINK_ULONG:
+ linkPtr->bytes = size * sizeof(unsigned long);
+ break;
+#endif
+ case TCL_LINK_FLOAT:
+ linkPtr->bytes = size * sizeof(float);
+ break;
+ case TCL_LINK_STRING:
+ linkPtr->bytes = size * sizeof(char);
+ size = 1; /* This is a variable length string, no need
+ * to check last value. */
+
+ /*
+ * If no address is given create one and use as address the
+ * not needed linkPtr->lastValue
+ */
+
+ if (addr == NULL) {
+ linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ addr = (char *) &linkPtr->lastValue.cPtr;
+ }
+ break;
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
+ linkPtr->bytes = size * sizeof(char);
+ break;
+ default:
+ LinkFree(linkPtr);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad linked array variable type", -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate C variable space in case no address is given
+ */
+
+ if (addr == NULL) {
+ linkPtr->addr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_ADDR;
+ } else {
+ linkPtr->addr = addr;
+ }
+
+ /*
+ * If necessary create space for last used value.
+ */
+
+ if (size > 1) {
+ linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
+ linkPtr->flags |= LINK_ALLOC_LAST;
+ }
+
+ /*
+ * Initialize allocated space.
+ */
+
+ if (linkPtr->flags & LINK_ALLOC_ADDR) {
+ memset(linkPtr->addr, 0, linkPtr->bytes);
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes);
+ }
+
+ /*
+ * Set common structure values.
+ */
+
+ linkPtr->interp = interp;
+ linkPtr->varName = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(linkPtr->varName);
+
+ TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY,
+ &(linkPtr->nsPtr), &dummy, &dummy, &name);
+ linkPtr->nsPtr->refCount++;
+
+ objPtr = ObjValue(linkPtr);
+ if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
+ TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(linkPtr->varName);
+ LinkFree(linkPtr);
+ return TCL_ERROR;
+ }
+
+ code = Tcl_TraceVar2(interp, varName, NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ LinkTraceProc, linkPtr);
+ if (code != TCL_OK) {
+ Tcl_DecrRefCount(linkPtr->varName);
+ LinkFree(linkPtr);
}
return code;
}
@@ -194,10 +437,7 @@ Tcl_UnlinkVar(
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
- if (linkPtr->nsPtr) {
- TclNsDecrRefCount(linkPtr->nsPtr);
- }
- ckfree(linkPtr);
+ LinkFree(linkPtr);
}
/*
@@ -248,6 +488,201 @@ Tcl_UpdateLinkedVar(
/*
*----------------------------------------------------------------------
*
+ * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial --
+ *
+ * Helper functions for LinkTraceProc and ObjValue. These are all
+ * factored out here to make those functions simpler.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetInt(
+ Tcl_Obj *objPtr,
+ int *intPtr)
+{
+ return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK
+ && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK);
+}
+
+static inline int
+GetWide(
+ Tcl_Obj *objPtr,
+ Tcl_WideInt *widePtr)
+{
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) {
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return 1;
+ }
+ *widePtr = intValue;
+ }
+ return 0;
+}
+
+static inline int
+GetUWide(
+ Tcl_Obj *objPtr,
+ Tcl_WideUInt *uwidePtr)
+{
+ if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) {
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return 1;
+ }
+ *uwidePtr = intValue;
+ }
+ return 0;
+}
+
+static inline int
+GetDouble(
+ Tcl_Obj *objPtr,
+ double *dblPtr)
+{
+ if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
+ return 0;
+ } else {
+#ifdef ACCEPT_NAN
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);
+
+ if (irPtr != NULL) {
+ *dblPtr = irPtr->doubleValue;
+ return 0;
+ }
+#endif /* ACCEPT_NAN */
+ return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
+ }
+}
+
+static inline int
+EqualDouble(
+ double a,
+ double b)
+{
+ return (a == b)
+#ifdef ACCEPT_NAN
+ || (isnan(a) && isnan(b))
+#endif /* ACCEPT_NAN */
+ ;
+}
+
+static inline int
+IsSpecial(
+ double a)
+{
+ return isinf(a)
+#ifdef ACCEPT_NAN
+ || isnan(a)
+#endif /* ACCEPT_NAN */
+ ;
+}
+
+/*
+ * Mark an object as holding a weird double.
+ */
+
+static int
+SetInvalidRealFromAny(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *objPtr)
+{
+ const char *str;
+ const char *endPtr;
+ int length;
+
+ str = TclGetStringFromObj(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;
+ }
+ if (*endPtr == 0) {
+ double doubleValue = 0.0;
+
+ Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+ TclFreeInternalRep(objPtr);
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = doubleValue;
+ return TCL_OK;
+ }
+ }
+ }
+ 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)
+{
+ int length;
+ const char *str = TclGetStringFromObj(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)
+{
+ int intValue;
+
+ if (TclHasInternalRep(objPtr, &invalidRealType)) {
+ goto gotdouble;
+ }
+ if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
+ *doublePtr = (double) intValue;
+ return TCL_OK;
+ }
+ if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
+ gotdouble:
+ *doublePtr = objPtr->internalRep.doubleValue;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* LinkTraceProc --
*
* This function is invoked when a linked Tcl variable is read, written,
@@ -268,21 +703,28 @@ Tcl_UpdateLinkedVar(
static char *
LinkTraceProc(
- ClientData clientData, /* Contains information about the link. */
+ void *clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
- const char *name1, /* First part of variable name. */
- const char *name2, /* Second part of variable name. */
+ 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 = clientData;
+ Link *linkPtr = (Link *)clientData;
int changed;
- size_t valueLength;
+ int valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
+ Tcl_WideUInt valueUWide;
double valueDouble;
+ int objc;
+ Tcl_Obj **objv;
+ int i;
/*
* If the variable is being unset, then just re-create it (with a trace)
@@ -292,10 +734,7 @@ LinkTraceProc(
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
- if (linkPtr->nsPtr) {
- TclNsDecrRefCount(linkPtr->nsPtr);
- }
- ckfree(linkPtr);
+ LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
@@ -322,49 +761,64 @@ LinkTraceProc(
*/
if (flags & TCL_TRACE_READS) {
- switch (linkPtr->type) {
- case TCL_LINK_INT:
- case TCL_LINK_BOOLEAN:
- changed = (LinkedVar(int) != linkPtr->lastValue.i);
- break;
- case TCL_LINK_DOUBLE:
- changed = (LinkedVar(double) != linkPtr->lastValue.d);
- break;
- case TCL_LINK_WIDE_INT:
- changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
- break;
- case TCL_LINK_WIDE_UINT:
- changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
- break;
- case TCL_LINK_CHAR:
- changed = (LinkedVar(char) != linkPtr->lastValue.c);
- break;
- case TCL_LINK_UCHAR:
- changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
- break;
- case TCL_LINK_SHORT:
- changed = (LinkedVar(short) != linkPtr->lastValue.s);
- break;
- case TCL_LINK_USHORT:
- changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
- break;
- case TCL_LINK_UINT:
- changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
- break;
- case TCL_LINK_LONG:
- changed = (LinkedVar(long) != linkPtr->lastValue.l);
- break;
- case TCL_LINK_ULONG:
- changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
- break;
- case TCL_LINK_FLOAT:
- changed = (LinkedVar(float) != linkPtr->lastValue.f);
- break;
- case TCL_LINK_STRING:
- changed = 1;
- break;
- default:
- return (char *) "internal error: bad linked variable type";
+ /*
+ * Variable arrays
+ */
+
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr,
+ linkPtr->bytes);
+ } else {
+ /* single variables */
+ switch (linkPtr->type) {
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ changed = (LinkedVar(int) != linkPtr->lastValue.i);
+ break;
+ case TCL_LINK_DOUBLE:
+ changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d);
+ break;
+ case TCL_LINK_WIDE_INT:
+ changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
+ break;
+ case TCL_LINK_WIDE_UINT:
+ changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
+ break;
+ case TCL_LINK_CHAR:
+ changed = (LinkedVar(char) != linkPtr->lastValue.c);
+ break;
+ case TCL_LINK_UCHAR:
+ changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
+ break;
+ case TCL_LINK_SHORT:
+ changed = (LinkedVar(short) != linkPtr->lastValue.s);
+ break;
+ case TCL_LINK_USHORT:
+ changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
+ break;
+ case TCL_LINK_UINT:
+ changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
+ break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
+ case TCL_LINK_LONG:
+ changed = (LinkedVar(long) != linkPtr->lastValue.l);
+ break;
+ case TCL_LINK_ULONG:
+ changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
+ break;
+#endif
+ case TCL_LINK_FLOAT:
+ changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f);
+ break;
+ case TCL_LINK_STRING:
+ case TCL_LINK_CHARS:
+ case TCL_LINK_BINARY:
+ changed = 1;
+ break;
+ default:
+ changed = 0;
+ /* return (char *) "internal error: bad linked variable type"; */
+ }
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
@@ -396,167 +850,377 @@ LinkTraceProc(
return (char *) "internal error: linked variable couldn't be read";
}
+ /*
+ * Special cases.
+ */
+
+ switch (linkPtr->type) {
+ case TCL_LINK_STRING:
+ value = TclGetStringFromObj(valueObj, &valueLength);
+ valueLength++; /* include end of string char */
+ pp = (char **) linkPtr->addr;
+
+ *pp = (char *)ckrealloc(*pp, valueLength);
+ memcpy(*pp, value, valueLength);
+ return NULL;
+
+ case TCL_LINK_CHARS:
+ value = (char *) TclGetStringFromObj(valueObj, &valueLength);
+ valueLength++; /* include end of string char */
+ if (valueLength > linkPtr->bytes) {
+ return (char *) "wrong size of char* value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
+ memcpy(linkPtr->addr, value, valueLength);
+ } else {
+ linkPtr->lastValue.c = '\0';
+ LinkedVar(char) = linkPtr->lastValue.c;
+ }
+ return NULL;
+
+ case TCL_LINK_BINARY:
+ value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
+ if (valueLength != linkPtr->bytes) {
+ return (char *) "wrong size of binary value";
+ }
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
+ memcpy(linkPtr->addr, value, valueLength);
+ } else {
+ linkPtr->lastValue.uc = (unsigned char) *value;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ }
+ return NULL;
+ }
+
+ /*
+ * A helper macro. Writing this as a function is messy because of type
+ * variance.
+ */
+
+#define InRange(lowerLimit, value, upperLimit) \
+ ((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 (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ 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";
+ }
+ }
+ } else {
+ int *varPtr = &linkPtr->lastValue.i;
+
+ if (GetInt(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have integer value";
+ }
+ LinkedVar(int) = *varPtr;
}
- LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have integer value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i];
+
+ if (GetWide(objv[i], varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have wide integer value";
+ }
+ }
+ } else {
+ Tcl_WideInt *varPtr = &linkPtr->lastValue.w;
+
+ if (GetWide(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have wide integer value";
+ }
+ LinkedVar(Tcl_WideInt) = *varPtr;
}
- LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
-#ifdef ACCEPT_NAN
- if (valueObj->typePtr != &tclDoubleType) {
-#endif
- if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have real value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have real value";
}
-#ifdef ACCEPT_NAN
}
- linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
-#endif
+ } else {
+ double *varPtr = &linkPtr->lastValue.d;
+
+ if (GetDouble(valueObj, varPtr)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have real value";
+ }
+ LinkedVar(double) = *varPtr;
}
- LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have boolean value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ int *varPtr = &linkPtr->lastValue.iPtr[i];
+
+ if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have boolean value";
+ }
+ }
+ } else {
+ int *varPtr = &linkPtr->lastValue.i;
+
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have boolean value";
+ }
+ LinkedVar(int) = *varPtr;
}
- LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_CHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have char value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have char value";
+ }
+ linkPtr->lastValue.cPtr[i] = (char) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have char value";
+ }
+ LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
- LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
break;
case TCL_LINK_UCHAR:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > UCHAR_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned char value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(0, valueInt, (int)UCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned char value";
+ }
+ linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(0, valueInt, (int)UCHAR_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned char value";
+ }
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc =
+ (unsigned char) valueInt;
}
- LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
break;
case TCL_LINK_SHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have short value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have short value";
+ }
+ linkPtr->lastValue.sPtr[i] = (short) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have short value";
+ }
+ LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
}
- LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
break;
case TCL_LINK_USHORT:
- if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
- && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
- || valueInt < 0 || valueInt > USHRT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned short value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetInt(objv[i], &valueInt)
+ || !InRange(0, valueInt, (int)USHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned short value";
+ }
+ linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt;
+ }
+ } else {
+ if (GetInt(valueObj, &valueInt)
+ || !InRange(0, valueInt, (int)USHRT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned short value";
+ }
+ LinkedVar(unsigned short) = linkPtr->lastValue.us =
+ (unsigned short) valueInt;
}
- LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
break;
case TCL_LINK_UINT:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || valueWide > UINT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned int value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetWide(objv[i], &valueWide)
+ || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned int value";
+ }
+ linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide;
+ }
+ } else {
+ if (GetWide(valueObj, &valueWide)
+ || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned int value";
+ }
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui =
+ (unsigned int) valueWide;
}
- LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < LONG_MIN || valueWide > LONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have long value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetWide(objv[i], &valueWide)
+ || !InRange(LONG_MIN, valueWide, LONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have long value";
+ }
+ linkPtr->lastValue.lPtr[i] = (long) valueWide;
+ }
+ } else {
+ if (GetWide(valueObj, &valueWide)
+ || !InRange(LONG_MIN, valueWide, LONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have long value";
+ }
+ LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide;
}
- LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
break;
case TCL_LINK_ULONG:
- if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
- || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned long value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetUWide(objv[i], &valueUWide)
+ || (valueUWide > ULONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned long value";
+ }
+ linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
+ }
+ } else {
+ if (GetUWide(valueObj, &valueUWide)
+ || (valueUWide > ULONG_MAX)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned long value";
+ }
+ LinkedVar(unsigned long) = linkPtr->lastValue.ul =
+ (unsigned long) valueUWide;
}
- LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
break;
+#endif
case TCL_LINK_WIDE_UINT:
- /*
- * FIXME: represent as a bignum.
- */
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
- && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have unsigned wide int value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetUWide(objv[i], &valueUWide)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *)
+ "variable array must have unsigned wide int value";
+ }
+ linkPtr->lastValue.uwPtr[i] = valueUWide;
+ }
+ } else {
+ if (GetUWide(valueObj, &valueUWide)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have unsigned wide int value";
+ }
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
- LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
break;
case TCL_LINK_FLOAT:
- if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
- && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
- || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
- TCL_GLOBAL_ONLY);
- return (char *) "variable must have float value";
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ for (i=0; i < objc; i++) {
+ if (GetDouble(objv[i], &valueDouble)
+ && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
+ && !IsSpecial(valueDouble)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable array must have float value";
+ }
+ linkPtr->lastValue.fPtr[i] = (float) valueDouble;
+ }
+ } else {
+ if (GetDouble(valueObj, &valueDouble)
+ && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
+ && !IsSpecial(valueDouble)) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
+ ObjValue(linkPtr), TCL_GLOBAL_ONLY);
+ return (char *) "variable must have float value";
+ }
+ LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble;
}
- LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
- break;
-
- case TCL_LINK_STRING:
- value = TclGetString(valueObj);
- valueLength = valueObj->length + 1;
- pp = (char **) linkPtr->addr;
-
- *pp = ckrealloc(*pp, valueLength);
- memcpy(*pp, value, valueLength);
break;
default:
return (char *) "internal error: bad linked variable type";
}
+
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes);
+ }
return NULL;
}
@@ -583,51 +1247,185 @@ ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
- Tcl_Obj *resultObj;
+ Tcl_Obj *resultObj, **objv;
+ int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewIntObj(linkPtr->lastValue.i);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewDoubleObj(objv[i], linkPtr->lastValue.dPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.c = LinkedVar(char);
- return Tcl_NewIntObj(linkPtr->lastValue.c);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.uc = LinkedVar(unsigned char);
- return Tcl_NewIntObj(linkPtr->lastValue.uc);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.s = LinkedVar(short);
- return Tcl_NewIntObj(linkPtr->lastValue.s);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.us = LinkedVar(unsigned short);
- return Tcl_NewIntObj(linkPtr->lastValue.us);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.lPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewIntObj(objv[i], linkPtr->lastValue.ulPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
+#endif
case TCL_LINK_FLOAT:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
- case TCL_LINK_WIDE_UINT:
+ case TCL_LINK_WIDE_UINT: {
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
+ for (i=0; i < linkPtr->numElems; i++) {
+ TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]);
+ }
+ resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
+ ckfree(objv);
+ return resultObj;
+ }
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
- /*
- * FIXME: represent as a bignum.
- */
- return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
+ Tcl_Obj *uwObj;
+ TclNewUIntObj(uwObj, linkPtr->lastValue.uw);
+ return uwObj;
+ }
+
case TCL_LINK_STRING:
p = LinkedVar(char *);
if (p == NULL) {
@@ -636,6 +1434,25 @@ ObjValue(
}
return Tcl_NewStringObj(p, -1);
+ case TCL_LINK_CHARS:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0';
+ /* take care of proper string end */
+ return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes);
+ }
+ linkPtr->lastValue.c = '\0';
+ return Tcl_NewStringObj(&linkPtr->lastValue.c, 1);
+
+ case TCL_LINK_BINARY:
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
+ return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr,
+ linkPtr->bytes);
+ }
+ linkPtr->lastValue.uc = LinkedVar(unsigned char);
+ return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1);
+
/*
* This code only gets executed if the link type is unknown (shouldn't
* ever happen).
@@ -646,110 +1463,37 @@ ObjValue(
return resultObj;
}
}
-
-static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-
-static Tcl_ObjType invalidRealType = {
- "invalidReal", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- NULL /* setFromAnyProc */
-};
-
-static int
-SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
- int length;
- const char *str;
- const char *endPtr;
-
- str = TclGetStringFromObj(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;
- if (*endPtr == 0) {
- double doubleValue = 0.0;
- Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
- if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->typePtr = &invalidRealType;
- objPtr->internalRep.doubleValue = doubleValue;
- return TCL_OK;
- }
- }
- }
- 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" and "0o"
- * (upperand lowercase). See bug [39f6304c2e].
+ *----------------------------------------------------------------------
+ *
+ * LinkFree --
+ *
+ * Free's allocated space of given link and link structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
*/
-int
-GetInvalidIntFromObj(Tcl_Obj *objPtr,
- int *intPtr)
-{
- const char *str = TclGetString(objPtr);
-
- if ((objPtr->length == 0) ||
- ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) {
- *intPtr = 0;
- return TCL_OK;
- } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
- *intPtr = (str[0] == '+');
- return TCL_OK;
- }
- return TCL_ERROR;
-}
-
-int
-GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
-{
- int intValue;
-
- if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
- return TCL_ERROR;
- }
- *widePtr = intValue;
- return TCL_OK;
-}
-/*
- * 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].
- */
-int
-GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
- double *doublePtr)
+static void
+LinkFree(
+ Link *linkPtr) /* Structure describing linked variable. */
{
- int intValue;
-
- if (objPtr->typePtr == &invalidRealType) {
- goto gotdouble;
+ if (linkPtr->nsPtr) {
+ TclNsDecrRefCount(linkPtr->nsPtr);
}
- if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
- *doublePtr = (double) intValue;
- return TCL_OK;
+ if (linkPtr->flags & LINK_ALLOC_ADDR) {
+ ckfree(linkPtr->addr);
}
- if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
- gotdouble:
- *doublePtr = objPtr->internalRep.doubleValue;
- return TCL_OK;
+ if (linkPtr->flags & LINK_ALLOC_LAST) {
+ ckfree(linkPtr->lastValue.aryPtr);
}
- return TCL_ERROR;
+ ckfree((char *) linkPtr);
}
/*
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index b2d6228..d9f13d0 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -3,39 +3,151 @@
*
* This file contains functions that implement the Tcl list object type.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * 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 <assert.h>
#include "tclInt.h"
+#include "tclTomMath.h"
/*
- * Prototypes for functions defined later in this file:
+ * 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?
*/
-static List * AttemptNewList(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static List * NewListInternalRep(int objc, Tcl_Obj *const objv[], int p);
-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);
+/*
+ * 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_)
+/*
+ * 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 { \
+ Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \
+ } while (0)
+/* Ditto for counts except upper limit is different */
+#define LIST_COUNT_ASSERT(countarg_) \
+ do { \
+ Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(count_ >= 0 && 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(Tcl_Size objc, Tcl_Obj *const objv[], int flags);
+static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *);
+static int ListRepInitAttempt(Tcl_Interp *,
+ Tcl_Size 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,
+ Tcl_Size rangeStart,
+ Tcl_Size rangeEnd,
+ int preserveSrcRep,
+ ListRep *rangeRepPtr);
+static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size 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 a two-pointer
- * representation. The first pointer designates a List structure that contains
- * an array of pointers to the element objects, together with integers that
- * represent the current element count and the allocated size of the array.
- * The second pointer is normally NULL; during execution of functions in this
- * file that operate on nested sublists, it is occasionally used as working
- * storage to avoid an auxiliary stack.
+ * The internal representation of a list object is ListRep defined in tcl.h.
*/
const Tcl_ObjType tclListType = {
@@ -47,130 +159,907 @@ const Tcl_ObjType tclListType = {
};
/* Macros to manipulate the List internal rep */
+#define ListRepIncrRefs(repPtr_) \
+ do { \
+ (repPtr_)->storePtr->refCount++; \
+ if ((repPtr_)->spanPtr) \
+ (repPtr_)->spanPtr->refCount++; \
+ } while (0)
-#define ListSetInternalRep(objPtr, listRepPtr) \
- (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
- (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
- (listRepPtr)->refCount++, \
- (objPtr)->typePtr = &tclListType
+/* 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)
-#ifndef TCL_MIN_ELEMENT_GROWTH
-#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
-#endif
+/* 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)
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * NewListInternalRep --
+ * ListSpanNew --
*
- * Creates a 'List' structure with space for 'objc' elements. 'objc' must
- * be > 0. If 'objv' is not NULL, The list is initialized with first
- * 'objc' values in that array. Otherwise the list is initialized to have
- * 0 elements, with space to add 'objc' more. Flag value 'p' indicates
- * how to behave on failure.
+ * Allocates and initializes memory for a new ListSpan. The reference
+ * count on the returned struct is 0.
*
- * Value
+ * Results:
+ * Non-NULL pointer to the allocated ListSpan.
*
- * A new 'List' structure with refCount 0. If some failure
- * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic'
- * is called if it is not.
+ * Side effects:
+ * The function will panic on memory allocation failure.
*
- * Effect
+ *------------------------------------------------------------------------
+ */
+static inline ListSpan *
+ListSpanNew(
+ Tcl_Size firstSlot, /* Starting slot index of the span */
+ Tcl_Size numSlots) /* Number of slots covered by the span */
+{
+ ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr));
+ spanPtr->refCount = 0;
+ spanPtr->spanStart = firstSlot;
+ spanPtr->spanLength = numSlots;
+ return spanPtr;
+}
+
+/*
+ *------------------------------------------------------------------------
*
- * The refCount of each value in 'objv' is incremented as it is added
- * to the list.
+ * 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) {
+ ckfree(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(
+ Tcl_Size length, /* Length of the proposed span */
+ Tcl_Size usedStorageLength, /* Number of slots currently in used */
+ Tcl_Size 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.
+ */
-static List *
-NewListInternalRep(
- int objc,
- Tcl_Obj *const objv[],
- int p)
+ 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 Tcl_Size
+ListStoreUpSize(Tcl_Size 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 */
+ Tcl_Size startIdx, /* Starting index of subarray within objv */
+ Tcl_Size 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 */
+ Tcl_Size startIdx, /* Starting index of subarray within objv */
+ Tcl_Size 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 */
+ Tcl_Size 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 */
+ size_t size) /* Size of attempted allocation that failed */
{
- List *listRepPtr;
+ 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", (void *)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", (void *)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, Tcl_Size shiftCount)
+{
+ ListStore *storePtr;
- if (objc <= 0) {
- Tcl_Panic("NewListInternalRep: expects positive element count");
+ 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, Tcl_Size 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 >= 0);
+ INVARIANT(storePtr->numAllocated <= LIST_MAX);
+ INVARIANT(storePtr->firstUsed >= 0);
+ INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
+ INVARIANT(storePtr->numUsed >= 0);
+ 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(
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ ListStore *storePtr;
+ Tcl_Size capacity;
+
/*
* First check to see if we'd overflow and try to allocate an object
- * larger than our memory allocator allows. Note that this is actually a
- * fairly small value when you're on a serious 64-bit machine, but that
- * requires API changes to fix. See [Bug 219196] for a discussion.
+ * larger than our memory allocator allows.
*/
-
- if ((size_t)objc > LIST_MAX) {
- if (p) {
- Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
- LIST_MAX);
+ if (objc > LIST_MAX) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
+ Tcl_Panic("max length of a Tcl list exceeded");
}
return NULL;
}
- listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
- if (listRepPtr == NULL) {
- if (p) {
- Tcl_Panic("list creation failed: unable to alloc %u bytes",
+ if (flags & LISTREP_SPACE_FLAGS) {
+ capacity = ListStoreUpSize(objc);
+ } else {
+ capacity = objc;
+ }
+
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ if (storePtr == NULL && capacity != objc) {
+ capacity = objc; /* Try allocating exact size */
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ }
+ if (storePtr == NULL) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
+ Tcl_Panic("list creation failed: unable to alloc %" TCL_SIZE_MODIFIER
+ "d bytes",
LIST_SIZE(objc));
}
return NULL;
}
- listRepPtr->canonicalFlag = 0;
- listRepPtr->refCount = 0;
- listRepPtr->maxElemCount = objc;
+ storePtr->refCount = 0;
+ storePtr->flags = 0;
+ storePtr->numAllocated = capacity;
+ if (capacity == objc) {
+ storePtr->firstUsed = 0;
+ } else {
+ Tcl_Size 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) {
- Tcl_Obj **elemPtrs;
- int i;
-
- listRepPtr->elemCount = objc;
- elemPtrs = &listRepPtr->elements;
- for (i = 0; i < objc; i++) {
- elemPtrs[i] = objv[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
+ storePtr->numUsed = objc;
+ ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv);
} else {
- listRepPtr->elemCount = 0;
+ storePtr->numUsed = 0;
}
- return listRepPtr;
+
+ return storePtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListStoreReallocate --
+ *
+ * Reallocates the memory for a ListStore allocating extra for
+ * possible future growth.
+ *
+ * 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, Tcl_Size needed)
+{
+ Tcl_Size capacity;
+ ListStore *newStorePtr;
+
+ capacity = ListStoreUpSize(needed);
+ newStorePtr =
+ (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(capacity));
+ if (newStorePtr == NULL) {
+ capacity = needed;
+ newStorePtr = (ListStore *)attemptckrealloc(storePtr,
+ LIST_SIZE(capacity));
+ if (newStorePtr == NULL)
+ return NULL;
+ }
+ /* Only the capacity has changed, fix it in the header */
+ newStorePtr->numAllocated = capacity;
+ return newStorePtr;
}
/*
*----------------------------------------------------------------------
*
- * AttemptNewList --
+ * 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.
*
- * Like NewListInternalRep, but additionally sets an error message on failure.
+ * 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(
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ int flags,
+ ListRep *repPtr
+ )
+{
+ ListStore *storePtr;
-static List *
-AttemptNewList(
+ 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,
- int objc,
- Tcl_Obj *const objv[])
+ Tcl_Size objc,
+ Tcl_Obj *const objv[],
+ ListRep *repPtr)
{
- List *listRepPtr = NewListInternalRep(objc, objv, 0);
+ int result = ListRepInit(objc, objv, 0, repPtr);
- if (interp != NULL && listRepPtr == NULL) {
+ if (result != TCL_OK && interp != NULL) {
if (objc > LIST_MAX) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
+ ListLimitExceededError(interp);
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list creation failed: unable to alloc %u bytes",
- LIST_SIZE(objc)));
+ MemoryAllocationError(interp, LIST_SIZE(objc));
}
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return listRepPtr;
+ 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;
+ Tcl_Size 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)
+{
+ Tcl_Size 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);
}
/*
@@ -178,20 +1067,23 @@ AttemptNewList(
*
* Tcl_NewListObj --
*
- * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is
- * defined, 'Tcl_DbNewListObj' is called instead.
+ * 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.
*
- * Value
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewListObj.
*
- * A new list 'Tcl_Obj' to which is appended values from 'objv', or if
- * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no
- * elements. The string representation of the new 'Tcl_Obj' is set to
- * NULL. The refCount of the list is 0.
+ * 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.
*
- * Effect
- *
- * The refCount of each elements in 'objv' is incremented as it is added
- * to the list.
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -201,7 +1093,7 @@ AttemptNewList(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size 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);
@@ -211,45 +1103,50 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
- Tcl_Obj *listPtr;
+ ListRep listRep;
+ Tcl_Obj *listObj;
- TclNewObj(listPtr);
+ TclNewObj(listObj);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
-
- /*
- * Now create the object.
- */
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- return listPtr;
+ return listObj;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
- * Tcl_DbNewListObj --
+ * 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.
*
- * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the
- * file name and line number from its caller. This simplifies debugging
- * since 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.
*
- * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead.
+ * 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.
*
*----------------------------------------------------------------------
*/
@@ -258,95 +1155,189 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size 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 *listPtr;
- List *listRepPtr;
+ Tcl_Obj *listObj;
+ ListRep listRep;
- TclDbNewObj(listPtr, file, line);
+ TclDbNewObj(listObj, file, line);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- /*
- * Now create the object.
- */
-
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
-
- return listPtr;
+ return listObj;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size 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_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(
+ Tcl_Size objc1, /* Count of objects referenced by objv1. */
+ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
+ Tcl_Size objc2, /* Count of objects referenced by objv2. */
+ Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */
+)
+{
+ Tcl_Obj *listObj;
+ ListStore *storePtr;
+ Tcl_Size 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 --
*
- * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of
- * creating a new one.
+ * 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. */
- int objc, /* Count of objects referenced by objv. */
+ Tcl_Size objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
-
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetListObj");
}
/*
- * Free any old string rep and any internal rep for the old type.
- */
-
- TclFreeIntRep(objPtr);
- TclInvalidateStringRep(objPtr);
-
- /*
* 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.
+ * object an empty string rep and a NULL type. NOTE ListRepInit must
+ * not be called with objc == 0!
*/
if (objc > 0) {
- listRepPtr = NewListInternalRep(objc, objv, 1);
- ListSetInternalRep(objPtr, listRepPtr);
+ ListRep listRep;
+ /* TODO - perhaps ask for extra space? */
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
+ TclFreeInternalRep(objPtr);
+ TclInvalidateStringRep(objPtr);
+ Tcl_InitStringRep(objPtr, NULL, 0);
}
}
@@ -355,20 +1346,18 @@ Tcl_SetListObj(
*
* TclListObjCopy --
*
- * Creates a new 'Tcl_Obj' which is a pure 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.
- *
- * Value
- *
- * The address of the new 'Tcl_Obj' which shares its internal
- * representation with 'listPtr', and whose refCount is 0. If 'listPtr'
- * is not actually a list, the value is NULL, and an error message is left
- * in 'interp' if it is not NULL.
+ * 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.
*
- * Effect
+ * 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.
*
- * 'listPtr' is converted to a list if it isn't one already.
+ * Side effects:
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -376,84 +1365,315 @@ Tcl_SetListObj(
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr) /* List object for which an element array is
+ Tcl_Obj *listObj) /* List object for which an element array is
* to be returned. */
{
- Tcl_Obj *copyPtr;
+ Tcl_Obj *copyObj;
- if (listPtr->typePtr != &tclListType) {
- if (SetListFromAny(interp, listPtr) != TCL_OK) {
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
}
}
- TclNewObj(copyPtr);
- TclInvalidateStringRep(copyPtr);
- DupListInternalRep(listPtr, copyPtr);
- return copyPtr;
+ 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 */
+ Tcl_Size rangeStart, /* Index of first element to include */
+ Tcl_Size 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;
+ Tcl_Size numSrcElems = ListRepLength(srcRepPtr);
+ Tcl_Size rangeLen;
+ Tcl_Size 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 < 0) {
+ rangeStart = 0;
+ }
+ if (rangeEnd >= numSrcElems) {
+ rangeEnd = numSrcElems - 1;
+ }
+ if (rangeStart > rangeEnd) {
+ /* 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 */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ 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 */
+ Tcl_Size 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 */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ 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;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjGetElements --
+ * TclListObjRange --
*
- * Retreive the elements in a list 'Tcl_Obj'.
+ * Makes a slice of a list value.
+ * *listObj must be known to be a valid list.
*
- * Value
+ * 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.
*
- * TCL_OK
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object.
*
- * A count of list elements is stored, 'objcPtr', And a pointer to the
- * array of elements in the list is stored in 'objvPtr'.
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclListObjRange(
+ Tcl_Interp *interp, /* May be NULL. Used for error messages */
+ Tcl_Obj *listObj, /* List object to take a range from. */
+ Tcl_Size rangeStart, /* Index of first element to include. */
+ Tcl_Size rangeEnd) /* Index of last element to include. */
+{
+ ListRep listRep;
+ ListRep resultRep;
+
+ int isShared;
+ if (TclListObjGetRep(interp, 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;
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * The elements accessible via 'objvPtr' should be treated as readonly
- * and the refCount for each object is _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.
+ * Tcl_ListObjGetElements --
*
- * TCL_ERROR
+ * This function returns an (objc,objv) array of the elements in a list
+ * object.
*
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * 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.
*
- * Effect
+ * 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.
*
- * 'listPtr' is converted to a list object if it isn't one already.
+ * 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 *listPtr, /* List object for which an element array is
+ Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
- int *objcPtr, /* Where to store the count of objects
+ Tcl_Size *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. */
{
- List *listRepPtr;
-
- if (listPtr->typePtr != &tclListType) {
- int result;
+ ListRep listRep;
- if (listPtr->bytes == tclEmptyStringRep) {
- *objcPtr = 0;
- *objvPtr = NULL;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr);
}
- listRepPtr = ListRepPtr(listPtr);
- *objcPtr = listRepPtr->elemCount;
- *objvPtr = &listRepPtr->elements;
+
+ if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
+ return TCL_ERROR;
+ ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
@@ -462,49 +1682,37 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * Appends the elements of elemListPtr to those of listPtr.
- *
- * Value
- *
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
+ * This function appends the elements in the list fromObj
+ * to toObj. toObj must not be shared else the function will panic.
*
- * 'listPtr' or 'elemListPtr' are not valid lists. An error
- * message is left in the interpreter's result if 'interp' is not NULL.
+ * 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.
*
- * Effect
- *
- * The reference count of each element of 'elemListPtr' as it is added to
- * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType'
- * if they are not already. Appending the new elements may cause the
- * array of element pointers in 'listObj' to grow. If any objects are
- * appended to 'listPtr'. Any preexisting string representation of
- * 'listPtr' is invalidated.
+ * 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 *listPtr, /* List object to append elements to. */
- Tcl_Obj *elemListPtr) /* List obj with elements to append. */
+ Tcl_Obj *toObj, /* List object to append elements to. */
+ Tcl_Obj *fromObj) /* List obj with elements to append. */
{
- int objc;
+ Tcl_Size objc;
Tcl_Obj **objv;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- /*
- * Pull the elements to append from elemListPtr.
- */
-
- if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
+ if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -513,7 +1721,155 @@ Tcl_ListObjAppendList(
* Delete zero existing elements.
*/
- return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
+ 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 */
+ Tcl_Size elemCount, /* Number of elements in elemObjs[] */
+ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */
+{
+ ListRep listRep;
+ Tcl_Obj **toObjv;
+ Tcl_Size toLen;
+ Tcl_Size 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.
+ */
+ Tcl_Size 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 */
+ Tcl_Size 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;
}
/*
@@ -545,146 +1901,17 @@ Tcl_ListObjAppendList(
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to append objPtr to. */
- Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
+ Tcl_Obj *toObj, /* List object to append elemObj to. */
+ Tcl_Obj *elemObj) /* Object to append to toObj's list. */
{
- List *listRepPtr, *newPtr = NULL;
- int numElems, numRequired, needGrow, isShared, attempt;
-
- if (Tcl_IsShared(listPtr)) {
- Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
- }
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- if (listPtr->bytes == tclEmptyStringRep) {
- Tcl_SetListObj(listPtr, 1, &objPtr);
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- }
-
- listRepPtr = ListRepPtr(listPtr);
- numElems = listRepPtr->elemCount;
- numRequired = numElems + 1 ;
- needGrow = (numRequired > listRepPtr->maxElemCount);
- isShared = (listRepPtr->refCount > 1);
-
- if (numRequired > LIST_MAX) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- }
- return TCL_ERROR;
- }
-
- if (needGrow && !isShared) {
- /*
- * Need to grow + unshared internalrep => try to realloc
- */
-
- attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr) {
- listRepPtr = newPtr;
- listRepPtr->maxElemCount = attempt;
- needGrow = 0;
- }
- }
- if (isShared || needGrow) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
-
- /*
- * Either we have a shared internalrep and we must copy to write, or we
- * need to grow and realloc attempts failed. Attempt internalrep copy.
- */
-
- attempt = 2 * numRequired;
- newPtr = AttemptNewList(NULL, attempt, NULL);
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = AttemptNewList(NULL, attempt, NULL);
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = AttemptNewList(interp, attempt, NULL);
- }
- if (newPtr == NULL) {
- /*
- * All growth attempts failed; throw the error.
- */
-
- return TCL_ERROR;
- }
-
- dst = &newPtr->elements;
- newPtr->refCount++;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
- newPtr->elemCount = listRepPtr->elemCount;
-
- if (isShared) {
- /*
- * The original internalrep must remain undisturbed. Copy into the new
- * one and bump refcounts
- */
- while (numElems--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
- }
- listRepPtr->refCount--;
- } else {
- /*
- * Old internalrep to be freed, re-use refCounts.
- */
-
- memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
- ckfree(listRepPtr);
- }
- listRepPtr = newPtr;
- }
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
-
- /*
- * Add objPtr to the end of listPtr's array of element pointers. Increment
- * the ref count for the (now shared) objPtr.
- */
-
- *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
- Tcl_IncrRefCount(objPtr);
- listRepPtr->elemCount++;
-
/*
- * Invalidate any old string representation since the list's internal
- * representation has changed.
+ * TODO - compare perf with 8.6 to see if worth optimizing single
+ * element case
*/
-
- TclInvalidateStringRep(listPtr);
- return TCL_OK;
+ return TclListObjAppendElements(interp, toObj, 1, &elemObj);
}
/*
@@ -716,34 +1943,30 @@ Tcl_ListObjAppendElement(
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjIndex(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to index into. */
- int index, /* Index of element to return. */
- Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object to index into. */
+ Tcl_Size index, /* Index of element to return. */
+ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
- List *listRepPtr;
+ Tcl_Obj **elemObjs;
+ Tcl_Size numElems;
- if (listPtr->typePtr != &tclListType) {
- int result;
-
- if (listPtr->bytes == tclEmptyStringRep) {
- *objPtrPtr = NULL;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ /* Empty string => empty list. Avoid unnecessary shimmering */
+ if (listObj->bytes == &tclEmptyString) {
+ *objPtrPtr = NULL;
+ return TCL_OK;
}
- listRepPtr = ListRepPtr(listPtr);
- if ((index < 0) || (index >= listRepPtr->elemCount)) {
+ if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = (&listRepPtr->elements)[index];
+ *objPtrPtr = elemObjs[index];
}
return TCL_OK;
@@ -754,47 +1977,48 @@ Tcl_ListObjIndex(
*
* Tcl_ListObjLength --
*
- * Retrieve the number of elements in a list.
- *
- * Value
- *
- * TCL_OK
- *
- * A count of list elements is stored at the address provided by
- * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is
- * converted.
+ * 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.
*
- * TCL_ERROR
+ * Results:
+ * The return value is normally TCL_OK; in this case *lenPtr 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.
*
- * 'listPtr' is not a valid list. 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 *listPtr, /* List object whose #elements to return. */
- int *intPtr) /* The resulting int is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object whose #elements to return. */
+ Tcl_Size *lenPtr) /* The resulting length is stored here. */
{
- List *listRepPtr;
+ ListRep listRep;
- if (listPtr->typePtr != &tclListType) {
- int result;
+ /* Empty string => empty list. Avoid unnecessary shimmering */
+ if (listObj->bytes == &tclEmptyString) {
+ *lenPtr = 0;
+ return TCL_OK;
+ }
- if (listPtr->bytes == tclEmptyStringRep) {
- *intPtr = 0;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ *lenPtr = TclArithSeriesObjLength(listObj);
+ return TCL_OK;
}
- listRepPtr = ListRepPtr(listPtr);
- *intPtr = listRepPtr->elemCount;
+
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
@@ -803,281 +2027,496 @@ Tcl_ListObjLength(
*
* Tcl_ListObjReplace --
*
- * Replace values in a list.
- *
- * If 'first' is zero or negative, it refers to the first element. If
- * 'first' outside the range of elements in the list, no elements are
- * deleted.
- *
- * If 'count' is zero or negative no elements are deleted, and any new
- * elements are inserted at the beginning of the list.
- *
- * Value
- *
- * TCL_OK
- *
- * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr'
- * starting at 'first'. If 'objc' 0, no new elements are added.
- *
- * TCL_ERROR
- *
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
- *
- * Effect
- *
- * If 'listPtr' is not of type 'tclListType', it is converted if possible.
- *
- * The 'refCount' of each element appended to the list is incremented.
- * Similarly, the 'refCount' for each replaced element is decremented.
- *
- * If 'listPtr' is modified, any previous string representation is
- * invalidated.
+ * 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 *listPtr, /* List object whose elements to replace. */
- int first, /* Index of first element to replace. */
- int count, /* Number of elements to replace. */
- int objc, /* Number of objects to insert. */
- Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to
- * insert. */
+ Tcl_Obj *listObj, /* List object whose elements to replace. */
+ Tcl_Size first, /* Index of first element to replace. */
+ Tcl_Size numToDelete, /* Number of elements to replace. */
+ Tcl_Size numToInsert, /* Number of objects to insert. */
+ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */
{
- List *listRepPtr;
- Tcl_Obj **elemPtrs;
- int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
-
- if (Tcl_IsShared(listPtr)) {
+ ListRep listRep;
+ Tcl_Size origListLen;
+ Tcl_Size lenChange;
+ Tcl_Size leadSegmentLen;
+ Tcl_Size tailSegmentLen;
+ Tcl_Size numFreeSlots;
+ Tcl_Size leadShift;
+ Tcl_Size tailShift;
+ Tcl_Obj **listObjs;
+ int favor;
+
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == tclEmptyStringRep) {
- if (!objc) {
- return TCL_OK;
- }
- Tcl_SetListObj(listPtr, objc, NULL);
- } else {
- int result = SetListFromAny(interp, listPtr);
-
- if (result != TCL_OK) {
- return result;
- }
- }
- }
-
- /*
- * Note that when count == 0 and objc == 0, this routine is logically a
- * no-op, removing and adding no elements to the list. However, by flowing
- * through this routine anyway, we get the important side effect that the
- * resulting listPtr is a list in canonical form. This is important.
- * Resist any temptation to optimize this case.
- */
- listRepPtr = ListRepPtr(listPtr);
- elemPtrs = &listRepPtr->elements;
- numElems = listRepPtr->elemCount;
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
+ /* Make limits sane */
+ origListLen = ListRepLength(&listRep);
if (first < 0) {
first = 0;
}
- if (first >= numElems) {
- first = numElems; /* So we'll insert after last element. */
+ if (first > origListLen) {
+ first = origListLen; /* So we'll insert after last element. */
}
- if (count < 0) {
- count = 0;
- } else if (count > LIST_MAX /* Handle integer overflow */
- || numElems < first+count) {
-
- count = numElems - first;
+ if (numToDelete < 0) {
+ numToDelete = 0;
+ } else if (first > LIST_MAX - numToDelete /* Handle integer overflow */
+ || origListLen < first + numToDelete) {
+ numToDelete = origListLen - first;
}
- if (objc > LIST_MAX - (numElems - count)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
- }
- return TCL_ERROR;
+ if (numToInsert > LIST_MAX - (origListLen - numToDelete)) {
+ return ListLimitExceededError(interp);
}
- isShared = (listRepPtr->refCount > 1);
- numRequired = numElems - count + objc; /* Known <= LIST_MAX */
- needGrow = numRequired > listRepPtr->maxElemCount;
- for (i = 0; i < objc; i++) {
- Tcl_IncrRefCount(objv[i]);
+ 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;
}
- if (needGrow && !isShared) {
- /* Try to use realloc */
- List *newPtr = NULL;
- int attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ /*
+ * 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 (newPtr) {
- listRepPtr = newPtr;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- elemPtrs = &listRepPtr->elements;
- listRepPtr->maxElemCount = attempt;
- needGrow = numRequired > listRepPtr->maxElemCount;
+ 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 */
}
- if (!needGrow && !isShared) {
- int shift;
- /*
- * Can use the current List struct. First "delete" count elements
- * starting at first.
- */
+ /* Garbage collect before checking the pure insert optimization */
+ ListRepFreeUnreferenced(&listRep);
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = elemPtrs[j];
-
- TclDecrRefCount(victimPtr);
+ /*
+ * 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);
}
/*
- * Shift the elements after the last one removed to their new
- * locations.
+ * 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) */
+ ) {
+ Tcl_Size 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;
+ }
+ }
- start = first + count;
- numAfterLast = numElems - start;
- shift = objc - count; /* numNewElems - numDeleted */
- if ((numAfterLast > 0) && (shift != 0)) {
- Tcl_Obj **src = elemPtrs + start;
+ /* Just for readability of the code */
+ lenChange = numToInsert - numToDelete;
+ leadSegmentLen = first;
+ tailSegmentLen = origListLen - (first + numToDelete);
+ numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
- memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*));
+ /*
+ * 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 (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));
}
- } else {
+ listRep.storePtr = newStorePtr;
+ numFreeSlots =
+ listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
/*
- * Cannot use the current List struct; it is shared, too small, or
- * both. Allocate a new struct and insert elements into it.
+ * 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);
+ }
- List *oldListRepPtr = listRepPtr;
- Tcl_Obj **oldPtrs = elemPtrs;
- int newMax;
-
- if (needGrow){
- newMax = 2 * numRequired;
- } else {
- newMax = listRepPtr->maxElemCount;
+ /*
+ * 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 */
+ 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);
}
-
- listRepPtr = AttemptNewList(NULL, newMax, NULL);
- if (listRepPtr == NULL) {
- unsigned int limit = LIST_MAX - numRequired;
- unsigned int extra = numRequired - numElems
- + TCL_MIN_ELEMENT_GROWTH;
- int growth = (int) ((extra > limit) ? limit : extra);
-
- listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
- if (listRepPtr == NULL) {
- listRepPtr = AttemptNewList(interp, numRequired, NULL);
- if (listRepPtr == NULL) {
- for (i = 0; i < objc; i++) {
- /* See bug 3598580 */
- objv[i]->refCount--;
- }
- return TCL_ERROR;
- }
- }
+ 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?
+ */
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- listRepPtr->refCount++;
+ /* 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);
- elemPtrs = &listRepPtr->elements;
+ LIST_ASSERT((numToDelete + numToInsert) > 0);
- if (isShared) {
- /*
- * The old struct will remain in place; need new refCounts for the
- * new List struct references. Copy over only the surviving
- * elements.
- */
+ /* Base of slot array holding the list elements */
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
- for (i=0; i < first; i++) {
- elemPtrs[i] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
- for (i = first + count, j = first + objc;
- j < numRequired; i++, j++) {
- elemPtrs[j] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[j]);
- }
+ /*
+ * 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 accommodate 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.
+ */
- oldListRepPtr->refCount--;
+ 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.
+ */
+ Tcl_Size leadSpace = ListRepNumFreeHead(&listRep);
+ Tcl_Size tailSpace = ListRepNumFreeTail(&listRep);
+ Tcl_Size 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;
/*
- * The old struct will be removed; use its inherited refCounts.
+ * 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 (first > 0) {
- memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *));
- }
-
+ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) {
+ Tcl_Size postShiftLeadSpace = leadSpace - lenChange;
+ if (postShiftLeadSpace > (finalFreeSpace/2)) {
+ Tcl_Size 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;
/*
- * "Delete" count elements starting at first.
+ * See comments above. This is analogous.
*/
-
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = oldPtrs[j];
-
- TclDecrRefCount(victimPtr);
+ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) {
+ Tcl_Size postShiftTailSpace = tailSpace - lenChange;
+ if (postShiftTailSpace > (finalFreeSpace/2)) {
+ /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */
+ Tcl_Size extraShift = postShiftTailSpace - (finalFreeSpace / 2);
+ tailShift += extraShift;
+ leadShift = extraShift; /* Move head to the back as well */
+ }
}
-
+ LIST_ASSERT(tailShift <= tailSpace);
+ } else {
/*
- * Copy the elements after the last one removed, shifted to their
- * new locations.
+ * 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);
- start = first + count;
- numAfterLast = numElems - start;
- if (numAfterLast > 0) {
- memcpy(elemPtrs + first + objc, oldPtrs + start,
- (size_t) numAfterLast * sizeof(Tcl_Obj *));
+ /*
+ * 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;
}
-
- ckfree(oldListRepPtr);
+ /*
+ * 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 */
}
}
- /*
- * Insert the new elements into elemPtrs before "first".
- */
-
- for (i=0,j=first ; i<objc ; i++,j++) {
- elemPtrs[j] = objv[i];
+ /* 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} */
+ Tcl_Size 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} */
+ Tcl_Size 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 *));
}
- /*
- * Update the count of elements.
- */
-
- listRepPtr->elemCount = numRequired;
+ listRep.storePtr->firstUsed += leadShift;
+ listRep.storePtr->numUsed = origListLen + lenChange;
+ listRep.storePtr->flags = 0;
- /*
- * Invalidate and free any old string representation since it no longer
- * reflects the list's internal representation.
- */
+ 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);
+ }
+ }
- TclInvalidateStringRep(listPtr);
+ LISTREP_CHECK(&listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1086,46 +2525,49 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * Implements the 'lindex' command when objc==3.
+ * This procedure handles the 'lindex' command when objc==3.
*
- * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures
- * the argument format into required form while taking care to manage
- * shimmering so as to tend to keep the most useful internalreps
- * and/or avoid the most expensive conversions.
+ * 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.
*
- * Value
+ * Side effects:
+ * None.
*
- * A pointer to the specified element, with its 'refCount' incremented, or
- * NULL if an error occurred.
- *
- * Notes
+ * 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 *listPtr, /* List being unpacked. */
- Tcl_Obj *argPtr) /* Index or index list. */
+ Tcl_Obj *listObj, /* List being unpacked. */
+ Tcl_Obj *argObj) /* Index or index list. */
{
-
- int index; /* Index into the list. */
+ Tcl_Size index; /* Index into the list. */
Tcl_Obj *indexListCopy;
+ Tcl_Obj **indexObjs;
+ Tcl_Size 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; see TIP#22 and TIP#33 for the details.
+ * shimmering; if internal rep is already a list do not shimmer it.
+ * see TIP#22 and TIP#33 for the details.
*/
-
- if (argPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
+ if (!TclHasInternalRep(argObj, &tclListType)
+ && TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1, &index)
+ == TCL_OK) {
/*
* argPtr designates a single index.
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
@@ -1140,112 +2582,141 @@ TclLindexList(
* implementation does not.
*/
- indexListCopy = TclListObjCopy(NULL, argPtr);
+ indexListCopy = TclListObjCopy(NULL, argObj);
if (indexListCopy == NULL) {
/*
- * argPtr designates something that is neither an index nor a
- * well-formed list. Report the error via TclLindexFlat.
+ * The argument is neither an index nor a well-formed list.
+ * Report the error via TclLindexFlat.
+ * TODO - This is as original code. why not directly return an error?
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
- }
-
- {
- int indexCount = -1; /* Size of the array of list indices. */
- Tcl_Obj **indices = NULL; /* Array of list indices. */
-
- TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
- listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
+ TclListObjGetElementsM(interp, indexListCopy, &numIndexObjs, &indexObjs);
+ listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
- return listPtr;
+ return listObj;
}
/*
*----------------------------------------------------------------------
*
- * TclLindexFlat --
+ * TclLindexFlat --
*
- * The core of the 'lindex' command, with all index
- * arguments presented as a flat list.
+ * This procedure is the core of the 'lindex' command, with all index
+ * arguments presented as a flat list.
*
- * Value
+ * 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.
*
- * A pointer to the object extracted, with its 'refCount' incremented, or
- * NULL if an error occurred. Thus, the calling code will usually do
- * something like:
- *
- * Tcl_SetObjResult(interp, result);
- * Tcl_DecrRefCount(result);
+ * 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 *listPtr, /* Tcl object representing the list. */
- int indexCount, /* Count of indices. */
+ Tcl_Obj *listObj, /* Tcl object representing the list. */
+ Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
- int i;
-
- Tcl_IncrRefCount(listPtr);
-
- for (i=0 ; i<indexCount && listPtr ; i++) {
- int 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.
- */
+ int status;
+ Tcl_Size i;
+
+ /* Handle ArithSeries as special case */
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ Tcl_Size listLen = TclArithSeriesObjLength(listObj);
+ Tcl_Size index;
+ Tcl_Obj *elemObj = NULL;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
+ &index) == TCL_OK) {
+ }
+ if (i==0) {
+ elemObj = TclArithSeriesObjIndex(NULL, listObj, index);
+ } else if (index > 0) {
+ /* ArithSeries cannot be a list of lists */
+ Tcl_DecrRefCount(elemObj);
+ TclNewObj(elemObj);
+ break;
+ }
+ }
+ Tcl_IncrRefCount(elemObj);
+ return elemObj;
+ }
- sublistCopy = TclListObjCopy(interp, listPtr);
- Tcl_DecrRefCount(listPtr);
- listPtr = NULL;
+ Tcl_IncrRefCount(listObj);
- if (sublistCopy == NULL) {
- /*
- * The sublist is not a list at all => error.
- */
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ Tcl_Size index, listLen = 0;
+ Tcl_Obj **elemPtrs = NULL;
- break;
+ status = Tcl_ListObjLength(interp, listObj, &listLen);
+ if (status != TCL_OK) {
+ Tcl_DecrRefCount(listObj);
+ return NULL;
}
- TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
- if (index<0 || index>=listLen) {
+ if (index < 0 || 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], -1, &index)
+ if (TclGetIntForIndexM(
+ interp, indexArray[i], TCL_SIZE_MAX - 1, &index)
!= TCL_OK) {
- Tcl_DecrRefCount(sublistCopy);
+ Tcl_DecrRefCount(listObj);
return NULL;
}
}
- TclNewObj(listPtr);
+ Tcl_DecrRefCount(listObj);
+ TclNewObj(listObj);
+ Tcl_IncrRefCount(listObj);
} else {
+ Tcl_Obj *itemObj;
/*
- * Extract the pointer to the appropriate element.
+ * Must set the internal rep again because it may have been
+ * changed by TclGetIntForIndexM. See test lindex-8.4.
*/
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ status = SetListFromAny(interp, listObj);
+ if (status != TCL_OK) {
+ /* The list is not a list at all => error. */
+ Tcl_DecrRefCount(listObj);
+ return NULL;
+ }
+ }
- listPtr = elemPtrs[index];
+ ListObjGetElements(listObj, listLen, elemPtrs);
+ /* increment this reference count first before decrementing
+ * just in case they are the same Tcl_Obj
+ */
+ itemObj = elemPtrs[index];
+ Tcl_IncrRefCount(itemObj);
+ Tcl_DecrRefCount(listObj);
+ /* Extract the pointer to the appropriate element. */
+ listObj = itemObj;
}
- Tcl_IncrRefCount(listPtr);
+ } else {
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
}
- Tcl_DecrRefCount(sublistCopy);
}
-
- return listPtr;
+ return listObj;
}
/*
@@ -1253,31 +2724,38 @@ TclLindexFlat(
*
* TclLsetList --
*
- * The core of [lset] when objc == 4. Objv[2] may be either a
+ * 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.
*
- * Implemented entirely as a wrapper around 'TclLindexFlat', as described
- * for 'TclLindexList'.
+ * 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.
*
- * Value
+ * Side effects:
+ * None.
*
- * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if
- * there was an error.
+ * 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 *listPtr, /* Pointer to the list being modified. */
- Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ 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'. */
{
- int indexCount = 0; /* Number of indices in the index list. */
+ Tcl_Size indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
- Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
- int index; /* Current index in the list - discarded. */
+ Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */
+ Tcl_Size index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
/*
@@ -1286,35 +2764,46 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- if (indexArgPtr->typePtr != &tclListType
- && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
- /*
- * indexArgPtr designates a single index.
- */
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
+ if (!TclHasInternalRep(indexArgObj, &tclListType)
+ && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_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 */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- indexListCopy = TclListObjCopy(NULL, indexArgPtr);
- if (indexListCopy == NULL) {
- /*
- * indexArgPtr designates something that is neither an index nor a
- * well formed list. Report the error via TclLsetFlat.
- */
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
- }
- TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
+ } else {
- /*
- * Let TclLsetFlat perform the actual lset operation.
- */
+ indexListCopy = TclListObjCopy(NULL,indexArgObj);
+ if (!indexListCopy) {
+ /*
+ * indexArgPtr designates something that is neither an index nor a
+ * well formed list. Report the error via TclLsetFlat.
+ */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
+ } else {
+ if (TCL_OK != TclListObjGetElementsM(
+ interp, indexListCopy, &indexCount, &indices)) {
+ Tcl_DecrRefCount(indexListCopy);
+ /*
+ * indexArgPtr designates something that is neither an index nor a
+ * well formed list. Report the error via TclLsetFlat.
+ */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
+ } else {
- retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);
+ /*
+ * Let TclLsetFlat perform the actual lset operation.
+ */
- Tcl_DecrRefCount(indexListCopy);
- return retValuePtr;
+ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
+ if (indexListCopy) {
+ Tcl_DecrRefCount(indexListCopy);
+ }
+ }
+ }
+ }
+ return retValueObj;
}
/*
@@ -1323,105 +2812,108 @@ TclLsetList(
* TclLsetFlat --
*
* Core engine of the 'lset' command.
- *
- * Value
- *
- * The resulting list
- *
- * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not
- * duplicated, its 'refCount' is incremented. The reference count of
- * an unduplicated object is therefore 2 (one for the returned pointer
- * and one for the variable that holds it). The reference count of a
- * duplicate object is 1, reflecting that result is the only active
- * reference. The caller is expected to store the result in the
- * variable and decrement its reference count. (INST_STORE_* does
- * exactly this.)
- *
- * NULL
- *
- * An error occurred. If 'listPtr' was duplicated, the reference
- * count on the duplicate is decremented so that it is 0, causing any
- * memory allocated by this function to be freed.
- *
- *
- * Effect
- *
- * On entry, the reference count of 'listPtr' does not reflect any
- * references held on the stack. The first action of this function is to
- * determine whether 'listPtr' is shared and to create a duplicate
- * unshared copy if it is. The reference count of the duplicate is
- * incremented. At this point, the reference count is 1 in either case so
- * that the object is considered unshared.
- *
- * The unshared list is altered directly to produce the result.
- * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string
- * representations must be spoilt by threading via 'ptr2' of the
- * two-pointer internal representation. On entry to 'TclLsetFlat', the
- * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
- * Tcl_Obj that has been modified is set to NULL.
+ * 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 *listPtr, /* Pointer to the list being modified. */
- int indexCount, /* Number of index args. */
+ Tcl_Obj *listObj, /* Pointer to the list being modified. */
+ Tcl_Size indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
+ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int index, result, len;
- Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+ Tcl_Size index, len;
+ int result;
+ Tcl_Obj *subListObj, *retValueObj;
+ Tcl_Obj *pendingInvalidates[10];
+ Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
+ Tcl_Size 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) {
- Tcl_IncrRefCount(valuePtr);
- return valuePtr;
+ 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 listPtr is actually a list; 2) We make a
+ * 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 listPtr and
+ * this routine to return NULL, will leave the string rep of listObj and
* all elements to be unchanged.
*/
- subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+ 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.
*/
- retValuePtr = subListPtr;
- chainPtr = NULL;
+ 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 **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr));
+ }
+
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
*/
do {
- int elemCount;
+ Tcl_Size elemCount;
Tcl_Obj *parentList, **elemPtrs;
/*
* Check for the possible error conditions...
*/
- if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
- != TCL_OK) {
+ if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs)
+ != TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
result = TCL_ERROR;
break;
@@ -1433,21 +2925,30 @@ TclLsetFlat(
*/
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
- != TCL_OK) {
+ != TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
- indexArray++;
+ indexArray++; /* Why bother with this increment? TBD */
break;
}
indexArray++;
- if (index < 0 || index > elemCount) {
+ if ((index == TCL_SIZE_MAX) && (elemCount == 0)) {
+ index = 0;
+ }
+ if (index < 0 || index > elemCount
+ || (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
- "BADINDEX", NULL);
+ Tcl_ObjPrintf("index \"%s\" out of range",
+ Tcl_GetString(indexArray[-1])));
+ Tcl_SetErrorCode(interp,
+ "TCL",
+ "VALUE",
+ "INDEX"
+ "OUTOFRANGE",
+ (void *)NULL);
}
result = TCL_ERROR;
break;
@@ -1455,115 +2956,129 @@ TclLsetFlat(
/*
* 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.
+ * 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 = subListPtr;
+ parentList = subListObj;
if (index == elemCount) {
- TclNewObj(subListPtr);
+ TclNewObj(subListObj);
} else {
- subListPtr = elemPtrs[index];
+ subListObj = elemPtrs[index];
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
+ 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
- * subListPtr to become shared again, so detect that case and make
- * and store another copy.
+ * 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, subListPtr);
+ Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ TclListObjSetElement(NULL, parentList, index, subListObj);
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ 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 valuePtr 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.
+ * 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.
*/
- parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
- chainPtr = parentList;
+ 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 valuePtr. In either case, we need to clean up our
- * string spoiling list of Tcl_Obj's.
+ * 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;
- while (chainPtr) {
- Tcl_Obj *objPtr = chainPtr;
+ --numPendingInvalidates;
+ objPtr = pendingInvalidatesPtr[numPendingInvalidates];
- if (result == TCL_OK) {
- /*
- * We're going to store valuePtr, so spoil string reps of all
- * containing lists.
- */
-
- TclInvalidateStringRep(objPtr);
+ 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);
+ }
}
-
- /*
- * Clear away our internalrep surgery mess.
- */
-
- chainPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr2;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
+ if (pendingInvalidatesPtr != pendingInvalidates)
+ ckfree(pendingInvalidatesPtr);
+
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
- if (retValuePtr != listPtr) {
- Tcl_DecrRefCount(retValuePtr);
+ if (retValueObj != listObj) {
+ Tcl_DecrRefCount(retValueObj);
}
return NULL;
}
/*
- * Store valuePtr in proper sublist and return. The -1 is to avoid a
+ * 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;
- TclListObjLength(NULL, subListPtr, &len);
- if (index == len) {
- Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
+ 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 {
- TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ /* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
+ TclListObjSetElement(NULL, subListObj, index, valueObj);
+ TclInvalidateStringRep(subListObj);
}
- TclInvalidateStringRep(subListPtr);
- Tcl_IncrRefCount(retValuePtr);
- return retValuePtr;
+ Tcl_IncrRefCount(retValueObj);
+ return retValueObj;
}
/*
@@ -1571,146 +3086,91 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value.
- *
- * It is the caller's responsibility to invalidate the string
- * representation of the 'listPtr'.
- *
- * Value
- *
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' does not refer to a list object and cannot be converted
- * to one. An error message will be left in the interpreter result if
- * interp is not NULL.
- *
- * TCL_ERROR
- *
- * An index designates an element outside the range [0..listLength-1],
- * where 'listLength' is the count of elements in the list object
- * designated by 'listPtr'. An error message is left in the
- * interpreter result.
- *
- * Effect
+ * Set a single element of a list to a specified value
*
- * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If
- * 'listPtr' is not already of type 'tclListType', it is converted and the
- * internal representation is unshared. The 'refCount' of the element at
- * 'index' is decremented and replaced in the list with the 'valuePtr',
- * whose 'refCount' in turn is incremented.
+ * 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 *listPtr, /* List object in which element should be
+ Tcl_Obj *listObj, /* List object in which element should be
* stored. */
- int index, /* Index of element to store. */
- Tcl_Obj *valuePtr) /* Tcl object to store in the designated list
+ Tcl_Size index, /* Index of element to store. */
+ Tcl_Obj *valueObj) /* Tcl object to store in the designated list
* element. */
{
- List *listRepPtr; /* Internal representation of the list being
- * modified. */
- Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
- int elemCount; /* Number of elements in the list. */
+ ListRep listRep;
+ Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
+ Tcl_Size elemCount; /* Number of elements in the list. */
- /*
- * Ensure that the listPtr parameter designates an unshared list.
- */
+ /* Ensure that the listObj parameter designates an unshared list. */
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- if (listPtr->typePtr != &tclListType) {
- int result;
- if (listPtr->bytes == tclEmptyStringRep) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
- "BADINDEX", NULL);
- }
- return TCL_ERROR;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
}
- listRepPtr = ListRepPtr(listPtr);
- elemCount = listRepPtr->elemCount;
-
- /*
- * Ensure that the index is in bounds.
- */
+ elemCount = ListRepLength(&listRep);
+ /* Ensure that the index is in bounds. */
if (index<0 || index>=elemCount) {
if (interp != NULL) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("list index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
- NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "index \"%" TCL_SIZE_MODIFIER "u\" out of range", index));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
+ "OUTOFRANGE", (void *)NULL);
}
return TCL_ERROR;
}
/*
- * If the internal rep is shared, replace it with an unshared copy.
+ * 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);
- if (listRepPtr->refCount > 1) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
- List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);
-
- if (newPtr == NULL) {
- newPtr = AttemptNewList(interp, elemCount, NULL);
- if (newPtr == NULL) {
- return TCL_ERROR;
- }
- }
- newPtr->refCount++;
- newPtr->elemCount = elemCount;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
-
- dst = &newPtr->elements;
- while (elemCount--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
- }
-
- listRepPtr->refCount--;
+ /* 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} */
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;
- }
- elemPtrs = &listRepPtr->elements;
+ /* Retrieve element array AFTER potential cloning above */
+ ListRepElements(&listRep, elemCount, elemPtrs);
/*
- * Add a reference to the new list element.
+ * Add a reference to the new list element and remove from old before
+ * replacing it. Order is important!
*/
-
- Tcl_IncrRefCount(valuePtr);
-
- /*
- * Remove a reference from the old list element.
- */
-
+ Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
+ elemPtrs[index] = valueObj;
- /*
- * Stash the new object in the list.
- */
-
- elemPtrs[index] = valuePtr;
+ /* Internal rep may be cloned so replace */
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1720,35 +3180,34 @@ TclListObjSetElement(
*
* FreeListInternalRep --
*
- * Deallocate the storage associated with the internal representation of a
- * a list object.
+ * Deallocate the storage associated with a list object's internal
+ * representation.
*
- * Effect
+ * Results:
+ * None.
*
- * The storage for the internal 'List' pointer of 'listPtr' is freed, the
- * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount'
- * of each element of the list is decremented.
+ * 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 *listPtr) /* List object with internal rep to free. */
+ Tcl_Obj *listObj) /* List object with internal rep to free. */
{
- List *listRepPtr = ListRepPtr(listPtr);
-
- if (listRepPtr->refCount-- <= 1) {
- Tcl_Obj **elemPtrs = &listRepPtr->elements;
- int i, numElems = listRepPtr->elemCount;
-
- for (i = 0; i < numElems; i++) {
- Tcl_DecrRefCount(elemPtrs[i]);
- }
- ckfree(listRepPtr);
+ ListRep listRep;
+
+ ListObjGetRep(listObj, &listRep);
+ if (listRep.storePtr->refCount-- <= 1) {
+ ObjArrayDecrRefs(
+ listRep.storePtr->slots,
+ listRep.storePtr->firstUsed, listRep.storePtr->numUsed);
+ ckfree(listRep.storePtr);
+ }
+ if (listRep.spanPtr) {
+ ListSpanDecrRefs(listRep.spanPtr);
}
-
- listPtr->typePtr = NULL;
}
/*
@@ -1756,24 +3215,25 @@ FreeListInternalRep(
*
* DupListInternalRep --
*
- * Initialize the internal representation of a list 'Tcl_Obj' to share the
+ * Initialize the internal representation of a list Tcl_Obj to share the
* internal representation of an existing list object.
*
- * Effect
+ * Results:
+ * None.
*
- * The 'refCount' of the List internal rep is incremented.
+ * Side effects:
+ * The reference count of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
-
static void
DupListInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ Tcl_Obj *srcObj, /* Object with internal rep to copy. */
+ Tcl_Obj *copyObj) /* Object with internal rep to set. */
{
- List *listRepPtr = ListRepPtr(srcPtr);
-
- ListSetInternalRep(copyPtr, listRepPtr);
+ ListRep listRep;
+ ListObjGetRep(srcObj, &listRep);
+ ListObjOverwriteRep(copyObj, &listRep);
}
/*
@@ -1781,31 +3241,26 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Convert any object to a list.
- *
- * Value
- *
- * TCL_OK
- *
- * Success. The internal representation of 'objPtr' is set, and the type
- * of 'objPtr' is 'tclListType'.
+ * Attempt to generate a list internal form for the Tcl object "objPtr".
*
- * TCL_ERROR
- *
- * An error occured during conversion. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * 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. */
{
- List *listRepPtr;
Tcl_Obj **elemPtrs;
+ ListRep listRep;
/*
* Dictionaries are a special case; they have a string representation such
@@ -1815,10 +3270,11 @@ SetListFromAny(
* describe duplicate keys).
*/
- if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
+ if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
- int done, size;
+ int done;
+ Tcl_Size size;
/*
* Create the new list representation. Note that we do not need to do
@@ -1830,17 +3286,22 @@ SetListFromAny(
*/
Tcl_DictObjSize(NULL, objPtr, &size);
- listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
- if (!listRepPtr) {
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? 2 * size : 1, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- listRepPtr->elemCount = 2 * size;
- /*
- * Populate the list representation.
- */
+ 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;
- elemPtrs = &listRepPtr->elements;
+ /* Populate the list representation. */
+
+ elemPtrs = listRep.storePtr->slots;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
@@ -1849,8 +3310,37 @@ SetListFromAny(
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
+ } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ /*
+ * Convertion from Arithmetic Series is a special case
+ * because it can be done an order of magnitude faster
+ * and may occur frequently.
+ */
+ Tcl_Size j, size = TclArithSeriesObjLength(objPtr);
+
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? 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 = size;
+ elemPtrs = listRep.storePtr->slots;
+ for (j = 0; j < size; j++) {
+ elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j);
+ if (elemPtrs[j] == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(elemPtrs[j]);
+ }
+
} else {
- int estCount, length;
+ Tcl_Size estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
@@ -1861,56 +3351,77 @@ SetListFromAny(
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
- listRepPtr = AttemptNewList(interp, estCount, NULL);
- if (listRepPtr == NULL) {
+ /* TODO - allocate additional space? */
+ if (ListRepInitAttempt(interp, estCount, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- elemPtrs = &listRepPtr->elements;
- /*
- * Each iteration, parse and store a list element.
- */
+ 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;
- int elemSize, literal;
+ char *check;
+ Tcl_Size elemSize;
+ int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
- while (--elemPtrs >= &listRepPtr->elements) {
+fail:
+ while (--elemPtrs >= listRep.storePtr->slots) {
Tcl_DecrRefCount(*elemPtrs);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRep.storePtr);
return TCL_ERROR;
}
if (elemStart == limit) {
break;
}
- /* TODO: replace panic with error on alloc failure? */
- if (literal) {
- TclNewStringObj(*elemPtrs, elemStart, elemSize);
- } else {
- TclNewObj(*elemPtrs);
- (*elemPtrs)->bytes = (char *)ckalloc((unsigned) elemSize + 1);
- (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart,
- (*elemPtrs)->bytes);
+ 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. */
}
- listRepPtr->elemCount = elemPtrs - &listRepPtr->elements;
+ listRep.storePtr->numUsed =
+ elemPtrs - listRep.storePtr->slots;
}
+ LISTREP_CHECK(&listRep);
+
/*
- * Free the old internalRep before setting the new one. We do this as late
+ * Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
- * Tcl_GetStringFromObj, to use that old internalRep.
+ * 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;
- TclFreeIntRep(objPtr);
- ListSetInternalRep(objPtr, listRepPtr);
return TCL_OK;
}
@@ -1932,53 +3443,62 @@ SetListFromAny(
*
*----------------------------------------------------------------------
*/
-
static void
UpdateStringOfList(
- Tcl_Obj *listPtr) /* List object with string rep to update. */
+ Tcl_Obj *listObj) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- List *listRepPtr = ListRepPtr(listPtr);
- int numElems = listRepPtr->elemCount;
- int i, length;
- unsigned int bytesNeeded = 0;
- const char *elem;
+ Tcl_Size numElems, i, length;
+ TCL_HASH_TYPE 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
+ *
+ * (a) the store is not shared as a shared store may be referenced by
+ * multiple lists with different string reps. (see [a366c6efee]), AND
+ *
+ * (b) list does not have a span. Consider a list generated from a
+ * string and then this function called for a spanned list generated
+ * from the original list. We cannot mark the list store as canonical as
+ * that would also make the originating list canonical, which it may not
+ * be. On the other hand, the spanned list itself 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.storePtr->refCount < 2 && listRep.spanPtr == NULL) {
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */
+ listRep.storePtr->flags |= LISTSTORE_CANONICAL;
+ }
- listRepPtr->canonicalFlag = 1;
-
- /*
- * Handle empty list case first, so rest of the routine is simpler.
- */
+ /* Handle empty list case first, so rest of the routine is simpler. */
if (numElems == 0) {
- listPtr->bytes = tclEmptyStringRep;
- listPtr->length = 0;
+ Tcl_InitStringRep(listObj, NULL, 0);
return;
}
- /*
- * Pass 1: estimate space, gather flags.
- */
+ /* Pass 1: estimate space, gather flags. */
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- /*
- * We know numElems <= LIST_MAX, so this is safe.
- */
-
+ /* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)ckalloc(numElems);
}
- elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
@@ -1990,46 +3510,82 @@ UpdateStringOfList(
if (bytesNeeded + numElems > INT_MAX + 1U) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
- bytesNeeded += numElems;
+ bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
- /*
- * We used to set the string length here, relying on a presumed
- * guarantee that the number of bytes TclScanElement() calls reported
- * to be needed was a precise count and not an over-estimate, so long
- * as the same flag values were passed to TclConvertElement().
- *
- * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused
- * that guarantee to fail. Rather than trust there are no more bugs,
- * we set the length after the loop based on what was actually written,
- * an not on what was predicted.
- *
- listPtr->length = bytesNeeded - 1;
- *
- */
-
- listPtr->bytes = (char *)ckalloc(bytesNeeded);
- dst = listPtr->bytes;
+ 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 = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
- dst[-1] = '\0';
- /* Here is the safe setting of the string length. */
- listPtr->length = dst - 1 - listPtr->bytes;
+ /* Set the string length to what was actually written, the safe choice */
+ (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(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(size_t length, size_t leadingSpace, size_t endSpace)
+{
+ ListRep listRep;
+ size_t capacity;
+ Tcl_Obj *listObj;
+
+ TclNewObj(listObj);
+
+ /* Only a test object so ignoring overflow checks */
+ capacity = length + leadingSpace + endSpace;
+ if (capacity == 0) {
+ return listObj;
+ }
+ if (capacity > LIST_MAX) {
+ return NULL;
+ }
+
+ ListRepInit(capacity, NULL, 0, &listRep);
+
+ ListStore *storePtr = listRep.storePtr;
+ size_t i;
+ for (i = 0; i < length; ++i) {
+ TclNewUIntObj(storePtr->slots[i + leadingSpace], 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
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 0c1c2fa..3966901 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -7,8 +7,8 @@
* general hashtable implementation of Tcl hash tables that appears in
* tclHash.c.
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 2004 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -104,7 +104,7 @@ TclDeleteLiteralTable(
{
LiteralEntry *entryPtr, *nextPtr;
Tcl_Obj *objPtr;
- int i;
+ size_t i;
/*
* Release remaining literals in the table. Note that releasing a literal
@@ -114,6 +114,8 @@ TclDeleteLiteralTable(
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
+#else
+ (void)interp;
#endif /*TCL_COMPILE_DEBUG*/
/*
@@ -174,7 +176,7 @@ TclDeleteLiteralTable(
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
- char *bytes, /* The start of the string. Note that this is
+ const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
int length, /* Number of bytes in the string. */
unsigned hash, /* The string's hash. If -1, it will be
@@ -186,7 +188,7 @@ TclCreateLiteral(
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
- int globalHash;
+ unsigned int globalHash;
Tcl_Obj *objPtr;
/*
@@ -209,7 +211,7 @@ TclCreateLiteral(
*/
int objLength;
- char *objBytes = TclGetStringFromObj(objPtr, &objLength);
+ const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
@@ -227,7 +229,9 @@ TclCreateLiteral(
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
- globalPtr->refCount++;
+ if (globalPtr->refCount != TCL_INDEX_NONE) {
+ globalPtr->refCount++;
+ }
return objPtr;
}
}
@@ -240,20 +244,22 @@ TclCreateLiteral(
}
/*
- * The literal is new to the interpreter. Add it to the global literal
- * table.
+ * The literal is new to the interpreter.
*/
TclNewObj(objPtr);
if ((flags & LITERAL_ON_HEAP)) {
- objPtr->bytes = bytes;
+ objPtr->bytes = (char *) bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+ /* Should the new literal be shared globally? */
+
if ((flags & LITERAL_UNSHARED)) {
/*
+ * No, do *not* add it the global literal table
* Make clear, that no global value is returned
*/
if (globalPtrPtr != NULL) {
@@ -262,6 +268,9 @@ TclCreateLiteral(
return objPtr;
}
+ /*
+ * Yes, add it to the global literal table.
+ */
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -291,7 +300,8 @@ TclCreateLiteral(
TclVerifyGlobalLiteralTable(iPtr);
{
LiteralEntry *entryPtr;
- int found, i;
+ int found;
+ size_t i;
found = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
@@ -381,7 +391,7 @@ int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
- char *bytes, /* Points to string for which to find or
+ const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length, /* Number of bytes in the string. If < 0, the
@@ -393,13 +403,14 @@ TclRegisterLiteral(
* the literal should not be shared across
* namespaces. */
{
- CompileEnv *envPtr = ePtr;
+ CompileEnv *envPtr = (CompileEnv *)ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
unsigned hash;
- int localHash, objIndex, new;
+ unsigned int localHash;
+ int objIndex, isNew;
Namespace *nsPtr;
if (length < 0) {
@@ -453,12 +464,12 @@ TclRegisterLiteral(
*/
globalPtr = NULL;
- objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
+ objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr != NULL && globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount + 1 < 2) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -543,7 +554,8 @@ TclHideLiteral(
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
- int localHash, length;
+ unsigned int localHash;
+ int length;
const char *bytes;
Tcl_Obj *newObjPtr;
@@ -562,7 +574,7 @@ TclHideLiteral(
lPtr->objPtr = newObjPtr;
bytes = TclGetStringFromObj(newObjPtr, &length);
- localHash = (HashString(bytes, length) & localTablePtr->mask);
+ localHash = HashString(bytes, length) & localTablePtr->mask;
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
@@ -618,7 +630,7 @@ TclAddLiteralObj(
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
- lPtr->refCount = -1; /* i.e., unused */
+ lPtr->refCount = TCL_INDEX_NONE; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
@@ -680,7 +692,8 @@ AddLocalLiteralEntry(
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
- int length, found, i;
+ int length, found;
+ size_t i;
found = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
@@ -693,7 +706,7 @@ AddLocalLiteralEntry(
}
if (!found) {
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : length), bytes);
}
@@ -734,15 +747,15 @@ ExpandLocalLiteralArray(
*/
LiteralTable *localTablePtr = &envPtr->localLitTable;
- int currElems = envPtr->literalArrayNext;
+ size_t currElems = envPtr->literalArrayNext;
size_t currBytes = (currElems * sizeof(LiteralEntry));
LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
LiteralEntry *newArrayPtr;
- int i;
- unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX;
+ size_t i;
+ size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX;
if (currBytes == newSize) {
- Tcl_Panic("max size of Tcl literal array (%d literals) exceeded",
+ Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
@@ -815,7 +828,8 @@ TclReleaseLiteral(
LiteralTable *globalTablePtr;
LiteralEntry *entryPtr, *prevPtr;
const char *bytes;
- int length, index;
+ int length;
+ unsigned int index;
if (iPtr == NULL) {
goto done;
@@ -834,15 +848,13 @@ TclReleaseLiteral(
for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
- entryPtr->refCount--;
-
/*
* If the literal is no longer being used by any ByteCode, delete
* the entry then remove the reference corresponding to the global
* literal table entry (decrement the ref count of the object).
*/
- if (entryPtr->refCount == 0) {
+ if ((entryPtr->refCount != TCL_INDEX_NONE) && (entryPtr->refCount-- <= 1)) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
@@ -960,8 +972,8 @@ RebuildLiteralTable(
LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
const char *bytes;
- unsigned int oldSize;
- int count, index, length;
+ unsigned int oldSize, index;
+ int count, length;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
@@ -983,7 +995,7 @@ RebuildLiteralTable(
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **)ckalloc(
- tablePtr->numBuckets * sizeof(LiteralEntry *));
+ tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
@@ -1033,7 +1045,7 @@ RebuildLiteralTable(
*
* Side effects:
* Resets the internal representation of the CmdName Tcl_Obj
- * using TclFreeIntRep().
+ * using TclFreeInternalRep().
*
*----------------------------------------------------------------------
*/
@@ -1048,12 +1060,12 @@ TclInvalidateCmdLiteral(
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
+ Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL) {
- if (literalObjPtr->typePtr == &tclCmdNameType) {
- TclFreeIntRep(literalObjPtr);
+ if (TclHasInternalRep(literalObjPtr, &tclCmdNameType)) {
+ TclFreeInternalRep(literalObjPtr);
}
/* Balance the refcount effects of TclCreateLiteral() above */
Tcl_IncrRefCount(literalObjPtr);
@@ -1085,7 +1097,9 @@ TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
- int count[NUM_COUNTERS], overflow, i, j;
+ size_t count[NUM_COUNTERS];
+ int overflow;
+ size_t i, j;
double average, tmp;
LiteralEntry *entryPtr;
char *result, *p;
@@ -1124,7 +1138,7 @@ TclLiteralStats(
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i=0 ; i<NUM_COUNTERS ; i++) {
- snprintf(p, 60, "number of buckets with %d entries: %d\n",
+ snprintf(p, 60, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
}
@@ -1161,17 +1175,17 @@ TclVerifyLocalLiteralTable(
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
char *bytes;
- int i;
- int length, count;
+ size_t i, count;
+ int length;
count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
- if (localPtr->refCount != -1) {
- bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d",
+ if (localPtr->refCount != TCL_INDEX_NONE) {
+ bytes = TclGetStringFromObj(localPtr->objPtr, &length);
+ Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
@@ -1182,7 +1196,7 @@ TclVerifyLocalLiteralTable(
}
}
if (count != localTablePtr->numEntries) {
- Tcl_Panic("%s: local literal table had %d entries, should be %d",
+ Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyLocalLiteralTable", count,
localTablePtr->numEntries);
}
@@ -1212,16 +1226,16 @@ TclVerifyGlobalLiteralTable(
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
char *bytes;
- int i;
- int length, count;
+ size_t i, count;
+ int length;
count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
- if (globalPtr->refCount < 1) {
- bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
+ if (globalPtr->refCount + 1 < 2) {
+ bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : length), bytes, globalPtr->refCount);
@@ -1233,7 +1247,7 @@ TclVerifyGlobalLiteralTable(
}
}
if (count != globalTablePtr->numEntries) {
- Tcl_Panic("%s: global literal table had %d entries, should be %d",
+ Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyGlobalLiteralTable", count,
globalTablePtr->numEntries);
}
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index dbacead..05883ba 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -4,7 +4,7 @@
* This file provides the generic portion (those that are the same on all
* platforms) of Tcl's dynamic loading facilities.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -12,20 +12,21 @@
#include "tclInt.h"
+
/*
- * The following structure describes a package that has been loaded either
+ * The following structure describes a library that has been loaded either
* dynamically (with the "load" command) or statically (as indicated by a call
- * to TclGetLoadedPackages). All such packages are linked together into a
- * single list for the process. Packages are never unloaded, until the
+ * to Tcl_StaticLibrary). All such libraries are linked together into a
+ * single list for the process. Library are never unloaded, until the
* application exits, when TclFinalizeLoad is called, and these structures are
* freed.
*/
-typedef struct LoadedPackage {
- char *fileName; /* Name of the file from which the package was
- * loaded. An empty string means the package
+typedef struct LoadedLibrary {
+ char *fileName; /* Name of the file from which the library was
+ * loaded. An empty string means the library
* is loaded statically. Malloc-ed. */
- char *packageName; /* Name of package prefix for the package,
+ char *prefix; /* Prefix for the library,
* properly capitalized (first letter UC,
* others LC), as in "Net".
* Malloc-ed. */
@@ -33,68 +34,80 @@ typedef struct LoadedPackage {
* passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
- Tcl_PackageInitProc *initProc;
+ Tcl_LibraryInitProc *initProc;
/* Initialization function to call to
- * incorporate this package into a trusted
+ * incorporate this library into a trusted
* interpreter. */
- Tcl_PackageInitProc *safeInitProc;
+ Tcl_LibraryInitProc *safeInitProc;
/* Initialization function to call to
- * incorporate this package into a safe
+ * incorporate this library into a safe
* interpreter (one that will execute
- * untrusted scripts). NULL means the package
+ * untrusted scripts). NULL means the library
* can't be used in unsafe interpreters. */
- Tcl_PackageUnloadProc *unloadProc;
- /* Finalisation function to unload a package
+ Tcl_LibraryUnloadProc *unloadProc;
+ /* Finalization function to unload a library
* from a trusted interpreter. NULL means that
- * the package cannot be unloaded. */
- Tcl_PackageUnloadProc *safeUnloadProc;
- /* Finalisation function to unload a package
+ * the library cannot be unloaded. */
+ Tcl_LibraryUnloadProc *safeUnloadProc;
+ /* Finalization function to unload a library
* from a safe interpreter. NULL means that
- * the package cannot be unloaded. */
- int interpRefCount; /* How many times the package has been loaded
+ * the library cannot be unloaded. */
+ int interpRefCount; /* How many times the library has been loaded
* in trusted interpreters. */
- int safeInterpRefCount; /* How many times the package has been loaded
+ int safeInterpRefCount; /* How many times the library has been loaded
* in safe interpreters. */
- struct LoadedPackage *nextPtr;
- /* Next in list of all packages loaded into
+ struct LoadedLibrary *nextPtr;
+ /* Next in list of all libraries loaded into
* this application process. NULL means end of
* list. */
-} LoadedPackage;
+} LoadedLibrary;
/*
* TCL_THREADS
- * There is a global list of packages that is anchored at firstPackagePtr.
+ * There is a global list of libraries that is anchored at firstLibraryPtr.
* Access to this list is governed by a mutex.
*/
-static LoadedPackage *firstPackagePtr = NULL;
- /* First in list of all packages loaded into
+static LoadedLibrary *firstLibraryPtr = NULL;
+ /* First in list of all libraries loaded into
* this process. */
-TCL_DECLARE_MUTEX(packageMutex)
+TCL_DECLARE_MUTEX(libraryMutex)
/*
- * The following structure represents a particular package that has been
+ * The following structure represents a particular library that has been
* incorporated into a particular interpreter (by calling its initialization
* function). There is a list of these structures for each interpreter, with
* an AssocData value (key "load") for the interpreter that points to the
- * first package (if any).
+ * first library (if any).
*/
-typedef struct InterpPackage {
- LoadedPackage *pkgPtr; /* Points to detailed information about
- * package. */
- struct InterpPackage *nextPtr;
- /* Next package in this interpreter, or NULL
+typedef struct InterpLibrary {
+ LoadedLibrary *libraryPtr; /* Points to detailed information about
+ * library. */
+ struct InterpLibrary *nextPtr;
+ /* Next library in this interpreter, or NULL
* for end of list. */
-} InterpPackage;
+} InterpLibrary;
/*
* Prototypes for functions that are private to this file:
*/
-static void LoadCleanupProc(ClientData clientData,
- Tcl_Interp *interp);
+static void LoadCleanupProc(ClientData clientData,
+ Tcl_Interp *interp);
+static int IsStatic (LoadedLibrary *libraryPtr);
+static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
+ LoadedLibrary *library, int keepLibrary,
+ const char *fullFileName, int interpExiting);
+
+
+static int
+IsStatic (LoadedLibrary *libraryPtr) {
+ int res;
+ res = (libraryPtr->fileName[0] == '\0');
+ return res;
+}
/*
*----------------------------------------------------------------------
@@ -115,20 +128,20 @@ static void LoadCleanupProc(ClientData clientData,
int
Tcl_LoadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
- LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString prefix, tmp, initName, safeInitName;
+ LoadedLibrary *libraryPtr, *defaultPtr;
+ Tcl_DString pfx, tmp, initName, safeInitName;
Tcl_DString unloadName, safeUnloadName;
- InterpPackage *ipFirstPtr, *ipPtr;
+ InterpLibrary *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
- Tcl_PackageInitProc *initProc;
- const char *p, *fullFileName, *packageName;
+ Tcl_LibraryInitProc *initProc;
+ const char *p, *fullFileName, *prefix;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
unsigned len;
@@ -137,7 +150,7 @@ Tcl_LoadObjCmd(
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
- enum options {
+ enum loadOptionsEnum {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
};
@@ -150,16 +163,16 @@ Tcl_LoadObjCmd(
return TCL_ERROR;
}
++objv; --objc;
- if (LOAD_GLOBAL == (enum options) index) {
+ if (LOAD_GLOBAL == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_GLOBAL;
- } else if (LOAD_LAZY == (enum options) index) {
+ } else if (LOAD_LAZY == (enum loadOptionsEnum) index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
}
if ((objc < 2) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
+ Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
@@ -167,31 +180,31 @@ Tcl_LoadObjCmd(
}
fullFileName = Tcl_GetString(objv[1]);
- Tcl_DStringInit(&prefix);
+ Tcl_DStringInit(&pfx);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
Tcl_DStringInit(&unloadName);
Tcl_DStringInit(&safeUnloadName);
Tcl_DStringInit(&tmp);
- packageName = NULL;
+ prefix = NULL;
if (objc >= 3) {
- packageName = Tcl_GetString(objv[2]);
- if (packageName[0] == '\0') {
- packageName = NULL;
+ prefix = Tcl_GetString(objv[2]);
+ if (prefix[0] == '\0') {
+ prefix = NULL;
}
}
- if ((fullFileName[0] == 0) && (packageName == NULL)) {
+ if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "must specify either file name or package name", -1));
+ "must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
/*
- * Figure out which interpreter we're going to load the package into.
+ * Figure out which interpreter we're going to load the library into.
*/
target = interp;
@@ -206,226 +219,229 @@ Tcl_LoadObjCmd(
}
/*
- * Scan through the packages that are currently loaded to see if the
- * package we want is already loaded. We'll use a loaded package if it
+ * Scan through the libraries that are currently loaded to see if the
+ * library we want is already loaded. We'll use a loaded library if it
* meets any of the following conditions:
* - Its name and file match the once we're looking for.
* - Its file matches, and we weren't given a name.
* - Its name matches, the file name was specified as empty, and there is
- * only no statically loaded package with the same name.
+ * only no statically loaded library with the same prefix.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
defaultPtr = NULL;
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
- if (packageName == NULL) {
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
+ if (prefix == NULL) {
namesMatch = 0;
} else {
- TclDStringClear(&prefix);
- Tcl_DStringAppend(&prefix, packageName, -1);
+ TclDStringClear(&pfx);
+ Tcl_DStringAppend(&pfx, prefix, -1);
TclDStringClear(&tmp);
- Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
- Tcl_UtfToLower(Tcl_DStringValue(&prefix));
+ Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pfx));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
- Tcl_DStringValue(&prefix)) == 0) {
+ Tcl_DStringValue(&pfx)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
- TclDStringClear(&prefix);
+ TclDStringClear(&pfx);
- filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
- if (filesMatch && (namesMatch || (packageName == NULL))) {
+ filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
+ if (filesMatch && (namesMatch || (prefix == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
- defaultPtr = pkgPtr;
+ defaultPtr = libraryPtr;
}
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
/*
- * Can't have two different packages loaded from the same file.
+ * Can't have two different libraries loaded from the same file.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" is already loaded for package \"%s\"",
- fullFileName, pkgPtr->packageName));
+ "file \"%s\" is already loaded for prefix \"%s\"",
+ fullFileName, libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
- "SPLITPERSONALITY", NULL);
+ "SPLITPERSONALITY", (void *)NULL);
code = TCL_ERROR;
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
goto done;
}
}
- Tcl_MutexUnlock(&packageMutex);
- if (pkgPtr == NULL) {
- pkgPtr = defaultPtr;
+ Tcl_MutexUnlock(&libraryMutex);
+ if (libraryPtr == NULL) {
+ libraryPtr = defaultPtr;
}
/*
- * Scan through the list of packages already loaded in the target
- * interpreter. If the package we want is already loaded there, then
+ * Scan through the list of libraries already loaded in the target
+ * interpreter. If the library we want is already loaded there, then
* there's nothing for us to do.
*/
- if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ if (libraryPtr != NULL) {
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
code = TCL_OK;
goto done;
}
}
}
- if (pkgPtr == NULL) {
+ if (libraryPtr == NULL) {
/*
* The desired file isn't currently loaded, so load it. It's an error
- * if the desired package is a static one.
+ * if the desired library is a static one.
*/
if (fullFileName[0] == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "package \"%s\" isn't loaded statically", packageName));
+ "no library with prefix \"%s\" is loaded statically", prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
/*
- * Figure out the module name if it wasn't provided explicitly.
+ * Figure out the prefix if it wasn't provided explicitly.
*/
- if (packageName != NULL) {
- Tcl_DStringAppend(&prefix, packageName, -1);
+ if (prefix != NULL) {
+ Tcl_DStringAppend(&pfx, prefix, -1);
} else {
- int retc;
+ Tcl_Obj *splitPtr, *pkgGuessPtr;
+ int pElements;
+ const char *pkgGuess;
/*
* Threading note - this call used to be protected by a mutex.
*/
- retc = TclGuessPackageName(fullFileName, &prefix);
- if (!retc) {
- Tcl_Obj *splitPtr, *pkgGuessPtr;
- int pElements;
- const char *pkgGuess;
-
- /*
- * The platform-specific code couldn't figure out the module
- * name. Make a guess by taking the last element of the file
- * name, stripping off any leading "lib", and then using all
- * of the alphabetic and underline characters that follow
- * that.
- */
+ /*
+ * The platform-specific code couldn't figure out the prefix.
+ * Make a guess by taking the last element of the file
+ * name, stripping off any leading "lib" and/or "tcl", and
+ * then using all of the alphabetic and underline characters
+ * that follow that.
+ */
- splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
- Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
- pkgGuess = Tcl_GetString(pkgGuessPtr);
- if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
- && (pkgGuess[2] == 'b')) {
- pkgGuess += 3;
- }
+ splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
+ Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
+ pkgGuess = Tcl_GetString(pkgGuessPtr);
+ if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
+ && (pkgGuess[2] == 'b')) {
+ pkgGuess += 3;
+ }
#ifdef __CYGWIN__
- if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
- && (pkgGuess[2] == 'g')) {
- pkgGuess += 3;
- }
+ else if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
+ && (pkgGuess[2] == 'g')) {
+ pkgGuess += 3;
+ }
#endif /* __CYGWIN__ */
- for (p = pkgGuess; *p != 0; p += offset) {
- offset = TclUtfToUniChar(p, &ch);
- if ((ch > 0x100)
- || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
- || (UCHAR(ch) == '_'))) {
- break;
- }
- }
- if (p == pkgGuess) {
- Tcl_DecrRefCount(splitPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't figure out package name for %s",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
- "WHATPACKAGE", NULL);
- code = TCL_ERROR;
- goto done;
+ if (((pkgGuess[0] == 't')
+#ifdef MAC_OSX_TCL
+ || (pkgGuess[0] == 'T')
+#endif
+ ) && (pkgGuess[1] == 'c')
+ && (pkgGuess[2] == 'l')) {
+ pkgGuess += 3;
+ }
+ for (p = pkgGuess; *p != 0; p += offset) {
+ offset = TclUtfToUniChar(p, &ch);
+ if ((ch > 0x100)
+ || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
+ || (UCHAR(ch) == '_'))) {
+ break;
}
- Tcl_DStringAppend(&prefix, pkgGuess, p - pkgGuess);
+ }
+ if (p == pkgGuess) {
Tcl_DecrRefCount(splitPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't figure out prefix for %s",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+ "WHATLIBRARY", (void *)NULL);
+ code = TCL_ERROR;
+ goto done;
}
+ Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess);
+ Tcl_DecrRefCount(splitPtr);
}
/*
- * Fix the capitalization in the package name so that the first
+ * Fix the capitalization in the prefix so that the first
* character is in caps (or title case) but the others are all
* lower-case.
*/
- Tcl_DStringSetLength(&prefix,
- Tcl_UtfToTitle(Tcl_DStringValue(&prefix)));
+ Tcl_DStringSetLength(&pfx,
+ Tcl_UtfToTitle(Tcl_DStringValue(&pfx)));
/*
* Compute the names of the two initialization functions, based on the
- * package name.
+ * prefix.
*/
- TclDStringAppendDString(&initName, &prefix);
+ TclDStringAppendDString(&initName, &pfx);
TclDStringAppendLiteral(&initName, "_Init");
- TclDStringAppendDString(&safeInitName, &prefix);
+ TclDStringAppendDString(&safeInitName, &pfx);
TclDStringAppendLiteral(&safeInitName, "_SafeInit");
- TclDStringAppendDString(&unloadName, &prefix);
+ TclDStringAppendDString(&unloadName, &pfx);
TclDStringAppendLiteral(&unloadName, "_Unload");
- TclDStringAppendDString(&safeUnloadName, &prefix);
+ TclDStringAppendDString(&safeUnloadName, &pfx);
TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload");
/*
- * Call platform-specific code to load the package and find the two
+ * Call platform-specific code to load the library and find the two
* initialization functions.
*/
symbols[0] = Tcl_DStringValue(&initName);
symbols[1] = NULL;
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc,
&loadHandle);
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
if (code != TCL_OK) {
goto done;
}
/*
- * Create a new record to describe this package.
+ * Create a new record to describe this library.
*/
- pkgPtr = ckalloc(sizeof(LoadedPackage));
+ libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary));
len = strlen(fullFileName) + 1;
- pkgPtr->fileName = ckalloc(len);
- memcpy(pkgPtr->fileName, fullFileName, len);
- len = (unsigned) Tcl_DStringLength(&prefix) + 1;
- pkgPtr->packageName = ckalloc(len);
- memcpy(pkgPtr->packageName, Tcl_DStringValue(&prefix), len);
- pkgPtr->loadHandle = loadHandle;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = (Tcl_PackageInitProc *)
+ libraryPtr->fileName = (char *)ckalloc(len);
+ memcpy(libraryPtr->fileName, fullFileName, len);
+ len = Tcl_DStringLength(&pfx) + 1;
+ libraryPtr->prefix = (char *)ckalloc(len);
+ memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len);
+ libraryPtr->loadHandle = loadHandle;
+ libraryPtr->initProc = initProc;
+ libraryPtr->safeInitProc = (Tcl_LibraryInitProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&safeInitName));
- pkgPtr->unloadProc = (Tcl_PackageUnloadProc *)
+ libraryPtr->unloadProc = (Tcl_LibraryUnloadProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&unloadName));
- pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *)
+ libraryPtr->safeUnloadProc = (Tcl_LibraryUnloadProc *)
Tcl_FindSymbol(interp, loadHandle,
Tcl_DStringValue(&safeUnloadName));
- pkgPtr->interpRefCount = 0;
- pkgPtr->safeInterpRefCount = 0;
+ libraryPtr->interpRefCount = 0;
+ libraryPtr->safeInterpRefCount = 0;
- Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
+ libraryPtr->nextPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr;
+ Tcl_MutexUnlock(&libraryMutex);
/*
* The Tcl_FindSymbol calls may have left a spurious error message in
@@ -436,32 +452,32 @@ Tcl_LoadObjCmd(
}
/*
- * Invoke the package's initialization function (either the normal one or
+ * Invoke the library's initialization function (either the normal one or
* the safe one, depending on whether or not the interpreter is safe).
*/
if (Tcl_IsSafe(target)) {
- if (pkgPtr->safeInitProc == NULL) {
+ if (libraryPtr->safeInitProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't use package in a safe interpreter: no"
- " %s_SafeInit procedure", pkgPtr->packageName));
+ "can't use library in a safe interpreter: no"
+ " %s_SafeInit procedure", libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
- code = pkgPtr->safeInitProc(target);
+ code = libraryPtr->safeInitProc(target);
} else {
- if (pkgPtr->initProc == NULL) {
+ if (libraryPtr->initProc == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't attach package to interpreter: no %s_Init procedure",
- pkgPtr->packageName));
+ "can't attach library to interpreter: no %s_Init procedure",
+ libraryPtr->prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
- code = pkgPtr->initProc(target);
+ code = libraryPtr->initProc(target);
}
/*
@@ -470,38 +486,51 @@ Tcl_LoadObjCmd(
*/
if (code != TCL_OK) {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+ Interp *iPtr = (Interp *) target;
+ if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) {
+ /*
+ * A call to Tcl_InitStubs() determined the caller extension and
+ * this interp are incompatible in their stubs mechanisms, and
+ * recorded the error in the oldest legacy place we have to do so.
+ */
+ Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1));
+ iPtr->result = &tclEmptyString;
+ iPtr->freeProc = NULL;
+ }
+#endif /* defined(TCL_NO_DEPRECATED) */
Tcl_TransferResult(target, code, interp);
goto done;
}
/*
- * Record the fact that the package has been loaded in the target
+ * Record the fact that the library has been loaded in the target
* interpreter.
*
* Update the proper reference count.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
if (Tcl_IsSafe(target)) {
- pkgPtr->safeInterpRefCount++;
+ libraryPtr->safeInterpRefCount++;
} else {
- pkgPtr->interpRefCount++;
+ libraryPtr->interpRefCount++;
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
/*
- * Refetch ipFirstPtr: loading the package may have introduced additional
- * static packages at the head of the linked list!
+ * Refetch ipFirstPtr: loading the library may have introduced additional
+ * static libraries at the head of the linked list!
*/
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ckalloc(sizeof(InterpPackage));
- ipPtr->pkgPtr = pkgPtr;
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary));
+ ipPtr->libraryPtr = libraryPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
done:
- Tcl_DStringFree(&prefix);
+ Tcl_DStringFree(&pfx);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
Tcl_DStringFree(&unloadName);
@@ -515,7 +544,7 @@ Tcl_LoadObjCmd(
*
* Tcl_UnloadObjCmd --
*
- * This function is invoked to process the "unload" Tcl command. See the
+ * Implements the the "unload" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
@@ -529,24 +558,22 @@ Tcl_LoadObjCmd(
int
Tcl_UnloadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target; /* Which interpreter to unload from. */
- LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString prefix, tmp;
- Tcl_PackageUnloadProc *unloadProc;
- InterpPackage *ipFirstPtr, *ipPtr;
+ LoadedLibrary *libraryPtr;
+ Tcl_DString pfx, tmp;
+ InterpLibrary *ipFirstPtr, *ipPtr;
int i, index, code, complain = 1, keepLibrary = 0;
- int trustedRefCount = -1, safeRefCount = -1;
const char *fullFileName = "";
- const char *packageName;
+ const char *prefix;
static const char *const options[] = {
"-nocomplain", "-keeplibrary", "--", NULL
};
- enum options {
+ enum unloadOptionsEnum {
UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
};
@@ -571,7 +598,7 @@ Tcl_UnloadObjCmd(
break;
}
}
- switch (index) {
+ switch ((enum unloadOptionsEnum)index) {
case UNLOAD_NOCOMPLAIN: /* -nocomplain */
complain = 0;
break;
@@ -586,7 +613,7 @@ Tcl_UnloadObjCmd(
endOfForLoop:
if ((objc-i < 1) || (objc-i > 3)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?-switch ...? fileName ?packageName? ?interp?");
+ "?-switch ...? fileName ?prefix? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
@@ -594,27 +621,27 @@ Tcl_UnloadObjCmd(
}
fullFileName = Tcl_GetString(objv[i]);
- Tcl_DStringInit(&prefix);
+ Tcl_DStringInit(&pfx);
Tcl_DStringInit(&tmp);
- packageName = NULL;
+ prefix = NULL;
if (objc - i >= 2) {
- packageName = Tcl_GetString(objv[i+1]);
- if (packageName[0] == '\0') {
- packageName = NULL;
+ prefix = Tcl_GetString(objv[i+1]);
+ if (prefix[0] == '\0') {
+ prefix = NULL;
}
}
- if ((fullFileName[0] == 0) && (packageName == NULL)) {
+ if ((fullFileName[0] == 0) && (prefix == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "must specify either file name or package name", -1));
+ "must specify either file name or prefix", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
/*
- * Figure out which interpreter we're going to load the package into.
+ * Figure out which interpreter we're going to load the library into.
*/
target = interp;
@@ -628,65 +655,61 @@ Tcl_UnloadObjCmd(
}
/*
- * Scan through the packages that are currently loaded to see if the
- * package we want is already loaded. We'll use a loaded package if it
+ * Scan through the libraries that are currently loaded to see if the
+ * library we want is already loaded. We'll use a loaded library if it
* meets any of the following conditions:
- * - Its name and file match the once we're looking for.
- * - Its file matches, and we weren't given a name.
- * - Its name matches, the file name was specified as empty, and there is
- * only no statically loaded package with the same name.
+ * - Its prefix and file match the once we're looking for.
+ * - Its file matches, and we weren't given a prefix.
+ * - Its prefix matches, the file name was specified as empty, and there is
+ * no statically loaded library with the same prefix.
*/
- Tcl_MutexLock(&packageMutex);
+ Tcl_MutexLock(&libraryMutex);
- defaultPtr = NULL;
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
int namesMatch, filesMatch;
- if (packageName == NULL) {
+ if (prefix == NULL) {
namesMatch = 0;
} else {
- TclDStringClear(&prefix);
- Tcl_DStringAppend(&prefix, packageName, -1);
+ TclDStringClear(&pfx);
+ Tcl_DStringAppend(&pfx, prefix, -1);
TclDStringClear(&tmp);
- Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
- Tcl_UtfToLower(Tcl_DStringValue(&prefix));
+ Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pfx));
Tcl_UtfToLower(Tcl_DStringValue(&tmp));
if (strcmp(Tcl_DStringValue(&tmp),
- Tcl_DStringValue(&prefix)) == 0) {
+ Tcl_DStringValue(&pfx)) == 0) {
namesMatch = 1;
} else {
namesMatch = 0;
}
}
- TclDStringClear(&prefix);
+ TclDStringClear(&pfx);
- filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
- if (filesMatch && (namesMatch || (packageName == NULL))) {
+ filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0);
+ if (filesMatch && (namesMatch || (prefix == NULL))) {
break;
}
- if (namesMatch && (fullFileName[0] == 0)) {
- defaultPtr = pkgPtr;
- }
if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
break;
}
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
if (fullFileName[0] == 0) {
/*
- * It's an error to try unload a static package.
+ * It's an error to try unload a static library.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "package \"%s\" is loaded statically and cannot be unloaded",
- packageName));
+ "library with prefix \"%s\" is loaded statically and cannot be unloaded",
+ prefix));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
- if (pkgPtr == NULL) {
+ if (libraryPtr == NULL) {
/*
* The DLL pointed by the provided filename has never been loaded.
*/
@@ -694,22 +717,22 @@ Tcl_UnloadObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded", fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
/*
- * Scan through the list of packages already loaded in the target
- * interpreter. If the package we want is already loaded there, then we
+ * Scan through the list of libraries already loaded in the target
+ * interpreter. If the library we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
- if (pkgPtr != NULL) {
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ if (libraryPtr != NULL) {
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
code = TCL_OK;
break;
}
@@ -717,50 +740,101 @@ Tcl_UnloadObjCmd(
}
if (code != TCL_OK) {
/*
- * The package has not been loaded in this interpreter.
+ * The library has not been loaded in this interpreter.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"file \"%s\" has never been loaded in this interpreter",
fullFileName));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
- NULL);
+ (void *)NULL);
code = TCL_ERROR;
goto done;
}
+ code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);
+
+ done:
+ Tcl_DStringFree(&pfx);
+ Tcl_DStringFree(&tmp);
+ if (!complain && (code != TCL_OK)) {
+ code = TCL_OK;
+ Tcl_ResetResult(interp);
+ }
+ return code;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnloadLibrary --
+ *
+ * Unloads a library from an interpreter, and also from the process if it
+ * is unloadable, i.e. if it provides an "unload" function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See description.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+UnloadLibrary(
+ Tcl_Interp *interp,
+ Tcl_Interp *target,
+ LoadedLibrary *libraryPtr,
+ int keepLibrary,
+ const char *fullFileName,
+ int interpExiting
+)
+{
+ int code;
+ InterpLibrary *ipFirstPtr, *ipPtr;
+ LoadedLibrary *iterLibraryPtr;
+ int trustedRefCount = -1, safeRefCount = -1;
+ Tcl_LibraryUnloadProc *unloadProc = NULL;
+
/*
* Ensure that the DLL can be unloaded. If it is a trusted interpreter,
- * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If
- * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL.
+ * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If
+ * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL.
*/
if (Tcl_IsSafe(target)) {
- if (pkgPtr->safeUnloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a safe interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (libraryPtr->safeUnloadProc == NULL) {
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a safe interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ (void *)NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
- unloadProc = pkgPtr->safeUnloadProc;
+ unloadProc = libraryPtr->safeUnloadProc;
} else {
- if (pkgPtr->unloadProc == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "file \"%s\" cannot be unloaded under a trusted interpreter",
- fullFileName));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
- NULL);
- code = TCL_ERROR;
- goto done;
+ if (libraryPtr->unloadProc == NULL) {
+ if (!interpExiting) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "file \"%s\" cannot be unloaded under a trusted interpreter",
+ fullFileName));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+ (void *)NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
}
- unloadProc = pkgPtr->unloadProc;
+ unloadProc = libraryPtr->unloadProc;
}
+
+
/*
- * We are ready to unload the package. First, evaluate the unload
+ * We are ready to unload the library. First, evaluate the unload
* function. If this fails, we cannot proceed with unload. Also, we must
* specify the proper flag to pass to the unload callback.
* TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should
@@ -769,63 +843,96 @@ Tcl_UnloadObjCmd(
* after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
*/
- code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
- if (!keepLibrary) {
- Tcl_MutexLock(&packageMutex);
- trustedRefCount = pkgPtr->interpRefCount;
- safeRefCount = pkgPtr->safeInterpRefCount;
- Tcl_MutexUnlock(&packageMutex);
-
- if (Tcl_IsSafe(target)) {
- safeRefCount--;
- } else {
- trustedRefCount--;
- }
+ if (unloadProc == NULL) {
+ code = TCL_OK;
+ } else {
+ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
+ if (!keepLibrary) {
+ Tcl_MutexLock(&libraryMutex);
+ trustedRefCount = libraryPtr->interpRefCount;
+ safeRefCount = libraryPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&libraryMutex);
+
+ if (Tcl_IsSafe(target)) {
+ safeRefCount--;
+ } else {
+ trustedRefCount--;
+ }
- if (safeRefCount <= 0 && trustedRefCount <= 0) {
- code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ if (safeRefCount <= 0 && trustedRefCount <= 0) {
+ code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ }
}
+ code = unloadProc(target, code);
}
- code = unloadProc(target, code);
+
+
if (code != TCL_OK) {
Tcl_TransferResult(target, code, interp);
goto done;
}
+
/*
- * The unload function executed fine. Examine the reference count to see
- * if we unload the DLL.
+ * Remove this library from the interpreter's library cache.
*/
- Tcl_MutexLock(&packageMutex);
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = ipFirstPtr;
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipFirstPtr = ipFirstPtr->nextPtr;
+ } else {
+ InterpLibrary *ipPrevPtr;
+
+ for (ipPrevPtr = ipPtr; ipPtr != NULL;
+ ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
+ ipPrevPtr->nextPtr = ipPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ ckfree(ipPtr);
+ Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);
+
+
+ if (IsStatic(libraryPtr)) {
+ goto done;
+ }
+
+ /*
+ * The unload function was called succesfully.
+ */
+
+ Tcl_MutexLock(&libraryMutex);
if (Tcl_IsSafe(target)) {
- pkgPtr->safeInterpRefCount--;
+ libraryPtr->safeInterpRefCount--;
/*
* Do not let counter get negative.
*/
- if (pkgPtr->safeInterpRefCount < 0) {
- pkgPtr->safeInterpRefCount = 0;
+ if (libraryPtr->safeInterpRefCount < 0) {
+ libraryPtr->safeInterpRefCount = 0;
}
} else {
- pkgPtr->interpRefCount--;
+ libraryPtr->interpRefCount--;
/*
* Do not let counter get negative.
*/
- if (pkgPtr->interpRefCount < 0) {
- pkgPtr->interpRefCount = 0;
+ if (libraryPtr->interpRefCount < 0) {
+ libraryPtr->interpRefCount = 0;
}
}
- trustedRefCount = pkgPtr->interpRefCount;
- safeRefCount = pkgPtr->safeInterpRefCount;
- Tcl_MutexUnlock(&packageMutex);
+ trustedRefCount = libraryPtr->interpRefCount;
+ safeRefCount = libraryPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&libraryMutex);
code = TCL_OK;
- if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
- && !keepLibrary) {
+ if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0
+ && (unloadProc != NULL) && !keepLibrary) {
/*
* Unload the shared library from the application memory...
*/
@@ -838,52 +945,30 @@ Tcl_UnloadObjCmd(
* it's been unloaded.
*/
- if (pkgPtr->fileName[0] != '\0') {
- Tcl_MutexLock(&packageMutex);
- if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {
+ if (!IsStatic(libraryPtr)) {
+ Tcl_MutexLock(&libraryMutex);
+ if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) {
/*
* Remove this library from the loaded library cache.
*/
- defaultPtr = pkgPtr;
- if (defaultPtr == firstPackagePtr) {
- firstPackagePtr = pkgPtr->nextPtr;
+ iterLibraryPtr = libraryPtr;
+ if (iterLibraryPtr == firstLibraryPtr) {
+ firstLibraryPtr = libraryPtr->nextPtr;
} else {
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
- pkgPtr = pkgPtr->nextPtr) {
- if (pkgPtr->nextPtr == defaultPtr) {
- pkgPtr->nextPtr = defaultPtr->nextPtr;
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
+ libraryPtr = libraryPtr->nextPtr) {
+ if (libraryPtr->nextPtr == iterLibraryPtr) {
+ libraryPtr->nextPtr = iterLibraryPtr->nextPtr;
break;
}
}
}
- /*
- * Remove this library from the interpreter's library cache.
- */
-
- ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
- ipPtr = ipFirstPtr;
- if (ipPtr->pkgPtr == defaultPtr) {
- ipFirstPtr = ipFirstPtr->nextPtr;
- } else {
- InterpPackage *ipPrevPtr;
-
- for (ipPrevPtr = ipPtr; ipPtr != NULL;
- ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == defaultPtr) {
- ipPrevPtr->nextPtr = ipPtr->nextPtr;
- break;
- }
- }
- }
- Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
- ipFirstPtr);
- ckfree(defaultPtr->fileName);
- ckfree(defaultPtr->packageName);
- ckfree(defaultPtr);
- ckfree(ipPtr);
- Tcl_MutexUnlock(&packageMutex);
+ ckfree(iterLibraryPtr->fileName);
+ ckfree(iterLibraryPtr->prefix);
+ ckfree(iterLibraryPtr);
+ Tcl_MutexUnlock(&libraryMutex);
} else {
code = TCL_ERROR;
}
@@ -899,111 +984,107 @@ Tcl_UnloadObjCmd(
}
done:
- Tcl_DStringFree(&prefix);
- Tcl_DStringFree(&tmp);
- if (!complain && (code != TCL_OK)) {
- code = TCL_OK;
- Tcl_ResetResult(interp);
- }
return code;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_StaticPackage --
+ * Tcl_StaticLibrary --
*
- * This function is invoked to indicate that a particular package has
+ * This function is invoked to indicate that a particular library has
* been linked statically with an application.
*
* Results:
* None.
*
* Side effects:
- * Once this function completes, the package becomes loadable via the
+ * Once this function completes, the library becomes loadable via the
* "load" command with an empty file name.
*
*----------------------------------------------------------------------
*/
void
-Tcl_StaticPackage(
- Tcl_Interp *interp, /* If not NULL, it means that the package has
+Tcl_StaticLibrary(
+ Tcl_Interp *interp, /* If not NULL, it means that the library has
* already been loaded into the given
* interpreter by calling the appropriate init
* proc. */
const char *prefix, /* Prefix (must be properly
* capitalized: first letter upper case,
* others lower case). */
- Tcl_PackageInitProc *initProc,
+ Tcl_LibraryInitProc *initProc,
/* Function to call to incorporate this
- * package into a trusted interpreter. */
- Tcl_PackageInitProc *safeInitProc)
+ * library into a trusted interpreter. */
+ Tcl_LibraryInitProc *safeInitProc)
/* Function to call to incorporate this
- * package into a safe interpreter (one that
+ * library into a safe interpreter (one that
* will execute untrusted scripts). NULL means
- * the package can't be used in safe
+ * the library can't be used in safe
* interpreters. */
{
- LoadedPackage *pkgPtr;
- InterpPackage *ipPtr, *ipFirstPtr;
+ LoadedLibrary *libraryPtr;
+ InterpLibrary *ipPtr, *ipFirstPtr;
/*
- * Check to see if someone else has already reported this package as
+ * Check to see if someone else has already reported this library as
* statically loaded in the process.
*/
- Tcl_MutexLock(&packageMutex);
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
- if ((pkgPtr->initProc == initProc)
- && (pkgPtr->safeInitProc == safeInitProc)
- && (strcmp(pkgPtr->packageName, prefix) == 0)) {
+ Tcl_MutexLock(&libraryMutex);
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) {
+ if ((libraryPtr->initProc == initProc)
+ && (libraryPtr->safeInitProc == safeInitProc)
+ && (strcmp(libraryPtr->prefix, prefix) == 0)) {
break;
}
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
/*
- * If the package is not yet recorded as being loaded statically, add it
+ * If the library is not yet recorded as being loaded statically, add it
* to the list now.
*/
- if (pkgPtr == NULL) {
- pkgPtr = ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = ckalloc(1);
- pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = ckalloc(strlen(prefix) + 1);
- strcpy(pkgPtr->packageName, prefix);
- pkgPtr->loadHandle = NULL;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
- Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
- Tcl_MutexUnlock(&packageMutex);
+ if (libraryPtr == NULL) {
+ libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary));
+ libraryPtr->fileName = (char *)ckalloc(1);
+ libraryPtr->fileName[0] = 0;
+ libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1);
+ strcpy(libraryPtr->prefix, prefix);
+ libraryPtr->loadHandle = NULL;
+ libraryPtr->initProc = initProc;
+ libraryPtr->safeInitProc = safeInitProc;
+ libraryPtr->unloadProc = NULL;
+ libraryPtr->safeUnloadProc = NULL;
+ Tcl_MutexLock(&libraryMutex);
+ libraryPtr->nextPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr;
+ Tcl_MutexUnlock(&libraryMutex);
}
if (interp != NULL) {
/*
- * If we're loading the package into an interpreter, determine whether
+ * If we're loading the library into an interpreter, determine whether
* it's already loaded.
*/
- ipFirstPtr = Tcl_GetAssocData(interp, "tclLoad", NULL);
+ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- if (ipPtr->pkgPtr == pkgPtr) {
+ if (ipPtr->libraryPtr == libraryPtr) {
return;
}
}
/*
- * Package isn't loade in the current interp yet. Mark it as now being
+ * Library isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
- ipPtr = ckalloc(sizeof(InterpPackage));
- ipPtr->pkgPtr = pkgPtr;
+ ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary));
+ ipPtr->libraryPtr = libraryPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
@@ -1012,7 +1093,7 @@ Tcl_StaticPackage(
/*
*----------------------------------------------------------------------
*
- * TclGetLoadedPackages --
+ * TclGetLoadedLibraries --
*
* This function returns information about all of the files that are
* loaded (either in a particular interpreter, or for all interpreters).
@@ -1022,7 +1103,7 @@ Tcl_StaticPackage(
* list of lists is placed in the interp's result. Each sublist
* corresponds to one loaded file; its first element is the name of the
* file (or an empty string for something that's statically loaded) and
- * the second element is the name of the package in that file.
+ * the second element is the prefix of the library in that file.
*
* Side effects:
* None.
@@ -1031,53 +1112,74 @@ Tcl_StaticPackage(
*/
int
-TclGetLoadedPackages(
+TclGetLoadedLibraries(
Tcl_Interp *interp, /* Interpreter in which to return information
* or error message. */
- const char *targetName) /* Name of target interpreter or NULL. If
+ const char *targetName, /* Name of target interpreter or NULL. If
* NULL, return info about all interps;
* otherwise, just return info about this
* interpreter. */
+ const char *prefix) /* Prefix or NULL. If NULL, return info
+ * for all prefixes.
+ */
{
Tcl_Interp *target;
- LoadedPackage *pkgPtr;
- InterpPackage *ipPtr;
+ LoadedLibrary *libraryPtr;
+ InterpLibrary *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
- /*
- * Return information about all of the available packages.
- */
-
TclNewObj(resultObj);
- Tcl_MutexLock(&packageMutex);
- for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
- pkgPtr = pkgPtr->nextPtr) {
- pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
- pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+ Tcl_MutexLock(&libraryMutex);
+ for (libraryPtr = firstLibraryPtr; libraryPtr != NULL;
+ libraryPtr = libraryPtr->nextPtr) {
+ pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewListObj(2, pkgDesc));
}
- Tcl_MutexUnlock(&packageMutex);
+ Tcl_MutexUnlock(&libraryMutex);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
- /*
- * Return information about only the packages that are loaded in a given
- * interpreter.
- */
-
target = Tcl_GetChild(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
- ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+ ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL);
+
+ /*
+ * Return information about all of the available libraries.
+ */
+ if (prefix) {
+ resultObj = NULL;
+
+ for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ libraryPtr = ipPtr->libraryPtr;
+
+ if (!strcmp(prefix, libraryPtr->prefix)) {
+ resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ break;
+ }
+ }
+
+ if (resultObj) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Return information about only the libraries that are loaded in a given
+ * interpreter.
+ */
+
TclNewObj(resultObj);
for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
- pkgPtr = ipPtr->pkgPtr;
- pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
- pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+ libraryPtr = ipPtr->libraryPtr;
+ pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1);
+ pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1);
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
}
Tcl_SetObjResult(interp, resultObj);
@@ -1089,7 +1191,7 @@ TclGetLoadedPackages(
*
* LoadCleanupProc --
*
- * This function is called to delete all of the InterpPackage structures
+ * This function is called to delete all of the InterpLibrary structures
* for an interpreter when the interpreter is deleted. It gets invoked
* via the Tcl AssocData mechanism.
*
@@ -1097,24 +1199,27 @@ TclGetLoadedPackages(
* None.
*
* Side effects:
- * Storage for all of the InterpPackage functions for interp get deleted.
+ * Storage for all of the InterpLibrary functions for interp get deleted.
*
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
- ClientData clientData, /* Pointer to first InterpPackage structure
+ TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure
* for interp. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
+ Tcl_Interp *interp)
{
- InterpPackage *ipPtr, *nextPtr;
+ InterpLibrary *ipPtr;
+ LoadedLibrary *libraryPtr;
- ipPtr = clientData;
- while (ipPtr != NULL) {
- nextPtr = ipPtr->nextPtr;
- ckfree(ipPtr);
- ipPtr = nextPtr;
+ while (1) {
+ ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
+ if (ipPtr == NULL) {
+ break;
+ }
+ libraryPtr = ipPtr->libraryPtr;
+ UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1);
}
}
@@ -1124,7 +1229,7 @@ LoadCleanupProc(
* TclFinalizeLoad --
*
* This function is invoked just before the application exits. It frees
- * all of the LoadedPackage structures.
+ * all of the LoadedLibrary structures.
*
* Results:
* None.
@@ -1138,18 +1243,18 @@ LoadCleanupProc(
void
TclFinalizeLoad(void)
{
- LoadedPackage *pkgPtr;
+ LoadedLibrary *libraryPtr;
/*
* No synchronization here because there should just be one thread alive
- * at this point. Logically, packageMutex should be grabbed at this point,
+ * at this point. Logically, libraryMutex should be grabbed at this point,
* but the Mutexes get finalized before the call to this routine. The only
* subsystem left alive at this point is the memory allocator.
*/
- while (firstPackagePtr != NULL) {
- pkgPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr->nextPtr;
+ while (firstLibraryPtr != NULL) {
+ libraryPtr = firstLibraryPtr;
+ firstLibraryPtr = libraryPtr->nextPtr;
#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32)
/*
@@ -1159,14 +1264,14 @@ TclFinalizeLoad(void)
* it has been unloaded.
*/
- if (pkgPtr->fileName[0] != '\0') {
- Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
+ if (!IsStatic(libraryPtr)) {
+ Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle);
}
#endif
- ckfree(pkgPtr->fileName);
- ckfree(pkgPtr->packageName);
- ckfree(pkgPtr);
+ ckfree(libraryPtr->fileName);
+ ckfree(libraryPtr->prefix);
+ ckfree(libraryPtr);
}
}
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index 6af5c4f..f60f843 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -4,7 +4,7 @@
* This procedure provides a version of the TclpDlopen for use in
* systems that don't support dynamic loading; it just returns an error.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1995-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.
@@ -54,36 +54,6 @@ TclpDlopen(
}
/*
- *----------------------------------------------------------------------
- *
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package name,
- * this procedure is invoked to try to figure it out.
- *
- * Results:
- * Always returns 0 to indicate that we couldn't figure out a package
- * name; generic code will then try to guess the package from the file
- * name. A return value of 1 would have meant that we figured out the
- * package name and put it in bufPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclGuessPackageName(
- const char *fileName, /* Name of file containing package (already
- * translated to local form if needed). */
- Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
- * name to this if possible. */
-{
- return 0;
-}
-
-/*
* These functions are fallbacks if we somehow determine that the platform can
* do loading from memory but the user wishes to disable it. They just report
* (gracefully) that they fail.
@@ -93,8 +63,8 @@ TclGuessPackageName(
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
- Tcl_Interp *interp, /* Dummy: unused by this implementation */
- int size) /* Dummy: unused by this implementation */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int))
{
return NULL;
}
@@ -102,14 +72,12 @@ TclpLoadMemoryGetBuffer(
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
- void *buffer, /* Dummy: unused by this implementation */
- int size, /* Dummy: unused by this implementation */
- int codeSize, /* Dummy: unused by this implementation */
- Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */
- Tcl_FSUnloadFileProc **unloadProcPtr,
- /* Dummy: unused by this implementation */
- int flags)
- /* Dummy: unused by this implementation */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int),
+ TCL_UNUSED(int),
+ TCL_UNUSED(Tcl_LoadHandle *),
+ TCL_UNUSED(Tcl_FSUnloadFileProc **),
+ TCL_UNUSED(int))
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 3f72838..906c197 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -8,9 +8,9 @@
* application. Or, it can be used as a template for creating new main
* programs for Tcl applications.
*
- * Copyright (c) 1988-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 2000 Ajuba Solutions.
+ * Copyright © 1988-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -29,6 +29,7 @@
*/
static const char DEFAULT_PRIMARY_PROMPT[] = "% ";
+static const char ENCODING_ERROR[] = "\n\t(encoding error in stderr)";
/*
* This file can be compiled on Windows in UNICODE mode, as well as on all
@@ -50,11 +51,12 @@ NewNativeObj(
Tcl_DString ds;
#ifdef UNICODE
- Tcl_WinTCharToUtf(string, -1, &ds);
+ Tcl_DStringInit(&ds);
+ Tcl_WCharToUtfDString(string, -1, &ds);
#else
- Tcl_ExternalToUtfDString(NULL, (char *) string, -1, &ds);
+ Tcl_ExternalToUtfDString(NULL, (char *)string, -1, &ds);
#endif
- return TclDStringToObj(&ds);
+ return Tcl_DStringToObj(&ds);
}
/*
@@ -63,11 +65,6 @@ NewNativeObj(
* source directory to make their own modified versions).
*/
-#if defined _MSC_VER && _MSC_VER < 1900
-/* isatty is always defined on MSVC 14.0, but not necessarily as CRTIMPORT. */
-extern CRTIMPORT int isatty(int fd);
-#endif
-
/*
* The thread-local variables for this file's functions.
*/
@@ -253,7 +250,9 @@ Tcl_SourceRCFile(
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(chan, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
}
@@ -266,7 +265,7 @@ Tcl_SourceRCFile(
/*----------------------------------------------------------------------
*
- * Tcl_Main, Tcl_MainEx --
+ * Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
@@ -292,6 +291,7 @@ Tcl_MainEx(
* but before starting to execute commands. */
Tcl_Interp *interp)
{
+ int i=0; /* argv[i] index */
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
@@ -300,7 +300,13 @@ Tcl_MainEx(
InteractiveState is;
TclpSetInitialEncodings();
- TclpFindExecutable((const char *)argv[0]);
+ if (0 < argc) {
+ --argc; /* "consume" argv[0] */
+ ++i;
+ }
+ TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL
+ * w/ (eg) an empty argv
+ * supplied to execve() */
Tcl_InitMemory(interp);
@@ -322,18 +328,19 @@ Tcl_MainEx(
* FILENAME
*/
- if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
+ /* mind argc is being adjusted as we proceed */
+ if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
- argv += 3;
- } else if ((argc > 1) && ('-' != argv[1][0])) {
+ i += 3;
+ } else if ((argc >= 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
- argv++;
+ i++;
}
}
@@ -344,14 +351,12 @@ Tcl_MainEx(
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
- argc--;
- argv++;
- Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
- Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++));
+ Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++]));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
@@ -361,7 +366,7 @@ Tcl_MainEx(
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
- Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
+ Tcl_NewWideIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
@@ -373,7 +378,9 @@ Tcl_MainEx(
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(chan, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
}
@@ -413,7 +420,9 @@ Tcl_MainEx(
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
- Tcl_WriteObj(chan, valuePtr);
+ if (Tcl_WriteObj(chan, valuePtr) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
@@ -445,7 +454,7 @@ Tcl_MainEx(
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
- Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
+ Tcl_LinkVar(interp, "tcl_interactive", &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
@@ -526,7 +535,9 @@ Tcl_MainEx(
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(chan, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
@@ -535,7 +546,9 @@ Tcl_MainEx(
(void)Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
- Tcl_WriteObj(chan, resultPtr);
+ if (Tcl_WriteObj(chan, resultPtr) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
@@ -617,21 +630,6 @@ Tcl_MainEx(
Tcl_Exit(exitCode);
}
-
-#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
-#undef Tcl_Main
-extern DLLEXPORT void
-Tcl_Main(
- int argc, /* Number of arguments. */
- char **argv, /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc)
- /* Application-specific initialization
- * function to call after most initialization
- * but before starting to execute commands. */
-{
- Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
-}
-#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
#if !defined(_WIN32) || defined(UNICODE)
@@ -748,7 +746,7 @@ TclFullFinalizationRequested(void)
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
- int mask) /* Not used. */
+ TCL_UNUSED(int) /*mask*/)
{
int code;
int length;
@@ -756,7 +754,6 @@ StdinProc(
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
- (void)mask;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
@@ -816,7 +813,9 @@ StdinProc(
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(chan, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
@@ -826,7 +825,9 @@ StdinProc(
Tcl_IncrRefCount(resultPtr);
(void)Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
- Tcl_WriteObj(chan, resultPtr);
+ if (Tcl_WriteObj(chan, resultPtr) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
@@ -897,7 +898,9 @@ Prompt(
"\n (script that generates prompt)");
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan != NULL) {
- Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ if (Tcl_WriteObj(chan, Tcl_GetObjResult(interp)) < 0) {
+ Tcl_WriteChars(chan, ENCODING_ERROR, -1);
+ }
Tcl_WriteChars(chan, "\n", 1);
}
goto defaultPrompt;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 290dcea..7a32fd9 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -7,11 +7,11 @@
* children of the global namespace. These other namespaces contain
* special-purpose commands and variables for packages.
*
- * Copyright (c) 1993-1997 Lucent Technologies.
- * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 2002-2005 Donal K. Fellows.
- * Copyright (c) 2006 Neil Madden.
+ * Copyright © 1993-1997 Lucent Technologies.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2002-2005 Donal K. Fellows.
+ * Copyright © 2006 Neil Madden.
* Contributions from Don Porter, NIST, 2007. (not subject to US copyright)
*
* Originally implemented by
@@ -25,6 +25,7 @@
#include "tclInt.h"
#include "tclCompile.h" /* for TclLogCommandInfo visibility */
+#include <assert.h>
/*
* Thread-local storage used to avoid having a global lock on data that is not
@@ -32,7 +33,7 @@
*/
typedef struct {
- long numNsCreated; /* Count of the number of namespaces created
+ unsigned long numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
@@ -52,14 +53,14 @@ static Tcl_ThreadDataKey dataKey;
* with some information that is used to check the cached pointer's validity.
*/
-typedef struct ResolvedNsName {
+typedef struct {
Namespace *nsPtr; /* A cached pointer to the Namespace that the
* name resolved to. */
Namespace *refNsPtr; /* Points to the namespace context in which
* the name was resolved. NULL if the name is
* fully qualified and thus the resolution
* does not depend on the context. */
- int refCount; /* Reference count: 1 for each nsName object
+ size_t refCount; /* Reference count: 1 for each nsName object
* that has a pointer to this ResolvedNsName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -91,7 +92,6 @@ static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
static int InvokeImportedNRCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static Tcl_ObjCmdProc InvokeImportedCmd;
static Tcl_ObjCmdProc NamespaceChildrenCmd;
static Tcl_ObjCmdProc NamespaceCodeCmd;
static Tcl_ObjCmdProc NamespaceCurrentCmd;
@@ -133,6 +133,22 @@ static const Tcl_ObjType nsNameType = {
SetNsNameFromAny /* setFromAnyProc */
};
+#define NsNameSetInternalRep(objPtr, nnPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (nnPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (nnPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &nsNameType, &ir); \
+ } while (0)
+
+#define NsNameGetInternalRep(objPtr, nnPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &nsNameType); \
+ (nnPtr) = irPtr ? (ResolvedNsName *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
@@ -290,7 +306,7 @@ Tcl_PushCallFrame(
/*
* TODO: Examine whether it would be better to guard based on NS_DYING
- * or NS_KILLED. It appears that these are not tested because they can
+ * or NS_TEARDOWN. It appears that these are not tested because they can
* be set in a global interp that has been [namespace delete]d, but
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
@@ -310,7 +326,7 @@ Tcl_PushCallFrame(
framePtr->callerPtr = iPtr->framePtr;
framePtr->callerVarPtr = iPtr->varFramePtr;
if (iPtr->varFramePtr != NULL) {
- framePtr->level = (iPtr->varFramePtr->level + 1);
+ framePtr->level = iPtr->varFramePtr->level + 1U;
} else {
framePtr->level = 0;
}
@@ -380,7 +396,7 @@ Tcl_PopCallFrame(
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
- if (--framePtr->localCachePtr->refCount == 0) {
+ if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
@@ -393,14 +409,15 @@ Tcl_PopCallFrame(
*/
nsPtr = framePtr->nsPtr;
- nsPtr->activationCount--;
- if ((nsPtr->flags & NS_DYING)
- && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
+ if ((--nsPtr->activationCount <= (nsPtr == iPtr->globalNsPtr))
+ && (nsPtr->flags & NS_DYING)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
+ /* Reusing the existing reference count from framePtr->tailcallPtr, so
+ * no need to Tcl_IncrRefCount(framePtr->tailcallPtr)*/
TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -477,11 +494,11 @@ TclPopStackFrame(
static char *
EstablishErrorCodeTraces(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorCodeRead, NULL);
@@ -509,11 +526,11 @@ EstablishErrorCodeTraces(
static char *
ErrorCodeRead(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
@@ -526,8 +543,10 @@ ErrorCodeRead(
return NULL;
}
if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) {
+ Tcl_Obj *objPtr;
+ TclNewObj(objPtr);
Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
- Tcl_NewObj(), TCL_GLOBAL_ONLY);
+ objPtr, TCL_GLOBAL_ONLY);
}
return NULL;
}
@@ -551,11 +570,11 @@ ErrorCodeRead(
static char *
EstablishErrorInfoTraces(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorInfoRead, NULL);
@@ -583,11 +602,11 @@ EstablishErrorInfoTraces(
static char *
ErrorInfoRead(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
- const char *name1,
- const char *name2,
- int flags)
+ TCL_UNUSED(const char *) /*name1*/,
+ TCL_UNUSED(const char *) /*name2*/,
+ TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
@@ -600,8 +619,10 @@ ErrorInfoRead(
return NULL;
}
if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) {
+ Tcl_Obj *objPtr;
+ TclNewObj(objPtr);
Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
- Tcl_NewObj(), TCL_GLOBAL_ONLY);
+ objPtr, TCL_GLOBAL_ONLY);
}
return NULL;
}
@@ -649,7 +670,8 @@ Tcl_CreateNamespace(
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
Tcl_DString *namePtr, *buffPtr;
- int newEntry, nameLen;
+ int newEntry;
+ size_t nameLen;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
const char *nameStr;
Tcl_DString tmpBuffer;
@@ -698,7 +720,7 @@ Tcl_CreateNamespace(
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
" \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEGLOBAL", NULL);
+ "CREATEGLOBAL", (void *)NULL);
Tcl_DStringFree(&tmpBuffer);
return NULL;
}
@@ -737,7 +759,7 @@ Tcl_CreateNamespace(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create namespace \"%s\": already exists", name));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEEXISTING", NULL);
+ "CREATEEXISTING", (void *)NULL);
Tcl_DStringFree(&tmpBuffer);
return NULL;
}
@@ -970,23 +992,24 @@ Tcl_DeleteNamespace(
}
/*
- * If the namespace is on the call frame stack, it is marked as "dying"
- * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
- * name but its commands and variables are still usable by those active
- * call frames. When all active call frames referring to the namespace
- * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
- * function again to delete everything in the namespace. If no nsName
- * objects refer to the namespace (i.e., if its refCount is zero), its
- * commands and variables are deleted and the storage for its namespace
- * structure is freed. Otherwise, if its refCount is nonzero, the
- * namespace's commands and variables are deleted but the structure isn't
- * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
- * namespace resolution code to recognize that the namespace is "deleted".
- * The structure's storage is freed by FreeNsNameInternalRep when its
- * refCount reaches 0.
+ * If the namespace is on the call frame stack, it is marked as "dying"
+ * (NS_DYING is OR'd into its flags): Contents of the namespace are
+ * still available and visible until the namespace is later marked as
+ * NS_DEAD, and its commands and variables are still usable by any
+ * active call frames referring to th namespace. When all active call
+ * frames referring to the namespace have been popped from the Tcl
+ * stack, Tcl_PopCallFrame calls Tcl_DeleteNamespace again. If no
+ * nsName objects refer to the namespace (i.e., if its refCount is
+ * zero), its commands and variables are deleted and the storage for
+ * its namespace structure is freed. Otherwise, if its refCount is
+ * nonzero, the namespace's commands and variables are deleted but the
+ * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
+ * flags to allow the namespace resolution code to recognize that the
+ * namespace is "deleted". The structure's storage is freed by
+ * FreeNsNameInternalRep when its refCount reaches 0.
*/
- if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
+ if (nsPtr->activationCount > (nsPtr == globalNsPtr)) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(
@@ -997,16 +1020,16 @@ Tcl_DeleteNamespace(
}
}
nsPtr->parentPtr = NULL;
- } else if (!(nsPtr->flags & NS_KILLED)) {
+ } else if (!(nsPtr->flags & NS_TEARDOWN)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
- * interpreter is being torn down. Set the NS_KILLED flag to avoid
+ * interpreter is being torn down. Set the NS_TEARDOWN flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
- nsPtr->flags |= (NS_DYING|NS_KILLED);
+ nsPtr->flags |= (NS_DYING|NS_TEARDOWN);
TclTeardownNamespace(nsPtr);
@@ -1044,7 +1067,7 @@ Tcl_DeleteNamespace(
* get killed later, avoiding mem leaks.
*/
- nsPtr->flags &= ~(NS_DYING|NS_KILLED);
+ nsPtr->flags &= ~(NS_DYING|NS_TEARDOWN);
}
}
TclNsDecrRefCount(nsPtr);
@@ -1057,6 +1080,84 @@ TclNamespaceDeleted(
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
+void
+TclDeleteNamespaceChildren(
+ Namespace *nsPtr /* Namespace whose children to delete */
+)
+{
+ Interp *iPtr = (Interp *) nsPtr->interp;
+ Tcl_HashEntry *entryPtr;
+ size_t i;
+ int unchecked;
+ Tcl_HashSearch search;
+ /*
+ * Delete all the child namespaces.
+ *
+ * BE CAREFUL: When each child is deleted, it divorces itself from its
+ * parent. The hash table can't be proplery traversed if its elements are
+ * being deleted. Because of traces (and the desire to avoid the
+ * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
+ * f97d4ee020]) copy to a temporary array and then delete all those
+ * namespaces.
+ *
+ * Important: leave the hash table itself still live.
+ */
+
+#ifndef BREAK_NAMESPACE_COMPAT
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ size_t length = nsPtr->childTable.numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ size_t length = nsPtr->childTablePtr->numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+ }
+#endif
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1087,7 +1188,7 @@ TclTeardownNamespace(
Interp *iPtr = (Interp *) nsPtr->interp;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
- int i;
+ Tcl_Size i;
/*
* Start by destroying the namespace's variable table, since variables
@@ -1108,7 +1209,7 @@ TclTeardownNamespace(
*/
while (nsPtr->cmdTable.numEntries > 0) {
- int length = nsPtr->cmdTable.numEntries;
+ Tcl_Size length = nsPtr->cmdTable.numEntries;
Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Command *) * length);
@@ -1165,62 +1266,7 @@ TclTeardownNamespace(
nsPtr->commandPathSourceList = NULL;
}
- /*
- * Delete all the child namespaces.
- *
- * BE CAREFUL: When each child is deleted, it will divorce itself from its
- * parent. You can't traverse a hash table properly if its elements are
- * being deleted. Because of traces (and the desire to avoid the
- * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
- * f97d4ee020]) we copy to a temporary array and then delete all those
- * namespaces.
- *
- * Important: leave the hash table itself still live.
- */
-
-#ifndef BREAK_NAMESPACE_COMPAT
- while (nsPtr->childTable.numEntries > 0) {
- int length = nsPtr->childTable.numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
-#else
- if (nsPtr->childTablePtr != NULL) {
- while (nsPtr->childTablePtr->numEntries > 0) {
- int length = nsPtr->childTablePtr->numEntries;
- Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = Tcl_GetHashValue(entryPtr);
- children[i]->refCount++;
- i++;
- }
- for (i = 0 ; i < length ; i++) {
- Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
- TclNsDecrRefCount(children[i]);
- }
- TclStackFree((Tcl_Interp *) iPtr, children);
- }
- }
-#endif
+ TclDeleteNamespaceChildren(nsPtr);
/*
* Free the namespace's export pattern array.
@@ -1308,8 +1354,7 @@ void
TclNsDecrRefCount(
Namespace *nsPtr)
{
- nsPtr->refCount--;
- if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
+ if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
}
@@ -1354,7 +1399,7 @@ Tcl_Export(
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
const char *simplePattern;
char *patternCpy;
- int neededElems, len, i;
+ Tcl_Size neededElems, len, i;
/*
* If the specified namespace is NULL, use the current namespace.
@@ -1394,7 +1439,7 @@ Tcl_Export(
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
" \"%s\": pattern can't specify a namespace", pattern));
- Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", (void *)NULL);
return TCL_ERROR;
}
@@ -1481,7 +1526,8 @@ Tcl_AppendExportList(
* export pattern list is appended. */
{
Namespace *nsPtr;
- int i, result;
+ Tcl_Size i;
+ int result;
/*
* If the specified namespace is NULL, use the current namespace.
@@ -1599,7 +1645,7 @@ Tcl_Import(
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", (void *)NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
@@ -1608,7 +1654,7 @@ Tcl_Import(
if (importNsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in import pattern \"%s\"", pattern));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (void *)NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
@@ -1616,12 +1662,12 @@ Tcl_Import(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no namespace specified in import pattern \"%s\"",
pattern));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", (void *)NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" tries to import from namespace"
" \"%s\" into itself", pattern, importNsPtr->name));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1683,7 +1729,7 @@ DoImport(
Namespace *importNsPtr,
int allowOverwrite)
{
- int i = 0, exported = 0;
+ Tcl_Size i = 0, exported = 0;
Tcl_HashEntry *found;
/*
@@ -1744,7 +1790,7 @@ DoImport(
" containing command \"%s\"",
pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", (void *)NULL);
return TCL_ERROR;
}
}
@@ -1752,9 +1798,11 @@ DoImport(
dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
+ /* corresponding decrement is in DeleteImportedCmd */
+ cmdPtr->refCount++;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
@@ -1784,7 +1832,7 @@ DoImport(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't import command \"%s\": already exists", cmdName));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1854,7 +1902,7 @@ Tcl_ForgetImport(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace in namespace forget pattern \"%s\"",
pattern));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, (void *)NULL);
return TCL_ERROR;
}
@@ -1973,7 +2021,7 @@ TclGetOriginalCommand(
/*
*----------------------------------------------------------------------
*
- * InvokeImportedCmd --
+ * TclInvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that was
* created by Tcl_Import. Finds the "real" command (in another
@@ -2004,8 +2052,8 @@ InvokeImportedNRCmd(
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
-static int
-InvokeImportedCmd(
+int
+TclInvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
@@ -2062,6 +2110,7 @@ DeleteImportedCmd(
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
+ TclCleanupCommandMacro(realCmdPtr);
ckfree(dataPtr);
return;
}
@@ -2107,7 +2156,7 @@ DeleteImportedCmd(
* If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components
* of the qualified name that cannot be found are automatically created
* within their specified parent. This makes sure that functions like
- * Tcl_CreateCommand always succeed. There is no alternate search path,
+ * Tcl_CreateObjCommand always succeed. There is no alternate search path,
* so *altNsPtrPtr is set NULL.
*
* If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as
@@ -2304,7 +2353,7 @@ TclGetNamespaceForQualName(
* Look up the namespace qualifier nsName in the current namespace
* context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
* create that qualifying namespace. This is needed for functions like
- * Tcl_CreateCommand that cannot fail.
+ * Tcl_CreateObjCommand that cannot fail.
*/
if (nsPtr != NULL) {
@@ -2488,7 +2537,7 @@ Tcl_FindNamespace(
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (void *)NULL);
}
return NULL;
}
@@ -2592,7 +2641,7 @@ Tcl_FindCommand(
cmdPtr = NULL;
if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
&& !(flags & TCL_NAMESPACE_ONLY)) {
- int i;
+ Tcl_Size i;
Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
@@ -2600,7 +2649,7 @@ Tcl_FindCommand(
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
- || !(realNsPtr->flags & NS_DYING)) {
+ || !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2612,7 +2661,7 @@ Tcl_FindCommand(
* Next, check along the path.
*/
- for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
+ for (i=0 ; (cmdPtr == NULL) && i<cxtNsPtr->commandPathLength ; i++) {
pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
if (pathNsPtr == NULL) {
continue;
@@ -2621,7 +2670,7 @@ Tcl_FindCommand(
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2639,7 +2688,7 @@ Tcl_FindCommand(
TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
- && !(realNsPtr->flags & NS_DYING)) {
+ && !(realNsPtr->flags & NS_DEAD)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
@@ -2678,7 +2727,7 @@ Tcl_FindCommand(
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown command \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, (void *)NULL);
}
return NULL;
}
@@ -2872,7 +2921,7 @@ TclGetNamespaceFromObj(
"namespace \"%s\" not found in \"%s\"", name,
Tcl_GetStringResult(interp)));
}
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2886,26 +2935,29 @@ GetNamespaceFromObj(
Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
{
ResolvedNsName *resNamePtr;
- Namespace *nsPtr, *refNsPtr;
- if (objPtr->typePtr == &nsNameType) {
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ if (resNamePtr) {
+ Namespace *nsPtr, *refNsPtr;
+
/*
* Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
*/
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
nsPtr = resNamePtr->nsPtr;
refNsPtr = resNamePtr->refNsPtr;
- if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
- (!refNsPtr || ((interp == refNsPtr->interp) &&
- (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
+ if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp)
+ && (!refNsPtr || (refNsPtr ==
+ (Namespace *) TclGetCurrentNamespace(interp)))) {
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
return TCL_OK;
}
+ Tcl_StoreInternalRep(objPtr, &nsNameType, NULL);
}
if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
- resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
return TCL_OK;
}
@@ -2959,7 +3011,7 @@ TclInitNamespaceCmd(
static int
NamespaceChildrenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3016,7 +3068,7 @@ NamespaceChildrenCmd(
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
- unsigned int length = strlen(nsPtr->fullName);
+ size_t length = strlen(nsPtr->fullName);
if (strncmp(pattern, nsPtr->fullName, length) != 0) {
goto searchDone;
@@ -3088,7 +3140,7 @@ NamespaceChildrenCmd(
static int
NamespaceCodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3096,7 +3148,7 @@ NamespaceCodeCmd(
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
const char *arg;
- int length;
+ Tcl_Size length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg");
@@ -3169,7 +3221,7 @@ NamespaceCodeCmd(
static int
NamespaceCurrentCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3232,7 +3284,7 @@ NamespaceCurrentCmd(
static int
NamespaceDeleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3256,12 +3308,12 @@ NamespaceDeleteCmd(
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
- || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
+ || (((Namespace *) namespacePtr)->flags & NS_TEARDOWN)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown namespace \"%s\" in namespace delete command",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
- TclGetString(objv[i]), NULL);
+ TclGetString(objv[i]), (void *)NULL);
return TCL_ERROR;
}
}
@@ -3320,7 +3372,7 @@ NamespaceEvalCmd(
static int
NRNamespaceEvalCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3409,15 +3461,15 @@ NsEval_Callback(
Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0];
if (result == TCL_ERROR) {
- int length = strlen(namespacePtr->fullName);
- int limit = 200;
+ size_t length = strlen(namespacePtr->fullName);
+ unsigned limit = 200;
int overflow = (length > limit);
char *cmd = (char *)data[1];
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in namespace %s \"%.*s%s\" script line %d)",
cmd,
- (overflow ? limit : length), namespacePtr->fullName,
+ (overflow ? limit : (unsigned)length), namespacePtr->fullName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
@@ -3452,7 +3504,7 @@ NsEval_Callback(
static int
NamespaceExistsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3507,7 +3559,7 @@ NamespaceExistsCmd(
static int
NamespaceExportCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3589,7 +3641,7 @@ NamespaceExportCmd(
static int
NamespaceForgetCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3654,7 +3706,7 @@ NamespaceForgetCmd(
static int
NamespaceImportCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3769,7 +3821,7 @@ NamespaceInscopeCmd(
static int
NRNamespaceInscopeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3866,12 +3918,12 @@ NRNamespaceInscopeCmd(
static int
NamespaceOriginCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_Command command, origCommand;
+ Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
@@ -3879,30 +3931,29 @@ NamespaceOriginCmd(
return TCL_ERROR;
}
- command = Tcl_GetCommandFromObj(interp, objv[1]);
- if (command == NULL) {
+ cmd = Tcl_GetCommandFromObj(interp, objv[1]);
+ if (cmd == NULL) {
+ goto namespaceOriginError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+ TclNewObj(resultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, resultPtr);
+ if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) {
+ Tcl_DecrRefCount(resultPtr);
+ namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
- origCommand = TclGetOriginalCommand(command);
- TclNewObj(resultPtr);
- if (origCommand == NULL) {
- /*
- * The specified command isn't an imported command. Return the
- * command's name qualified by the full name of the namespace it was
- * defined in.
- */
-
- Tcl_GetCommandFullName(interp, command, resultPtr);
- } else {
- Tcl_GetCommandFullName(interp, origCommand, resultPtr);
- }
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
+
/*
*----------------------------------------------------------------------
@@ -3927,7 +3978,7 @@ NamespaceOriginCmd(
static int
NamespaceParentCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -3985,13 +4036,14 @@ NamespaceParentCmd(
static int
NamespacePathCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- int i, nsObjc, result = TCL_ERROR;
+ Tcl_Size nsObjc, i;
+ int result = TCL_ERROR;
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
@@ -4022,14 +4074,14 @@ NamespacePathCmd(
* There is a path given, so parse it into an array of namespace pointers.
*/
- if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
+ 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++) {
+ for (i = 0; i < nsObjc; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
&namespaceList[i]) != TCL_OK) {
goto badNamespace;
@@ -4074,13 +4126,13 @@ NamespacePathCmd(
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
- int pathLength, /* Length of pathAry. */
+ Tcl_Size pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
(NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength);
- int i;
+ Tcl_Size i;
for (i=0 ; i<pathLength ; i++) {
tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
@@ -4131,7 +4183,7 @@ static void
UnlinkNsPath(
Namespace *nsPtr)
{
- int i;
+ Tcl_Size i;
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
@@ -4211,13 +4263,13 @@ TclInvalidateNsPath(
static int
NamespaceQualifiersCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *p;
- int length;
+ size_t length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
@@ -4279,7 +4331,7 @@ NamespaceQualifiersCmd(
static int
NamespaceUnknownCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4382,7 +4434,7 @@ Tcl_SetNamespaceUnknownHandler(
Tcl_Namespace *nsPtr, /* Namespace which is being updated. */
Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
{
- int lstlen = 0;
+ Tcl_Size lstlen = 0;
Namespace *currNsPtr = (Namespace *) nsPtr;
/*
@@ -4390,7 +4442,7 @@ Tcl_SetNamespaceUnknownHandler(
*/
if (handlerPtr != NULL) {
- if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
+ if (TclListObjLengthM(interp, handlerPtr, &lstlen) != TCL_OK) {
/*
* Not a list.
*/
@@ -4466,7 +4518,7 @@ Tcl_SetNamespaceUnknownHandler(
static int
NamespaceTailCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4524,7 +4576,7 @@ NamespaceTailCmd(
static int
NamespaceUpvarCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4598,7 +4650,7 @@ NamespaceUpvarCmd(
static int
NamespaceWhichCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4677,15 +4729,17 @@ FreeNsNameInternalRep(
Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- ResolvedNsName *resNamePtr = (ResolvedNsName *)objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
+
+ NsNameGetInternalRep(objPtr, resNamePtr);
+ assert(resNamePtr != NULL);
/*
* Decrement the reference count of the namespace. If there are no more
* references, free it up.
*/
- resNamePtr->refCount--;
- if (resNamePtr->refCount == 0) {
+ if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
@@ -4695,7 +4749,6 @@ FreeNsNameInternalRep(
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -4722,11 +4775,11 @@ DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- resNamePtr->refCount++;
- copyPtr->typePtr = &nsNameType;
+ NsNameGetInternalRep(srcPtr, resNamePtr);
+ assert(resNamePtr != NULL);
+ NsNameSetInternalRep(copyPtr, resNamePtr);
}
/*
@@ -4771,36 +4824,25 @@ SetNsNameFromAny(
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+ if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
+ return TCL_ERROR;
+ }
+
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
- if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
- /*
- * Our failed lookup proves any previously cached nsName internalrep is no
- * longer valid. Get rid of it so we no longer waste memory storing
- * it, nor time determining its invalidity again and again.
- */
-
- if (objPtr->typePtr == &nsNameType) {
- TclFreeIntRep(objPtr);
- }
- return TCL_ERROR;
- }
-
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
- resNamePtr->refNsPtr = (Namespace *)Tcl_GetCurrentNamespace(interp);
+ resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
- resNamePtr->refCount = 1;
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- objPtr->typePtr = &nsNameType;
+ resNamePtr->refCount = 0;
+ NsNameSetInternalRep(objPtr, resNamePtr);
return TCL_OK;
}
@@ -4864,11 +4906,11 @@ TclGetNamespaceChildTable(
*
* TclLogCommandInfo --
*
- * This function is invoked after an error occurs in an interpreter. It
- * adds information to iPtr->errorInfo/errorStack fields to describe the
+ * Invoked after an error occurs in an interpreter.
+ * Adds information to iPtr->errorInfo/errorStack fields to describe the
* command that was being executed when the error occurred. When pc and
* tosPtr are non-NULL, conveying a bytecode execution "inner context",
- * and the offending instruction is suitable, that inner context is
+ * and the offending instruction is suitable, and that inner context is
* recorded in errorStack.
*
* Results:
@@ -4888,8 +4930,9 @@ TclLogCommandInfo(
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
- int length, /* Number of bytes in command (-1 means use
- * all bytes up to first null byte). */
+ Tcl_Size length, /* Number of bytes in command (< 0 means use
+ * all bytes up to first null byte).
+ */
const unsigned char *pc, /* Current pc of bytecode execution context */
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
* context */
@@ -4901,8 +4944,8 @@ TclLogCommandInfo(
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
- * Someone else has already logged error information for this command;
- * we shouldn't add anything more.
+ * Someone else has already logged error information for this command.
+ * Don't add anything more.
*/
return;
@@ -4973,10 +5016,10 @@ TclLogCommandInfo(
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
- int len;
+ Tcl_Size len;
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
@@ -5010,7 +5053,7 @@ TclLogCommandInfo(
*/
Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj(
iPtr->framePtr->level - iPtr->varFramePtr->level));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
/*
@@ -5045,7 +5088,7 @@ void
TclErrorStackResetIf(
Tcl_Interp *interp,
const char *msg,
- int length)
+ Tcl_Size length)
{
Interp *iPtr = (Interp *) interp;
@@ -5058,10 +5101,10 @@ TclErrorStackResetIf(
iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
- int len;
+ Tcl_Size len;
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
@@ -5100,7 +5143,7 @@ Tcl_LogCommandInfo(
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
- int length) /* Number of bytes in command (-1 means use
+ Tcl_Size length) /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
{
TclLogCommandInfo(interp, script, command, length, NULL, NULL);
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 3dbc58b..e511fa1 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -7,9 +7,10 @@
* of the notifier is defined in the tcl*Notify.c files in each platform
* directory.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
- * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1998 Scriptics Corporation.
+ * Copyright © 2003 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2021 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,11 +19,11 @@
#include "tclInt.h"
/*
- * Module-scope struct of notifier hooks that are checked in the default
+ * Notifier hooks that are checked in the public wrappers for the default
* notifier functions (for overriding via Tcl_SetNotifier).
*/
-Tcl_NotifierProcs tclNotifierHooks = {
+static Tcl_NotifierProcs tclNotifierHooks = {
NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL
};
@@ -94,8 +95,8 @@ TCL_DECLARE_MUTEX(listLock)
* Declarations for routines used only in this file.
*/
-static void QueueEvent(ThreadSpecificData *tsdPtr,
- Tcl_Event *evPtr, Tcl_QueuePosition position);
+static int QueueEvent(ThreadSpecificData *tsdPtr,
+ Tcl_Event *evPtr, int position);
/*
*----------------------------------------------------------------------
@@ -174,7 +175,7 @@ TclFinalizeNotifier(void)
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
- return; /* Notifier not initialized for the current thread */
+ return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
@@ -224,9 +225,41 @@ TclFinalizeNotifier(void)
void
Tcl_SetNotifier(
- Tcl_NotifierProcs *notifierProcPtr)
+ const Tcl_NotifierProcs *notifierProcPtr)
{
tclNotifierHooks = *notifierProcPtr;
+
+ /*
+ * Don't allow hooks to refer to the hook point functions; avoids infinite
+ * loop.
+ */
+
+ if (tclNotifierHooks.setTimerProc == Tcl_SetTimer) {
+ tclNotifierHooks.setTimerProc = NULL;
+ }
+ if (tclNotifierHooks.waitForEventProc == Tcl_WaitForEvent) {
+ tclNotifierHooks.waitForEventProc = NULL;
+ }
+ if (tclNotifierHooks.initNotifierProc == Tcl_InitNotifier) {
+ tclNotifierHooks.initNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.finalizeNotifierProc == Tcl_FinalizeNotifier) {
+ tclNotifierHooks.finalizeNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.alertNotifierProc == Tcl_AlertNotifier) {
+ tclNotifierHooks.alertNotifierProc = NULL;
+ }
+ if (tclNotifierHooks.serviceModeHookProc == Tcl_ServiceModeHook) {
+ tclNotifierHooks.serviceModeHookProc = NULL;
+ }
+#ifndef _WIN32
+ if (tclNotifierHooks.createFileHandlerProc == Tcl_CreateFileHandler) {
+ tclNotifierHooks.createFileHandlerProc = NULL;
+ }
+ if (tclNotifierHooks.deleteFileHandlerProc == Tcl_DeleteFileHandler) {
+ tclNotifierHooks.deleteFileHandlerProc = NULL;
+ }
+#endif /* !_WIN32 */
}
/*
@@ -276,7 +309,7 @@ Tcl_CreateEventSource(
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- EventSource *sourcePtr = ckalloc(sizeof(EventSource));
+ EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
@@ -358,8 +391,8 @@ Tcl_QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ 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);
@@ -390,8 +423,8 @@ Tcl_ThreadQueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr;
@@ -410,7 +443,9 @@ Tcl_ThreadQueueEvent(
*/
if (tsdPtr) {
- QueueEvent(tsdPtr, evPtr, position);
+ if (QueueEvent(tsdPtr, evPtr, position)) {
+ Tcl_AlertNotifier(tsdPtr->clientData);
+ }
} else {
ckfree(evPtr);
}
@@ -430,7 +465,8 @@ Tcl_ThreadQueueEvent(
* last-in-first-out order.
*
* Results:
- * None.
+ * For TCL_QUEUE_ALERT_IF_EMPTY the empty state before the
+ * operation is returned.
*
* Side effects:
* None.
@@ -438,7 +474,7 @@ Tcl_ThreadQueueEvent(
*----------------------------------------------------------------------
*/
-static void
+static int
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
@@ -447,11 +483,14 @@ QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK. */
+ 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 (position == TCL_QUEUE_TAIL) {
+ 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.
*/
@@ -463,7 +502,7 @@ QueueEvent(
tsdPtr->lastEventPtr->nextPtr = evPtr;
}
tsdPtr->lastEventPtr = evPtr;
- } else if (position == TCL_QUEUE_HEAD) {
+ } else if ((position & 3) == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
@@ -473,7 +512,7 @@ QueueEvent(
tsdPtr->lastEventPtr = evPtr;
}
tsdPtr->firstEventPtr = evPtr;
- } else if (position == TCL_QUEUE_MARK) {
+ } else if ((position & 3) == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance the
* marker to the new event.
@@ -492,6 +531,7 @@ QueueEvent(
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+ return position & TCL_QUEUE_ALERT_IF_EMPTY;
}
/*
@@ -794,7 +834,7 @@ Tcl_SetServiceMode(
void
Tcl_SetMaxBlockTime(
- const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the
+ const Tcl_Time *timePtr) /* Specifies a maximum elapsed time for the
* next blocking operation in the event
* tsdPtr-> */
{
@@ -1133,6 +1173,260 @@ Tcl_ThreadAlert(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitNotifier --
+ *
+ * Initializes the platform specific notifier state. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * Returns a handle to the notifier state for this thread..
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_InitNotifier(void)
+{
+ if (tclNotifierHooks.initNotifierProc) {
+ return tclNotifierHooks.initNotifierProc();
+ } else {
+ return TclpInitNotifier();
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeNotifier --
+ *
+ * This function is called to cleanup the notifier state before a thread
+ * is terminated. Forwards to the platform implementation when the hook
+ * is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If no finalizeNotifierProc notifier hook exists, TclpFinalizeNotifier
+ * is called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FinalizeNotifier(
+ ClientData clientData)
+{
+ if (tclNotifierHooks.finalizeNotifierProc) {
+ tclNotifierHooks.finalizeNotifierProc(clientData);
+ } else {
+ TclpFinalizeNotifier(clientData);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AlertNotifier --
+ *
+ * Wake up the specified notifier from any thread. This routine is called
+ * by the platform independent notifier code whenever the Tcl_ThreadAlert
+ * routine is called. This routine is guaranteed not to be called by Tcl
+ * on a given notifier after Tcl_FinalizeNotifier is called for that
+ * notifier. This routine is typically called from a thread other than
+ * the notifier's thread. Forwards to the platform implementation when
+ * the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AlertNotifier(
+ ClientData clientData) /* Pointer to thread data. */
+{
+ if (tclNotifierHooks.alertNotifierProc) {
+ tclNotifierHooks.alertNotifierProc(clientData);
+ } else {
+ TclpAlertNotifier(clientData);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ServiceModeHook --
+ *
+ * This function is invoked whenever the service mode changes. Forwards
+ * to the platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ServiceModeHook(
+ int mode) /* Either TCL_SERVICE_ALL, or
+ * TCL_SERVICE_NONE. */
+{
+ if (tclNotifierHooks.serviceModeHookProc) {
+ tclNotifierHooks.serviceModeHookProc(mode);
+ } else {
+ TclpServiceModeHook(mode);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetTimer --
+ *
+ * This function sets the current notifier timer value. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See the platform-specific implementations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetTimer(
+ const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
+{
+ if (tclNotifierHooks.setTimerProc) {
+ tclNotifierHooks.setTimerProc(timePtr);
+ } else {
+ TclpSetTimer(timePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WaitForEvent --
+ *
+ * This function is called by Tcl_DoOneEvent to wait for new events on
+ * the notifier's message queue. If the block time is 0, then
+ * Tcl_WaitForEvent just polls without blocking. Forwards to the
+ * platform implementation when the hook is not enabled.
+ *
+ * Results:
+ * Returns -1 if the wait would block forever, 1 if an out-of-loop source
+ * was processed (see platform-specific notes) and otherwise returns 0.
+ *
+ * Side effects:
+ * Queues file events that are detected by the notifier.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_WaitForEvent(
+ const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
+{
+ if (tclNotifierHooks.waitForEventProc) {
+ return tclNotifierHooks.waitForEventProc(timePtr);
+ } else {
+ return TclpWaitForEvent(timePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateFileHandler --
+ *
+ * This function registers a file descriptor handler with the notifier.
+ * Forwards to the platform implementation when the hook is not enabled.
+ *
+ * This function is not defined on Windows. The OS API there is too
+ * different.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new file handler structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef _WIN32
+void
+Tcl_CreateFileHandler(
+ 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. */
+ ClientData clientData) /* Arbitrary data to pass to proc. */
+{
+ if (tclNotifierHooks.createFileHandlerProc) {
+ tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData);
+ } else {
+ TclpCreateFileHandler(fd, mask, proc, clientData);
+ }
+}
+#endif /* !_WIN32 */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for a file
+ * descriptor. Forwards to the platform implementation when the hook is
+ * not enabled.
+ *
+ * This function is not defined on Windows. The OS API there is too
+ * different.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on the file descriptor, remove
+ * it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef _WIN32
+void
+Tcl_DeleteFileHandler(
+ int fd) /* Stream id for which to remove callback
+ * function. */
+{
+ if (tclNotifierHooks.deleteFileHandlerProc) {
+ tclNotifierHooks.deleteFileHandlerProc(fd);
+ } else {
+ TclpDeleteFileHandler(fd);
+ }
+}
+#endif /* !_WIN32 */
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4efdd9e..a65dc8f 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -3,8 +3,8 @@
*
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
- * Copyright (c) 2005-2012 by Donal K. Fellows
- * Copyright (c) 2017 by Nathan Coulter
+ * Copyright © 2005-2019 Donal K. Fellows
+ * Copyright © 2017 Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -26,11 +26,13 @@ static const struct {
int flag;
} defineCmds[] = {
{"constructor", TclOODefineConstructorObjCmd, 0},
+ {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
+ {"private", TclOODefinePrivateObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
@@ -41,7 +43,9 @@ static const struct {
{"export", TclOODefineExportObjCmd, 1},
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
+ {"private", TclOODefinePrivateObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+ {"self", TclOODefineObjSelfObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 1},
{NULL, NULL, 0}
};
@@ -63,37 +67,34 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
Method **newMPtrPtr);
static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
Method *mPtr, Tcl_Obj *namePtr);
-static void DeletedDefineNamespace(ClientData clientData);
-static void DeletedObjdefNamespace(ClientData clientData);
-static void DeletedHelpersNamespace(ClientData clientData);
+static void DeletedDefineNamespace(void *clientData);
+static void DeletedObjdefNamespace(void *clientData);
+static void DeletedHelpersNamespace(void *clientData);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
static Tcl_NRPostProc FinalizeObjectCall;
-static void initClassPath(Tcl_Interp * interp, Class *clsPtr);
+static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr);
+static void InitClassSystemRoots(Tcl_Interp *interp,
+ Foundation *fPtr);
static int InitFoundation(Tcl_Interp *interp);
-static void KillFoundation(ClientData clientData,
- Tcl_Interp *interp);
-static void MyDeleted(ClientData clientData);
-static void ObjectNamespaceDeleted(ClientData clientData);
-static void ObjectRenamedTrace(ClientData clientData,
- Tcl_Interp *interp, const char *oldName,
- const char *newName, int flags);
+static Tcl_InterpDeleteProc KillFoundation;
+static void MyDeleted(void *clientData);
+static void ObjectNamespaceDeleted(void *clientData);
+static Tcl_CommandTraceProc ObjectRenamedTrace;
+static inline void RemoveClass(Class **list, int num, int idx);
+static inline void RemoveObject(Object **list, int num, int idx);
static inline void SquelchCachedName(Object *oPtr);
-static int PublicObjectCmd(ClientData clientData,
+static int PublicNRObjectCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PublicNRObjectCmd(ClientData clientData,
+static int PrivateNRObjectCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateObjectCmd(ClientData clientData,
+static int MyClassNRObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateNRObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-static void RemoveClass(Class ** list, int num, int idx);
-static void RemoveObject(Object ** list, int num, int idx);
+static void MyClassDeleted(void *clientData);
/*
* Methods in the oo::object and oo::class classes. First, we define a helper
@@ -137,72 +138,20 @@ static const Tcl_MethodType classConstructor = {
*/
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" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
- * The scripted part of the definitions of slots.
+ * The scripted part of the definitions of TclOO.
*/
-static const char *slotScript =
-"::oo::define ::oo::Slot {\n"
-" method Get {} {error unimplemented}\n"
-" method Set list {error unimplemented}\n"
-" method -set args {\n"
-" uplevel 1 [list [namespace which my] Set $args]\n"
-" }\n"
-" method -append args {\n"
-" uplevel 1 [list [namespace which my] Set [list"
-" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
-" }\n"
-" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
-" forward --default-operation my -append\n"
-" method unknown {args} {\n"
-" set def --default-operation\n"
-" if {[llength $args] == 0} {\n"
-" return [uplevel 1 [list [namespace which my] $def]]\n"
-" } elseif {![string match -* [lindex $args 0]]} {\n"
-" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
-" }\n"
-" next {*}$args\n"
-" }\n"
-" export -set -append -clear\n"
-" unexport unknown destroy\n"
-"}\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
-"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
-
-/*
- * The body of the <cloned> method of oo::object.
- */
-
-static const char *clonedBody =
-"foreach p [info procs [info object namespace $originObject]::*] {"
-" set args [info args $p];"
-" set idx -1;"
-" foreach a $args {"
-" lset args [incr idx] "
-" [if {[info default $p $a d]} {list $a $d} {list $a}]"
-" };"
-" set b [info body $p];"
-" set p [namespace tail $p];"
-" proc $p $args $b;"
-"};"
-"foreach v [info vars [info object namespace $originObject]::*] {"
-" upvar 0 $v vOrigin;"
-" namespace upvar [namespace current] [namespace tail $v] vNew;"
-" if {[info exists vOrigin]} {"
-" if {[array exists vOrigin]} {"
-" array set vNew [array get vOrigin];"
-" } else {"
-" set vNew $vOrigin;"
-" }"
-" }"
-"}";
+#include "tclOOScript.h"
/*
* The actual definition of the variable holding the TclOO stub table.
@@ -232,14 +181,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
#define RemoveItem(type, lst, i) \
- do { \
- Remove ## type ((lst).list, (lst).num, i); \
- (lst).num--; \
+ do { \
+ Remove ## type ((lst).list, (lst).num, i); \
+ (lst).num--; \
} while (0)
/*
* ----------------------------------------------------------------------
*
+ * RemoveClass, RemoveObject --
+ *
+ * Helpers for the RemoveItem macro for deleting a class or object from a
+ * list. Setting the "empty" location to NULL makes debugging a little
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RemoveClass(
+ Class **list,
+ int num,
+ int idx)
+{
+ for (; idx + 1 < num; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+static inline void
+RemoveObject(
+ Object **list,
+ int num,
+ int idx)
+{
+ for (; idx + 1 < num; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOInit --
*
* Called to initialise the OO system within an interpreter.
@@ -271,11 +256,15 @@ TclOOInit(
* to be fully provided.
*/
- if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ if (Tcl_EvalEx(interp, initScript, TCL_INDEX_NONE, 0) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
+#ifndef TCL_NO_DEPRECATED
+ Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
+ &tclOOStubs);
+#endif
+ return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
@@ -314,13 +303,9 @@ InitFoundation(
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
- Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
- Foundation *fPtr = ckalloc(sizeof(Foundation));
- Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
-
- Class fakeCls;
- Object fakeObject;
-
+ (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation));
+ Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
@@ -342,6 +327,7 @@ InitFoundation(
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
+ Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
@@ -383,29 +369,99 @@ InitFoundation(
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
- * Create the objects at the core of the object system. These need to be
- * spliced manually.
+ * Create the special objects at the core of the object system.
*/
+ InitClassSystemRoots(interp, fPtr);
+
/*
- * Stand up a phony class for bootstrapping.
+ * Basic method declarations for the core classes.
*/
- fPtr->objectCls = &fakeCls;
+ for (i = 0 ; objMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
+ }
+ for (i = 0 ; clsMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
+ }
/*
- * Referenced in TclOOAllocClass to increment the refCount.
+ * 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");
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
+ fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
+ NULL, TclOONextObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextCmd;
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+ NULL, TclOONextToObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextToCmd;
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+ TclOOSelfObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectSelfCmd;
+ Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
+ TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
*/
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Evaluate the remaining definitions, which are a compiled-in Tcl script.
+ */
+
+ return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitClassSystemRoots --
+ *
+ * Creates the objects at the core of the object system. These need to be
+ * spliced manually.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InitClassSystemRoots(
+ Tcl_Interp *interp,
+ Foundation *fPtr)
+{
+ Class fakeCls;
+ Object fakeObject;
+ Tcl_Obj *defNsName;
+
+ /* Stand up a phony class for bootstrapping. */
+ fPtr->objectCls = &fakeCls;
+ /* referenced in TclOOAllocClass to increment the refCount. */
fakeCls.thisPtr = &fakeObject;
fakeObject.refCount = 0; /* Do not increment an uninitialized value. */
fPtr->objectCls = TclOOAllocClass(interp,
AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
- /*
- * Corresponding TclOODecrRefCount in KillFoudation.
- */
-
+ /* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->objectCls->thisPtr);
/*
@@ -424,14 +480,13 @@ InitFoundation(
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
+ TclNewLiteralStringObj(defNsName, "::oo::objdefine");
+ fPtr->objectCls->objDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
fPtr->classCls = TclOOAllocClass(interp,
AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
-
- /*
- * Corresponding TclOODecrRefCount in KillFoudation.
- */
-
+ /* Corresponding TclOODecrRefCount in KillFoudation */
AddRef(fPtr->classCls->thisPtr);
/*
@@ -456,77 +511,17 @@ InitFoundation(
fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
fPtr->classCls->flags |= ROOT_CLASS;
+ TclNewLiteralStringObj(defNsName, "::oo::define");
+ fPtr->classCls->clsDefinitionNs = defNsName;
+ Tcl_IncrRefCount(defNsName);
- /*
- * Standard initialization for new Objects.
- */
-
+ /* Standard initialization for new Objects */
TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
/*
- * Basic method declarations for the core classes.
- */
-
- for (i = 0 ; objMethods[i].name ; i++) {
- TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
- }
- for (i = 0 ; clsMethods[i].name ; i++) {
- TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
- }
-
- /*
- * Create the default <cloned> method implementation, used when 'oo::copy'
- * is called to finish the copying of one object to another.
- */
-
- TclNewLiteralStringObj(argsPtr, "originObject");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(clonedBody, -1);
- TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
- bodyPtr, NULL);
- TclDecrRefCount(argsPtr);
-
- /*
- * 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");
- Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
- namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
- fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
- (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
-
- /*
- * Create non-object commands and plug ourselves into the Tcl [info]
- * ensemble.
- */
-
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
- NULL, TclOONextObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextCmd;
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
- NULL, TclOONextToObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectNextToCmd;
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
- TclOOSelfObjCmd, NULL, NULL);
- cmdPtr->compileProc = TclCompileObjectSelfCmd;
- Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
- TclOOInitInfo(interp);
-
- /*
- * Now make the class of slots.
+ * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
+ * Everything else is careful to prohibit looping.
*/
-
- if (TclOODefineSlots(fPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- return Tcl_Eval(interp, slotScript);
}
/*
@@ -542,27 +537,27 @@ InitFoundation(
static void
DeletedDefineNamespace(
- ClientData clientData)
+ void *clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
static void
DeletedObjdefNamespace(
- ClientData clientData)
+ void *clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
static void
DeletedHelpersNamespace(
- ClientData clientData)
+ void *clientData)
{
- Foundation *fPtr = clientData;
+ Foundation *fPtr = (Foundation *)clientData;
fPtr->helpersNs = NULL;
}
@@ -580,10 +575,9 @@ DeletedHelpersNamespace(
static void
KillFoundation(
- ClientData clientData, /* Pointer to the OO system foundation
- * structure. */
- Tcl_Interp *interp) /* The interpreter containing the OO system
- * foundation. */
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
{
Foundation *fPtr = GetFoundation(interp);
@@ -621,8 +615,8 @@ AllocObject(
* if the OO system should pick the object
* name itself (equal to the namespace
* name). */
- Namespace *nsPtr, /* The namespace to create the object in,
- or NULL if *nameStr is NULL */
+ Namespace *nsPtr, /* The namespace to create the object in, or
+ * NULL if *nameStr is NULL */
const char *nsNameStr) /* The name of the namespace to create, or
* NULL if the OO system should pick a unique
* name itself. If this is non-NULL but names
@@ -635,7 +629,7 @@ AllocObject(
CommandTrace *tracePtr;
int creationEpoch;
- oPtr = ckalloc(sizeof(Object));
+ oPtr = (Object *)ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
@@ -719,8 +713,8 @@ AllocObject(
* destruction it occur: A call to ObjectRenamedTrace(), and a call to
* ObjectNamespaceDeleted().
*/
- oPtr->refCount = 2;
+ oPtr->refCount = 2;
oPtr->flags = USE_CLASS_CACHE;
/*
@@ -735,10 +729,9 @@ AllocObject(
if (nsPtr->parentPtr != NULL) {
nsPtr = nsPtr->parentPtr;
}
-
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
- (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
+ (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -747,7 +740,7 @@ AllocObject(
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
- cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
+ cmdPtr->tracePtr = tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = ObjectRenamedTrace;
tracePtr->clientData = oPtr;
tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
@@ -755,7 +748,10 @@ AllocObject(
tracePtr->refCount = 1;
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
- PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
+ oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
+ MyClassDeleted);
return oPtr;
}
@@ -783,25 +779,33 @@ SquelchCachedName(
/*
* ----------------------------------------------------------------------
*
- * MyDeleted --
+ * MyDeleted, MyClassDeleted --
*
- * This callback is triggered when the object's [my] command is deleted
- * by any mechanism. It just marks the object as not having a [my]
- * command, and so prevents cleanup of that when the object itself is
- * deleted.
+ * These callbacks are triggered when the object's [my] or [myclass]
+ * commands are deleted by any mechanism. They just mark the object as
+ * not having a [my] command or [myclass] command, and so prevent cleanup
+ * of those commands when the object itself is deleted.
*
* ----------------------------------------------------------------------
*/
static void
MyDeleted(
- ClientData clientData) /* Reference to the object whose [my] has been
+ void *clientData) /* Reference to the object whose [my] has been
* squelched. */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ void *clientData)
+{
+ Object *oPtr = (Object *)clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -818,13 +822,14 @@ MyDeleted(
static void
ObjectRenamedTrace(
- ClientData clientData, /* The object being deleted. */
- Tcl_Interp *interp, /* The interpreter containing the object. */
- const char *oldName, /* What the object was (last) called. */
- const char *newName, /* What it's getting renamed to. (unused) */
+ void *clientData, /* The object being deleted. */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(const char *) /*oldName*/,
+ TCL_UNUSED(const char *) /*newName*/,
int flags) /* Why was the object deleted? */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
+
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -892,6 +897,7 @@ TclOODeleteDescendants(
ckfree(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
+
/*
* Squelch subclasses of this class.
*/
@@ -956,11 +962,12 @@ TclOOReleaseClassContents(
Object *oPtr) /* The object representing the class. */
{
FOREACH_HASH_DECLS;
- int i;
+ Tcl_Size i;
Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
- Tcl_Obj *variableObj;
+ Tcl_Obj *variableObj, *propertyObj;
+ PrivateVariableMapping *privateVariable;
/*
* Sanity check!
@@ -977,6 +984,19 @@ TclOOReleaseClassContents(
}
/*
+ * Stop using the class for definition information.
+ */
+
+ if (clsPtr->clsDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->clsDefinitionNs);
+ clsPtr->clsDefinitionNs = NULL;
+ }
+ if (clsPtr->objDefinitionNs) {
+ Tcl_DecrRefCount(clsPtr->objDefinitionNs);
+ clsPtr->objDefinitionNs = NULL;
+ }
+
+ /*
* Squelch method implementation chain caches.
*/
@@ -1000,6 +1020,29 @@ TclOOReleaseClassContents(
}
/*
+ * Squelch the property lists.
+ */
+
+ if (clsPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
+ }
+ if (clsPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
+ }
+ if (clsPtr->properties.readable.num) {
+ FOREACH(propertyObj, clsPtr->properties.readable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(clsPtr->properties.readable.list);
+ }
+ if (clsPtr->properties.writable.num) {
+ FOREACH(propertyObj, clsPtr->properties.writable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(clsPtr->properties.writable.list);
+ }
+
+ /*
* Squelch our filter list.
*/
@@ -1020,7 +1063,7 @@ TclOOReleaseClassContents(
if (clsPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
+ void *value;
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
@@ -1064,6 +1107,14 @@ TclOOReleaseClassContents(
ckfree(clsPtr->variables.list);
}
+ FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
+ TclDecrRefCount(privateVariable->variableObj);
+ TclDecrRefCount(privateVariable->fullNameObj);
+ }
+ if (i) {
+ ckfree(clsPtr->privateVariables.list);
+ }
+
if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
@@ -1084,23 +1135,25 @@ TclOOReleaseClassContents(
static void
ObjectNamespaceDeleted(
- ClientData clientData) /* Pointer to the class whose namespace is
+ void *clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
- Object *oPtr = clientData;
+ Object *oPtr = (Object *)clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
- Tcl_Obj *filterObj, *variableObj;
+ Tcl_Obj *filterObj, *variableObj, *propertyObj;
+ PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
- int i;
+ Tcl_Size i;
if (Destructing(oPtr)) {
/*
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
+
return;
}
@@ -1109,6 +1162,7 @@ ObjectNamespaceDeleted(
* process of being deleted, nothing else may modify its bookkeeping
* records. This is the flag that
*/
+
oPtr->flags |= OBJECT_DESTRUCTING;
/*
@@ -1128,7 +1182,7 @@ ObjectNamespaceDeleted(
if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
- TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
int result;
Tcl_InterpState state;
@@ -1155,7 +1209,7 @@ ObjectNamespaceDeleted(
* freed memory.
*/
- if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
+ if (((Command *) oPtr->command)->flags && CMD_DYING) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the namespace,
@@ -1169,6 +1223,9 @@ ObjectNamespaceDeleted(
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
+ if (oPtr->myclassCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+ }
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -1213,6 +1270,14 @@ ObjectNamespaceDeleted(
ckfree(oPtr->variables.list);
}
+ FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
+ TclDecrRefCount(privateVariable->variableObj);
+ TclDecrRefCount(privateVariable->fullNameObj);
+ }
+ if (i) {
+ ckfree(oPtr->privateVariables.list);
+ }
+
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
@@ -1221,7 +1286,7 @@ ObjectNamespaceDeleted(
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
+ void *value;
FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
@@ -1232,6 +1297,29 @@ ObjectNamespaceDeleted(
}
/*
+ * Squelch the property lists.
+ */
+
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ }
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ }
+ if (oPtr->properties.readable.num) {
+ FOREACH(propertyObj, oPtr->properties.readable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(oPtr->properties.readable.list);
+ }
+ if (oPtr->properties.writable.num) {
+ FOREACH(propertyObj, oPtr->properties.writable) {
+ Tcl_DecrRefCount(propertyObj);
+ }
+ ckfree(oPtr->properties.writable.list);
+ }
+
+ /*
* Because an object can be a class that is an instance of itself, the
* class object's class structure should only be cleaned after most of
* the cleanup on the object is done.
@@ -1245,7 +1333,6 @@ ObjectNamespaceDeleted(
if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
&& !Tcl_InterpDeleted(interp)) {
-
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1268,7 +1355,7 @@ ObjectNamespaceDeleted(
/*
* ----------------------------------------------------------------------
*
- * TclOODecrRef --
+ * TclOODecrRefCount --
*
* Decrement the refcount of an object and deallocate storage then object
* is no longer referenced. Returns 1 if storage was deallocated, and 0
@@ -1276,8 +1363,13 @@ ObjectNamespaceDeleted(
*
* ----------------------------------------------------------------------
*/
-int TclOODecrRefCount(Object *oPtr) {
+
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
if (oPtr->refCount-- <= 1) {
+
if (oPtr->classPtr != NULL) {
ckfree(oPtr->classPtr);
}
@@ -1302,21 +1394,6 @@ int TclOOObjectDestroyed(Object *oPtr) {
}
/*
- * Setting the "empty" location to NULL makes debugging a little easier.
- */
-
-#define REMOVEBODY { \
- for (; idx < num - 1; idx++) { \
- list[idx] = list[idx + 1]; \
- } \
- list[idx] = NULL; \
- return; \
-}
-void RemoveClass(Class **list, int num, int idx) REMOVEBODY
-
-void RemoveObject(Object **list, int num, int idx) REMOVEBODY
-
-/*
* ----------------------------------------------------------------------
*
* TclOORemoveFromInstances --
@@ -1333,7 +1410,8 @@ TclOORemoveFromInstances(
Class *clsPtr) /* The class (possibly) containing the
* reference to the instance. */
{
- int i, res = 0;
+ Tcl_Size i;
+ int res = 0;
Object *instPtr;
FOREACH(instPtr, clsPtr->instances) {
@@ -1368,9 +1446,9 @@ TclOOAddToInstances(
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
- clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+ clsPtr->instances.list = (Object **)ckalloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
- clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
+ clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list,
sizeof(Object *) * clsPtr->instances.size);
}
}
@@ -1395,7 +1473,8 @@ TclOORemoveFromMixins(
Object *oPtr) /* The object (possibly) containing the
* reference to the mixin. */
{
- int i, res = 0;
+ Tcl_Size i;
+ int res = 0;
Class *mixPtr;
FOREACH(mixPtr, oPtr->mixins) {
@@ -1430,7 +1509,8 @@ TclOORemoveFromSubclasses(
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i, res = 0;
+ Tcl_Size i;
+ int res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->subclasses) {
@@ -1467,9 +1547,9 @@ TclOOAddToSubclasses(
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
- superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ superPtr->subclasses.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
+ superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
@@ -1494,7 +1574,8 @@ TclOORemoveFromMixinSubs(
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i, res = 0;
+ Tcl_Size i;
+ int res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->mixinSubs) {
@@ -1532,9 +1613,9 @@ TclOOAddToMixinSubs(
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
- superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ superPtr->mixinSubs.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
- superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
+ superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list,
sizeof(Class *) * superPtr->mixinSubs.size);
}
}
@@ -1553,6 +1634,25 @@ TclOOAddToMixinSubs(
* ----------------------------------------------------------------------
*/
+static inline void
+InitClassPath(
+ Tcl_Interp *interp,
+ Class *clsPtr)
+{
+ Foundation *fPtr = GetFoundation(interp);
+
+ if (fPtr->helpersNs != NULL) {
+ Tcl_Namespace *path[2];
+
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+ } else {
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
+ &fPtr->ooNs);
+ }
+}
+
Class *
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
@@ -1561,7 +1661,7 @@ TclOOAllocClass(
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
- Class *clsPtr = ckalloc(sizeof(Class));
+ Class *clsPtr = (Class *)ckalloc(sizeof(Class));
memset(clsPtr, 0, sizeof(Class));
clsPtr->thisPtr = useThisObj;
@@ -1569,7 +1669,8 @@ TclOOAllocClass(
/*
* Configure the namespace path for the class's object.
*/
- initClassPath(interp, clsPtr);
+
+ InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
@@ -1577,7 +1678,7 @@ TclOOAllocClass(
*/
clsPtr->superclasses.num = 1;
- clsPtr->superclasses.list = ckalloc(sizeof(Class *));
+ clsPtr->superclasses.list = (Class **)ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
@@ -1595,19 +1696,6 @@ TclOOAllocClass(
Tcl_InitObjHashTable(&clsPtr->classMethods);
return clsPtr;
}
-static void
-initClassPath(Tcl_Interp *interp, Class *clsPtr) {
- Foundation *fPtr = GetFoundation(interp);
- if (fPtr->helpersNs != NULL) {
- Tcl_Namespace *path[2];
- path[0] = fPtr->helpersNs;
- path[1] = fPtr->ooNs;
- TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
- } else {
- TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
- &fPtr->ooNs);
- }
-}
/*
* ----------------------------------------------------------------------
@@ -1627,18 +1715,20 @@ Tcl_NewObjectInstance(
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
- int objc, /* Number of arguments. Negative value means
+ Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
- int skip) /* Number of arguments to _not_ pass to the
+ Tcl_Size skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
Class *classPtr = (Class *) cls;
Object *oPtr;
- ClientData clientData[4];
+ void *clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return NULL;}
+ if (oPtr == NULL) {
+ return NULL;
+ }
/*
* Run constructors, except when objc < 0, which is a special flag case
@@ -1647,7 +1737,7 @@ Tcl_NewObjectInstance(
if (objc >= 0) {
CallContext *contextPtr =
- TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr != NULL) {
int isRoot, result;
@@ -1693,10 +1783,10 @@ TclNRNewObjectInstance(
const char *nsNameStr, /* Name of namespace to create inside object,
* or NULL to ask the code to pick its own
* unique name. */
- int objc, /* Number of arguments. Negative value means
+ Tcl_Size objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
- int skip, /* Number of arguments to _not_ pass to the
+ Tcl_Size skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
@@ -1707,7 +1797,9 @@ TclNRNewObjectInstance(
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return TCL_ERROR;}
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1718,7 +1810,7 @@ TclNRNewObjectInstance(
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
}
- contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
if (contextPtr == NULL) {
*objectPtr = (Tcl_Object) oPtr;
return TCL_OK;
@@ -1757,8 +1849,8 @@ TclNewObjectInstanceCommon(
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
const char *simpleName = NULL;
- Namespace *nsPtr = NULL, *dummy,
- *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = NULL, *dummy;
+ Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (nameStr) {
TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
@@ -1773,7 +1865,7 @@ TclNewObjectInstanceCommon(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
- Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", (void *)NULL);
return NULL;
}
}
@@ -1810,24 +1902,24 @@ TclNewObjectInstanceCommon(
static int
FinalizeAlloc(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = data[0];
- Object *oPtr = data[1];
- Tcl_InterpState state = data[2];
- Tcl_Object *objectPtr = data[3];
+ CallContext *contextPtr = (CallContext *)data[0];
+ Object *oPtr = (Object *)data[1];
+ Tcl_InterpState state = (Tcl_InterpState)data[2];
+ Tcl_Object *objectPtr = (Tcl_Object *)data[3];
/*
- * Ensure an error if the object was deleted in the constructor.
- * Don't want to lose errors by accident. [Bug 2903011]
+ * Ensure an error if the object was deleted in the constructor. Don't
+ * want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Destructing(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (void *)NULL);
result = TCL_ERROR;
}
if (result != TCL_OK) {
@@ -1887,7 +1979,9 @@ Tcl_CopyObjectInstance(
Class *mixinPtr;
CallContext *contextPtr;
Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
- int i, result;
+ PrivateVariableMapping *privateVariable;
+ Tcl_Size i;
+ int result;
/*
* Sanity check.
@@ -1896,7 +1990,7 @@ Tcl_CopyObjectInstance(
if (IsRootClass(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not clone the class of classes", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (void *)NULL);
return NULL;
}
@@ -1905,7 +1999,7 @@ Tcl_CopyObjectInstance(
*/
o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
- (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1,
+ (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, TCL_INDEX_NONE,
NULL, -1);
if (o2Ptr == NULL) {
return NULL;
@@ -1960,7 +2054,7 @@ Tcl_CopyObjectInstance(
}
/*
- * Copy the object's variable resolution list to the new object.
+ * Copy the object's variable resolution lists to the new object.
*/
DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
@@ -1968,6 +2062,13 @@ Tcl_CopyObjectInstance(
Tcl_IncrRefCount(variableObj);
}
+ DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
+ PrivateVariableMapping);
+ FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
+ Tcl_IncrRefCount(privateVariable->variableObj);
+ Tcl_IncrRefCount(privateVariable->fullNameObj);
+ }
+
/*
* Copy the object's flags to the new object, clearing those that must be
* kept object-local. The duplicate is never deleted at this point, nor is
@@ -1984,7 +2085,7 @@ Tcl_CopyObjectInstance(
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value, duplicate;
+ void *value, *duplicate;
FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
if (metadataTypePtr->cloneProc == NULL) {
@@ -2029,11 +2130,11 @@ Tcl_CopyObjectInstance(
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
- cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
+ cls2Ptr->superclasses.list = (Class **)ckrealloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list =
- ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
+ (Class **)ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
@@ -2059,7 +2160,7 @@ Tcl_CopyObjectInstance(
}
/*
- * Copy the source class's variable resolution list.
+ * Copy the source class's variable resolution lists.
*/
DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
@@ -2067,6 +2168,13 @@ Tcl_CopyObjectInstance(
Tcl_IncrRefCount(variableObj);
}
+ DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
+ PrivateVariableMapping);
+ FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
+ Tcl_IncrRefCount(privateVariable->variableObj);
+ Tcl_IncrRefCount(privateVariable->fullNameObj);
+ }
+
/*
* Duplicate the source class's mixins (which cannot be circular
* references to the duplicate).
@@ -2122,7 +2230,7 @@ Tcl_CopyObjectInstance(
if (clsPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value, duplicate;
+ void *value, *duplicate;
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
if (metadataTypePtr->cloneProc == NULL) {
@@ -2143,7 +2251,8 @@ Tcl_CopyObjectInstance(
}
TclResetRewriteEnsemble(interp, 1);
- contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
+ NULL, NULL);
if (contextPtr) {
args[0] = TclOOObjectName(interp, o2Ptr);
args[1] = oPtr->fPtr->clonedName;
@@ -2193,7 +2302,7 @@ CloneObjectMethod(
Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
- ClientData newClientData;
+ void *newClientData;
if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
&newClientData) != TCL_OK) {
@@ -2222,7 +2331,7 @@ CloneClassMethod(
m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
- ClientData newClientData;
+ void *newClientData;
if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
&newClientData) != TCL_OK) {
@@ -2268,7 +2377,7 @@ CloneClassMethod(
* ----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_ClassGetMetadata(
Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr)
@@ -2305,7 +2414,7 @@ void
Tcl_ClassSetMetadata(
Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata)
+ void *metadata)
{
Class *clsPtr = (Class *) clazz;
Tcl_HashEntry *hPtr;
@@ -2319,7 +2428,7 @@ Tcl_ClassSetMetadata(
if (metadata == NULL) {
return;
}
- clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2348,7 +2457,7 @@ Tcl_ClassSetMetadata(
Tcl_SetHashValue(hPtr, metadata);
}
-ClientData
+void *
Tcl_ObjectGetMetadata(
Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr)
@@ -2385,7 +2494,7 @@ void
Tcl_ObjectSetMetadata(
Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata)
+ void *metadata)
{
Object *oPtr = (Object *) object;
Tcl_HashEntry *hPtr;
@@ -2399,7 +2508,7 @@ Tcl_ObjectSetMetadata(
if (metadata == NULL) {
return;
}
- oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
@@ -2431,7 +2540,7 @@ Tcl_ObjectSetMetadata(
/*
* ----------------------------------------------------------------------
*
- * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject --
*
* Main entry point for object invocations. The Public* and Private*
* wrapper functions (implementations of both object instance commands
@@ -2441,9 +2550,9 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
- ClientData clientData,
+int
+TclOOPublicObjectCmd(
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2453,18 +2562,18 @@ PublicObjectCmd(
static int
PublicNRObjectCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
+ return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
NULL);
}
-static int
-PrivateObjectCmd(
- ClientData clientData,
+int
+TclOOPrivateObjectCmd(
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -2474,12 +2583,12 @@ PrivateObjectCmd(
static int
PrivateNRObjectCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
+ return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
}
int
@@ -2495,7 +2604,7 @@ TclOOInvokeObject(
* (PRIVATE_METHOD), or a *really* private
* context (any other value; conventionally
* 0). */
- int objc, /* Number of arguments. */
+ Tcl_Size 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. */
@@ -2516,6 +2625,43 @@ TclOOInvokeObject(
/*
* ----------------------------------------------------------------------
*
+ * TclOOMyClassObjCmd, MyClassNRObjCmd --
+ *
+ * Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOMyClassObjCmd(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *)clientData;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+ return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
+ NULL);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOObjectCmdCore, FinalizeObjectCall --
*
* Main function for object invocations. Does call chain creation,
@@ -2529,7 +2675,7 @@ int
TclOOObjectCmdCore(
Object *oPtr, /* The object being invoked. */
Tcl_Interp *interp, /* The interpreter containing the object. */
- int objc, /* How many arguments are being passed in. */
+ Tcl_Size 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. */
@@ -2540,6 +2686,9 @@ TclOOObjectCmdCore(
{
CallContext *contextPtr;
Tcl_Obj *methodNamePtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+ Object *callerObjPtr = NULL;
+ Class *callerClsPtr = NULL;
int result;
/*
@@ -2554,6 +2703,24 @@ TclOOObjectCmdCore(
}
/*
+ * Determine if we're in a context that can see the extra, private methods
+ * in this class.
+ */
+
+ if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+ CallContext *callerContextPtr = (CallContext *)framePtr->clientData;
+ Method *callerMethodPtr =
+ callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
+
+ if (callerMethodPtr->declaringObjectPtr) {
+ callerObjPtr = callerMethodPtr->declaringObjectPtr;
+ }
+ if (callerMethodPtr->declaringClassPtr) {
+ callerClsPtr = callerMethodPtr->declaringClassPtr;
+ }
+ }
+
+ /*
* Give plugged in code a chance to remap the method name.
*/
@@ -2580,14 +2747,15 @@ TclOOObjectCmdCore(
Tcl_IncrRefCount(mappedMethodName);
contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
- flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+ flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+ callerClsPtr, methodNamePtr);
TclDecrRefCount(mappedMethodName);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
- TclGetString(methodNamePtr), NULL);
+ TclGetString(methodNamePtr), (void *)NULL);
return TCL_ERROR;
}
} else {
@@ -2597,13 +2765,14 @@ TclOOObjectCmdCore(
noMapping:
contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
- flags | (oPtr->flags & FILTER_HANDLING), NULL);
+ flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
+ callerClsPtr, NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"impossible to invoke method \"%s\": no defined method or"
" unknown method", TclGetString(methodNamePtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(methodNamePtr), NULL);
+ TclGetString(methodNamePtr), (void *)NULL);
return TCL_ERROR;
}
}
@@ -2630,7 +2799,7 @@ TclOOObjectCmdCore(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"no valid method implementation", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(methodNamePtr), NULL);
+ TclGetString(methodNamePtr), (void *)NULL);
TclOODeleteContext(contextPtr);
return TCL_ERROR;
}
@@ -2647,8 +2816,8 @@ TclOOObjectCmdCore(
static int
FinalizeObjectCall(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
/*
@@ -2656,7 +2825,7 @@ FinalizeObjectCall(
* structure.
*/
- TclOODeleteContext(data[0]);
+ TclOODeleteContext((CallContext *)data[0]);
return result;
}
@@ -2678,9 +2847,9 @@ int
Tcl_ObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const *objv,
- int skip)
+ Tcl_Size skip)
{
CallContext *contextPtr = (CallContext *) context;
int savedIndex = contextPtr->index;
@@ -2711,7 +2880,7 @@ Tcl_ObjectContextInvokeNext(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
- Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL);
return TCL_ERROR;
}
@@ -2750,9 +2919,9 @@ int
TclNRObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const *objv,
- int skip)
+ Tcl_Size skip)
{
CallContext *contextPtr = (CallContext *) context;
@@ -2780,7 +2949,7 @@ TclNRObjectContextInvokeNext(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no next %s implementation", methodType));
- Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL);
return TCL_ERROR;
}
@@ -2808,11 +2977,11 @@ TclNRObjectContextInvokeNext(
static int
FinalizeNext(
- ClientData data[],
- Tcl_Interp *interp,
+ void *data[],
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
@@ -2847,19 +3016,19 @@ Tcl_GetObjectFromObj(
if (cmdPtr == NULL) {
goto notAnObject;
}
- if (cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
- return cmdPtr->objClientData;
+ return (Tcl_Object)cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
- NULL);
+ (void *)NULL);
return NULL;
}
@@ -2879,7 +3048,7 @@ TclOOIsReachable(
Class *targetPtr,
Class *startPtr)
{
- int i;
+ Tcl_Size i;
Class *superPtr;
tailRecurse:
@@ -2972,7 +3141,7 @@ Tcl_ObjectContextObject(
return (Tcl_Object) ((CallContext *)context)->oPtr;
}
-int
+Tcl_Size
Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context)
{
@@ -3028,6 +3197,26 @@ Tcl_ObjectSetMethodNameMapper(
{
((Object *) object)->mapMethodNameProc = mapMethodNameProc;
}
+
+Tcl_Class
+Tcl_GetClassOfObject(
+ Tcl_Object object)
+{
+ return (Tcl_Class) ((Object *) object)->selfCls;
+}
+
+Tcl_Obj *
+Tcl_GetObjectClassName(
+ Tcl_Interp *interp,
+ Tcl_Object object)
+{
+ Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr;
+
+ if (classObj == NULL) {
+ return NULL;
+ }
+ return Tcl_GetObjectName(interp, classObj);
+}
/*
* Local Variables:
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 67b1996..913d76c 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -58,18 +58,18 @@ declare 10 {
}
declare 11 {
Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
- Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
void *clientData)
}
declare 12 {
Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
- Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
+ 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, int objc,
- Tcl_Obj *const *objv, int skip)
+ const char *nameStr, const char *nsNameStr, Tcl_Size objc,
+ Tcl_Obj *const *objv, Tcl_Size skip)
}
declare 14 {
int Tcl_ObjectDeleted(Tcl_Object object)
@@ -84,7 +84,7 @@ declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
- int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
+ Tcl_Size Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
void *Tcl_ClassGetMetadata(Tcl_Class clazz,
@@ -104,8 +104,8 @@ declare 22 {
}
declare 23 {
int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
- Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv,
- int skip)
+ Tcl_ObjectContext context, Tcl_Size objc, Tcl_Obj *const *objv,
+ Tcl_Size skip)
}
declare 24 {
Tcl_ObjectMapMethodNameProc *Tcl_ObjectGetMethodNameMapper(
@@ -126,6 +126,15 @@ declare 27 {
declare 28 {
Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
}
+declare 29 {
+ int Tcl_MethodIsPrivate(Tcl_Method method)
+}
+declare 30 {
+ Tcl_Class Tcl_GetClassOfObject(Tcl_Object object)
+}
+declare 31 {
+ Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
+}
declare 34 {
void TclOOUnusedStubEntry(void)
}
@@ -164,7 +173,7 @@ declare 4 {
ProcedureMethod **pmPtrPtr)
}
declare 5 {
- int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc,
+ int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const *objv, int publicOnly, Class *startCls)
}
declare 6 {
@@ -194,24 +203,24 @@ declare 10 {
}
declare 11 {
int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
- Tcl_Class startCls, int publicPrivate, int objc,
+ Tcl_Class startCls, int publicPrivate, Tcl_Size objc,
Tcl_Obj *const *objv)
}
declare 12 {
- void TclOOObjectSetFilters(Object *oPtr, int numFilters,
+ void TclOOObjectSetFilters(Object *oPtr, Tcl_Size numFilters,
Tcl_Obj *const *filters)
}
declare 13 {
void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr,
- int numFilters, Tcl_Obj *const *filters)
+ Tcl_Size numFilters, Tcl_Obj *const *filters)
}
declare 14 {
- void TclOOObjectSetMixins(Object *oPtr, int numMixins,
+ void TclOOObjectSetMixins(Object *oPtr, Tcl_Size numMixins,
Class *const *mixins)
}
declare 15 {
void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr,
- int numMixins, Class *const *mixins)
+ Tcl_Size numMixins, Class *const *mixins)
}
return
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 20dc281..19d93f9 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,8 +24,8 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.1.0"
-#define TCLOO_PATCHLEVEL TCLOO_VERSION
+#define TCLOO_VERSION "1.3"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0"
#include "tcl.h"
@@ -40,7 +40,7 @@ extern "C" {
extern const char *TclOOInitializeStubs(
Tcl_Interp *, const char *version);
#define Tcl_OOInitStubs(interp) \
- TclOOInitializeStubs((interp), TCLOO_VERSION)
+ TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL)
#ifndef USE_TCL_STUBS
# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
#endif
@@ -62,6 +62,7 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+#define Tcl_MethodCallProc2 Tcl_MethodCallProc
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
@@ -77,7 +78,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
typedef struct {
int version; /* Structure version field. Always to be equal
- * to TCL_OO_METHOD_VERSION_CURRENT in
+ * to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
@@ -92,13 +93,26 @@ typedef struct {
* be copied directly. */
} Tcl_MethodType;
+#define Tcl_MethodType2 Tcl_MethodType
+
/*
* 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.
+ */
+
+#define TCL_OO_METHOD_PUBLIC 1
+#define TCL_OO_METHOD_UNEXPORTED 0
+#define TCL_OO_METHOD_PRIVATE 0x20
/*
* The type of some object (or class) metadata. This describes how to delete
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index e746b64..82aad22 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -4,7 +4,7 @@
* This file contains implementations of the "simple" commands and
* methods from the object-system core.
*
- * Copyright (c) 2005-2013 by Donal K. Fellows
+ * Copyright © 2005-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.
@@ -55,7 +55,7 @@ FinalizeConstruction(
Tcl_Interp *interp,
int result)
{
- Object *oPtr = data[0];
+ Object *oPtr = (Object *)data[0];
if (result != TCL_OK) {
return result;
@@ -76,14 +76,14 @@ FinalizeConstruction(
int
TclOO_Class_Constructor(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj **invoke;
+ Tcl_Obj **invoke, *nameObj;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,10 +94,21 @@ TclOO_Class_Constructor(
}
/*
+ * Make the class definition delegate. This is special; it doesn't reenter
+ * here (and the class definition delegate doesn't run any constructors).
+ */
+
+ nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+ Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+ TclGetString(nameObj), NULL, -1, NULL, -1);
+ Tcl_DecrRefCount(nameObj);
+
+ /*
* Delegate to [oo::define] to do the work.
*/
- invoke = ckalloc(3 * sizeof(Tcl_Obj *));
+ invoke = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke, NULL, NULL, NULL);
+ invoke, oPtr, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -127,13 +138,28 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **invoke = data[0];
+ Tcl_Obj **invoke = (Tcl_Obj **)data[0];
+ Object *oPtr = (Object *)data[1];
+ Tcl_InterpState saved;
+ int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
+ invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ saved = Tcl_SaveInterpState(interp, result);
+ code = Tcl_EvalObjv(interp, 2, invoke, 0);
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
ckfree(invoke);
- return result;
+ if (code != TCL_OK) {
+ Tcl_DiscardInterpState(saved);
+ return code;
+ }
+ return Tcl_RestoreInterpState(interp, saved);
}
/*
@@ -148,7 +174,7 @@ DecrRefsPostClassConstructor(
int
TclOO_Class_Create(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -169,7 +195,7 @@ TclOO_Class_Create(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
- Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL);
return TCL_ERROR;
}
@@ -182,12 +208,12 @@ TclOO_Class_Create(
"objectName ?arg ...?");
return TCL_ERROR;
}
- objName = Tcl_GetStringFromObj(
+ objName = TclGetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL);
return TCL_ERROR;
}
@@ -213,7 +239,7 @@ TclOO_Class_Create(
int
TclOO_Class_CreateNs(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -234,7 +260,7 @@ TclOO_Class_CreateNs(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
- Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL);
return TCL_ERROR;
}
@@ -247,20 +273,20 @@ TclOO_Class_CreateNs(
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
- objName = Tcl_GetStringFromObj(
+ objName = TclGetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL);
return TCL_ERROR;
}
- nsName = Tcl_GetStringFromObj(
+ nsName = TclGetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"namespace name must not be empty", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (void *)NULL);
return TCL_ERROR;
}
@@ -286,7 +312,7 @@ TclOO_Class_CreateNs(
int
TclOO_Class_New(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -305,7 +331,7 @@ TclOO_Class_New(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" is not a class", TclGetString(cmdnameObj)));
- Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (void *)NULL);
return TCL_ERROR;
}
@@ -330,7 +356,7 @@ TclOO_Class_New(
int
TclOO_Object_Destroy(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -347,7 +373,8 @@ TclOO_Object_Destroy(
}
if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
oPtr->flags |= DESTRUCTOR_CALLED;
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
+ NULL);
if (contextPtr != NULL) {
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
@@ -369,7 +396,7 @@ AfterNRDestructor(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = data[0];
+ CallContext *contextPtr = (CallContext *)data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
@@ -390,7 +417,7 @@ AfterNRDestructor(
int
TclOO_Object_Eval(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -456,7 +483,7 @@ FinalizeEval(
int result)
{
if (result == TCL_ERROR) {
- Object *oPtr = data[0];
+ Object *oPtr = (Object *)data[0];
const char *namePtr;
if (oPtr) {
@@ -491,7 +518,7 @@ FinalizeEval(
int
TclOO_Object_Unknown(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -499,9 +526,12 @@ TclOO_Object_Unknown(
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
+ Object *callerObj = NULL;
+ Class *callerCls = NULL;
Object *oPtr = contextPtr->oPtr;
const char **methodNames;
int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
Tcl_Obj *errorMsg;
/*
@@ -516,10 +546,31 @@ TclOO_Object_Unknown(
}
/*
+ * Determine if the calling context should know about extra private
+ * methods, and if so, which.
+ */
+
+ if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
+ CallContext *callerContext = (CallContext *)framePtr->clientData;
+ Method *mPtr = callerContext->callPtr->chain[
+ callerContext->index].mPtr;
+
+ if (mPtr->declaringObjectPtr) {
+ if (oPtr == mPtr->declaringObjectPtr) {
+ callerObj = mPtr->declaringObjectPtr;
+ }
+ } else {
+ if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
+ callerCls = mPtr->declaringClassPtr;
+ }
+ }
+ }
+
+ /*
* Get the list of methods that we want to know about.
*/
- numMethodNames = TclOOGetSortedMethodList(oPtr,
+ numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
/*
@@ -538,7 +589,7 @@ TclOO_Object_Unknown(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"object \"%s\" has no %s", TclGetString(tmpBuf), piece));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[skip]), NULL);
+ TclGetString(objv[skip]), (void *)NULL);
return TCL_ERROR;
}
@@ -557,7 +608,7 @@ TclOO_Object_Unknown(
ckfree(methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[skip]), NULL);
+ TclGetString(objv[skip]), (void *)NULL);
return TCL_ERROR;
}
@@ -573,7 +624,7 @@ TclOO_Object_Unknown(
int
TclOO_Object_LinkVar(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -614,7 +665,7 @@ TclOO_Object_LinkVar(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable name \"%s\" illegal: must not contain namespace"
" separator", varName));
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (void *)NULL);
return TCL_ERROR;
}
@@ -643,7 +694,7 @@ TclOO_Object_LinkVar(
TclVarErrMsg(interp, varName, NULL, "define",
"name refers to an element in an array");
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (void *)NULL);
return TCL_ERROR;
}
@@ -675,7 +726,7 @@ TclOO_Object_LinkVar(
int
TclOO_Object_VarName(
- ClientData clientData, /* Ignored. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
@@ -684,6 +735,7 @@ TclOO_Object_VarName(
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
@@ -709,6 +761,58 @@ TclOO_Object_VarName(
Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ /*
+ * Private method handling. [TIP 500]
+ *
+ * If we're in a context that can see some private methods of an
+ * object, we may need to precede a variable name with its prefix.
+ * This is a little tricky as we need to check through the inheritance
+ * hierarchy when the method was declared by a class to see if the
+ * current object is an instance of that class.
+ */
+
+ 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;
+ int i;
+
+ if (mPtr->declaringObjectPtr == oPtr) {
+ FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
+ if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+ Tcl_GetString(argPtr))) {
+ argPtr = pvPtr->fullNameObj;
+ break;
+ }
+ }
+ } else if (mPtr->declaringClassPtr &&
+ mPtr->declaringClassPtr->privateVariables.num) {
+ Class *clsPtr = mPtr->declaringClassPtr;
+ int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
+ Class *mixinCls;
+
+ if (!isInstance) {
+ FOREACH(mixinCls, oPtr->mixins) {
+ if (TclOOIsReachable(clsPtr, mixinCls)) {
+ isInstance = 1;
+ break;
+ }
+ }
+ }
+ if (isInstance) {
+ FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
+ if (!strcmp(Tcl_GetString(pvPtr->variableObj),
+ Tcl_GetString(argPtr))) {
+ argPtr = pvPtr->fullNameObj;
+ break;
+ }
+ }
+ }
+ }
+ }
+
varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
Tcl_AppendToObj(varNamePtr, "::", 2);
Tcl_AppendObjToObj(varNamePtr, argPtr);
@@ -718,7 +822,7 @@ TclOO_Object_VarName(
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *)NULL);
return TCL_ERROR;
}
@@ -729,26 +833,16 @@ TclOO_Object_VarName(
TclNewObj(varNamePtr);
if (aryVar != NULL) {
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch search;
-
Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
/*
* WARNING! This code pokes inside the implementation of hash tables!
*/
- hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
- &search);
- while (hPtr != NULL) {
- if (varPtr == Tcl_GetHashValue(hPtr)) {
- Tcl_AppendToObj(varNamePtr, "(", -1);
- Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
- Tcl_AppendToObj(varNamePtr, ")", -1);
- break;
- }
- hPtr = Tcl_NextHashEntry(&search);
- }
+ Tcl_AppendToObj(varNamePtr, "(", -1);
+ Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
+ varPtr)->entry.key.objPtr);
+ Tcl_AppendToObj(varNamePtr, ")", -1);
} else {
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
}
@@ -770,7 +864,7 @@ TclOO_Object_VarName(
int
TclOONextObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -789,10 +883,10 @@ TclOONextObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
return TCL_ERROR;
}
- context = framePtr->clientData;
+ context = (Tcl_ObjectContext)framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
@@ -806,7 +900,7 @@ TclOONextObjCmd(
int
TclOONextToObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -829,10 +923,10 @@ TclOONextToObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
return TCL_ERROR;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext *)framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
@@ -850,7 +944,7 @@ TclOONextToObjCmd(
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (void *)NULL);
return TCL_ERROR;
}
@@ -899,14 +993,14 @@ TclOONextToObjCmd(
"%s implementation by \"%s\" not reachable from here",
methodType, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s has no non-filter implementation by \"%s\"",
methodType, TclGetString(objv[1])));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (void *)NULL);
return TCL_ERROR;
}
@@ -917,9 +1011,9 @@ NextRestoreFrame(
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = data[1];
+ CallContext *contextPtr = (CallContext *)data[1];
- iPtr->varFramePtr = data[0];
+ iPtr->varFramePtr = (CallFrame *)data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2INT(data[2]);
}
@@ -939,7 +1033,7 @@ NextRestoreFrame(
int
TclOOSelfObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -969,11 +1063,11 @@ TclOOSelfObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
return TCL_ERROR;
}
- contextPtr = framePtr->clientData;
+ contextPtr = (CallContext*)framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
@@ -1004,7 +1098,7 @@ TclOOSelfObjCmd(
if (clsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method not defined by a class", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL);
return TCL_ERROR;
}
@@ -1025,7 +1119,7 @@ TclOOSelfObjCmd(
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL);
return TCL_ERROR;
} else {
struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
@@ -1051,10 +1145,10 @@ TclOOSelfObjCmd(
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL);
return TCL_ERROR;
} else {
- CallContext *callerPtr = framePtr->callerVarPtr->clientData;
+ CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
@@ -1119,7 +1213,7 @@ TclOOSelfObjCmd(
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (void *)NULL);
return TCL_ERROR;
} else {
Method *mPtr;
@@ -1155,7 +1249,7 @@ TclOOSelfObjCmd(
}
case SELF_CALL:
result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
- TclNewIntObj(result[1], contextPtr->index);
+ TclNewIndexObj(result[1], contextPtr->index);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
@@ -1176,7 +1270,7 @@ TclOOSelfObjCmd(
int
TclOOCopyObjectCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 7ebde5e..85ca995 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -2,9 +2,10 @@
* tclOOCall.c --
*
* This file contains the method call chain management code for the
- * object-system core.
+ * object-system core. It also contains everything else that does
+ * inheritance hierarchy traversal.
*
- * Copyright (c) 2005-2012 Donal K. Fellows
+ * Copyright © 2005-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,6 +16,7 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include <assert.h>
/*
* Structure containing a CallContext and any other values needed only during
@@ -31,6 +33,22 @@ struct ChainBuilder {
};
/*
+ * Structures used for traversing the class hierarchy to find out where
+ * definitions are supposed to be done.
+ */
+
+typedef struct {
+ Class *definerCls;
+ Tcl_Obj *namespaceName;
+} DefineEntry;
+
+typedef struct {
+ DefineEntry *list;
+ int num;
+ int size;
+} DefineChain;
+
+/*
* Extra flags used for call chain management.
*/
@@ -41,11 +59,34 @@ struct ChainBuilder {
#define BUILDING_MIXINS 0x400000
#define TRAVERSED_MIXIN 0x800000
#define OBJECT_MIXIN 0x1000000
+#define DEFINE_FOR_CLASS 0x2000000
#define MIXIN_CONSISTENT(flags) \
(((flags) & OBJECT_MIXIN) || \
!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
/*
+ * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
+ * Itcl's special type of private.
+ */
+
+#define IS_PUBLIC(mPtr) \
+ (((mPtr)->flags & PUBLIC_METHOD) != 0)
+#define IS_UNEXPORTED(mPtr) \
+ (((mPtr)->flags & SCOPE_FLAGS) == 0)
+#define IS_ITCLPRIVATE(mPtr) \
+ (((mPtr)->flags & PRIVATE_METHOD) != 0)
+#define IS_PRIVATE(mPtr) \
+ (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
+#define WANT_PUBLIC(flags) \
+ (((flags) & PUBLIC_METHOD) != 0)
+#define WANT_UNEXPORTED(flags) \
+ (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
+#define WANT_ITCLPRIVATE(flags) \
+ (((flags) & PRIVATE_METHOD) != 0)
+#define WANT_PRIVATE(flags) \
+ (((flags) & TRUE_PRIVATE_METHOD) != 0)
+
+/*
* Function declarations for things defined in this file.
*/
@@ -55,20 +96,41 @@ static void AddClassFiltersToCallContext(Object *const oPtr,
static void AddClassMethodNames(Class *clsPtr, int flags,
Tcl_HashTable *const namesPtr,
Tcl_HashTable *const examinedClassesPtr);
+static inline void AddDefinitionNamespaceToChain(Class *const definerCls,
+ Tcl_Obj *const namespaceName,
+ DefineChain *const definePtr, int flags);
static inline void AddMethodToCallChain(Method *const mPtr,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters,
Class *const filterDecl, int flags);
-static inline void AddSimpleChainToCallContext(Object *const oPtr,
+static inline int AddInstancePrivateToCallContext(Object *const oPtr,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr, int flags);
+static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr,
+ Method *mPtr, Tcl_HashTable *namesPtr);
+static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
+ Tcl_HashTable *namesPtr);
+static inline int AddSimpleChainToCallContext(Object *const oPtr,
+ Class *const contextCls,
+ Tcl_Obj *const methodNameObj,
+ struct ChainBuilder *const cbPtr,
+ Tcl_HashTable *const doneFilters, int flags,
+ Class *const filterDecl);
+static int AddPrivatesFromClassChainToCallContext(Class *classPtr,
+ Class *const contextCls,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
-static void AddSimpleClassChainToCallContext(Class *classPtr,
+static int AddSimpleClassChainToCallContext(Class *classPtr,
Tcl_Obj *const methodNameObj,
struct ChainBuilder *const cbPtr,
Tcl_HashTable *const doneFilters, int flags,
Class *const filterDecl);
+static void AddSimpleClassDefineNamespaces(Class *classPtr,
+ DefineChain *const definePtr, int flags);
+static inline void AddSimpleDefineNamespaces(Object *const oPtr,
+ DefineChain *const definePtr, int flags);
static int CmpStr(const void *ptr1, const void *ptr2);
static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static Tcl_NRPostProc FinalizeMethodRefs;
@@ -77,6 +139,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr,
int flags, int reuseMask);
static Tcl_NRPostProc ResetFilterFlags;
static Tcl_NRPostProc SetFilterFlags;
+static int SortMethodNames(Tcl_HashTable *namesPtr, int flags,
+ const char ***stringsPtr);
static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
/*
@@ -185,11 +249,12 @@ StashCallChain(
Tcl_Obj *objPtr,
CallChain *callPtr)
{
+ Tcl_ObjInternalRep ir;
+
callPtr->refCount++;
TclGetString(objPtr);
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &methodNameType;
- objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
+ ir.twoPtrValue.ptr1 = callPtr;
+ Tcl_StoreInternalRep(objPtr, &methodNameType, &ir);
}
void
@@ -216,21 +281,16 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
-
- dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
- callPtr->refCount++;
+ StashCallChain(dstPtr,
+ (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
-
- TclOODeleteChain(callPtr);
- objPtr->typePtr = NULL;
+ TclOODeleteChain(
+ (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
@@ -311,14 +371,14 @@ TclOOInvokeContext(
* Run the method implementation.
*/
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -330,7 +390,7 @@ SetFilterFlags(
static int
ResetFilterFlags(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -342,7 +402,7 @@ ResetFilterFlags(
static int
FinalizeMethodRefs(
void *data[],
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
@@ -367,6 +427,14 @@ FinalizeMethodRefs(
int
TclOOGetSortedMethodList(
Object *oPtr, /* The object to get the method names for. */
+ Object *contextObj, /* From what context object we are inquiring.
+ * NULL when the context shouldn't see
+ * object-level private methods. Note that
+ * flags can override this. */
+ Class *contextCls, /* From what context class we are inquiring.
+ * NULL when the context shouldn't see
+ * class-level private methods. Note that
+ * flags can override this. */
int flags, /* Whether we just want the public method
* names. */
const char ***stringsPtr) /* Where to write a pointer to the array of
@@ -379,12 +447,10 @@ TclOOGetSortedMethodList(
* at. Is set-like in nature and keyed by
* pointer to class. */
FOREACH_HASH_DECLS;
- int i;
+ int i, numStrings;
Class *mixinPtr;
Tcl_Obj *namePtr;
Method *mPtr;
- int isWantedIn;
- void *isWanted;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -401,18 +467,13 @@ TclOOGetSortedMethodList(
if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
- int isNew;
-
- if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
+ if (IS_PRIVATE(mPtr)) {
continue;
}
- hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
- if (isNew) {
- isWantedIn = ((!(flags & PUBLIC_METHOD)
- || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
- isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
- Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
+ if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
+ continue;
}
+ AddStandardMethodName(flags, namePtr, mPtr, &names);
}
}
@@ -420,84 +481,46 @@ TclOOGetSortedMethodList(
* Process method names due to private methods on the object's class.
*/
- if (flags & PRIVATE_METHOD) {
+ if (WANT_UNEXPORTED(flags)) {
FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
- if (mPtr->flags & PRIVATE_METHOD) {
- int isNew;
-
- hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
- if (isNew) {
- isWantedIn = IN_LIST;
- if (mPtr->typePtr == NULL) {
- isWantedIn |= NO_IMPLEMENTATION;
- }
- Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
- } else if (mPtr->typePtr != NULL) {
- isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
- if (isWantedIn & NO_IMPLEMENTATION) {
- isWantedIn &= ~NO_IMPLEMENTATION;
- Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
- }
- }
+ if (IS_UNEXPORTED(mPtr)) {
+ AddStandardMethodName(flags, namePtr, mPtr, &names);
}
}
}
/*
+ * Process method names due to private methods on the context's object or
+ * class. Which must be correct if either are not NULL.
+ */
+
+ if (contextObj && contextObj->methodsPtr) {
+ AddPrivateMethodNames(contextObj->methodsPtr, &names);
+ }
+ if (contextCls) {
+ AddPrivateMethodNames(&contextCls->classMethods, &names);
+ }
+
+ /*
* Process (normal) method names from the class hierarchy and the mixin
* hierarchy.
*/
AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses);
FOREACH(mixinPtr, oPtr->mixins) {
- AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names,
+ AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names,
&examinedClasses);
}
- Tcl_DeleteHashTable(&examinedClasses);
-
/*
- * See how many (visible) method names there are. If none, we do not (and
- * should not) try to sort the list of them.
+ * Tidy up, sort the names and resolve finally whether we really want
+ * them (processing export layering).
*/
- i = 0;
- if (names.numEntries != 0) {
- const char **strings;
-
- /*
- * We need to build the list of methods to sort. We will be using
- * qsort() for this, because it is very unlikely that the list will be
- * heavily sorted when it is long enough to matter.
- */
-
- strings = ckalloc(sizeof(char *) * names.numEntries);
- FOREACH_HASH(namePtr, isWanted, &names) {
- if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
- if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
- continue;
- }
- strings[i++] = TclGetString(namePtr);
- }
- }
-
- /*
- * Note that 'i' may well be less than names.numEntries when we are
- * dealing with public method names.
- */
-
- if (i > 0) {
- if (i > 1) {
- qsort((void *) strings, i, sizeof(char *), CmpStr);
- }
- *stringsPtr = strings;
- } else {
- ckfree(strings);
- }
- }
-
+ Tcl_DeleteHashTable(&examinedClasses);
+ numStrings = SortMethodNames(&names, flags, stringsPtr);
Tcl_DeleteHashTable(&names);
- return i;
+ return numStrings;
}
int
@@ -514,10 +537,7 @@ TclOOGetSortedClassMethodList(
/* Used to track what classes have been looked
* at. Is set-like in nature and keyed by
* pointer to class. */
- FOREACH_HASH_DECLS;
- int i;
- Tcl_Obj *namePtr;
- void *isWanted;
+ int numStrings;
Tcl_InitObjHashTable(&names);
Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
@@ -530,51 +550,101 @@ TclOOGetSortedClassMethodList(
Tcl_DeleteHashTable(&examinedClasses);
/*
+ * Process private method names if we should. [TIP 500]
+ */
+
+ if (WANT_PRIVATE(flags)) {
+ AddPrivateMethodNames(&clsPtr->classMethods, &names);
+ flags &= ~TRUE_PRIVATE_METHOD;
+ }
+
+ /*
+ * Tidy up, sort the names and resolve finally whether we really want
+ * them (processing export layering).
+ */
+
+ numStrings = SortMethodNames(&names, flags, stringsPtr);
+ Tcl_DeleteHashTable(&names);
+ return numStrings;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortMethodNames --
+ *
+ * Shared helper for TclOOGetSortedMethodList etc. that knows the method
+ * sorting rules.
+ *
+ * Returns:
+ * The length of the sorted list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+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. */
+ const char ***stringsPtr) /* Where to store the sorted list of strings
+ * that we produce. ckalloced() */
+{
+ const char **strings;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *namePtr;
+ void *isWanted;
+ int i = 0;
+
+ /*
* See how many (visible) method names there are. If none, we do not (and
* should not) try to sort the list of them.
*/
- i = 0;
- if (names.numEntries != 0) {
- const char **strings;
+ if (namesPtr->numEntries == 0) {
+ *stringsPtr = NULL;
+ return 0;
+ }
- /*
- * We need to build the list of methods to sort. We will be using
- * qsort() for this, because it is very unlikely that the list will be
- * heavily sorted when it is long enough to matter.
- */
+ /*
+ * We need to build the list of methods to sort. We will be using qsort()
+ * for this, because it is very unlikely that the list will be heavily
+ * sorted when it is long enough to matter.
+ */
- strings = (const char **)ckalloc(sizeof(char *) * names.numEntries);
- FOREACH_HASH(namePtr, isWanted, &names) {
- if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
- if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
- continue;
- }
- strings[i++] = TclGetString(namePtr);
+ strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries);
+ FOREACH_HASH(namePtr, isWanted, namesPtr) {
+ if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
+ if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
+ continue;
}
+ strings[i++] = TclGetString(namePtr);
}
+ }
- /*
- * Note that 'i' may well be less than names.numEntries when we are
- * dealing with public method names.
- */
+ /*
+ * Note that 'i' may well be less than names.numEntries when we are
+ * dealing with public method names. We don't sort unless there's at least
+ * two method names.
+ */
- if (i > 0) {
- if (i > 1) {
- qsort((void *) strings, i, sizeof(char *), CmpStr);
- }
- *stringsPtr = strings;
- } else {
- ckfree(strings);
+ if (i > 0) {
+ if (i > 1) {
+ qsort((void *) strings, i, sizeof(char *), CmpStr);
}
+ *stringsPtr = strings;
+ } else {
+ ckfree(strings);
+ *stringsPtr = NULL;
}
-
- Tcl_DeleteHashTable(&names);
return i;
}
/*
- * Comparator for GetSortedMethodList
+ * Comparator for SortMethodNames
*/
static int
@@ -618,6 +688,8 @@ AddClassMethodNames(
* pointers to the classes, and the values are
* immaterial. */
{
+ int i;
+
/*
* If we've already started looking at this class, stop working on it now
* to prevent repeated work.
@@ -648,7 +720,6 @@ AddClassMethodNames(
if (clsPtr->mixins.num != 0) {
Class *mixinPtr;
- int i;
FOREACH(mixinPtr, clsPtr->mixins) {
if (mixinPtr != clsPtr) {
@@ -659,20 +730,7 @@ AddClassMethodNames(
}
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
- if (isNew) {
- int isWanted = (!(flags & PUBLIC_METHOD)
- || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
-
- isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
- Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
- } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
- && mPtr->typePtr != NULL) {
- int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
-
- isWanted &= ~NO_IMPLEMENTATION;
- Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
- }
+ AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
}
if (clsPtr->superclasses.num != 1) {
@@ -682,7 +740,6 @@ AddClassMethodNames(
}
if (clsPtr->superclasses.num != 0) {
Class *superPtr;
- int i;
FOREACH(superPtr, clsPtr->superclasses) {
AddClassMethodNames(superPtr, flags, namesPtr,
@@ -694,19 +751,121 @@ AddClassMethodNames(
/*
* ----------------------------------------------------------------------
*
+ * AddPrivateMethodNames, AddStandardMethodName --
+ *
+ * Factored-out helpers for the sorted name list production functions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddPrivateMethodNames(
+ Tcl_HashTable *methodsTablePtr,
+ Tcl_HashTable *namesPtr)
+{
+ FOREACH_HASH_DECLS;
+ Method *mPtr;
+ Tcl_Obj *namePtr;
+
+ FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
+ if (IS_PRIVATE(mPtr)) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(namesPtr, (char *) 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, (char *) 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));
+ } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
+ && mPtr->typePtr != NULL) {
+ int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
+
+ isWanted &= ~NO_IMPLEMENTATION;
+ Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
+ }
+ }
+}
+
+#undef IN_LIST
+#undef NO_IMPLEMENTATION
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddInstancePrivateToCallContext --
+ *
+ * Add private methods from the instance. Called when the calling Tcl
+ * context is a TclOO method declared by an object that is the same as
+ * the current object. Returns true iff a private method was actually
+ * found and added to the call chain (as this suppresses caching).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+AddInstancePrivateToCallContext(
+ Object *const oPtr, /* Object to add call chain entries for. */
+ Tcl_Obj *const methodName, /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ 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, (char *) methodName);
+ if (hPtr != NULL) {
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
+ donePrivate = 1;
+ }
+ }
+ }
+ return donePrivate;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* AddSimpleChainToCallContext --
*
* The core of the call-chain construction engine, this handles calling a
* particular method on a particular object. Note that filters and
* unknown handling are already handled by the logic that uses this
- * function.
+ * function. Returns true if a private method was one of those found.
*
* ----------------------------------------------------------------------
*/
-static inline void
+static inline int
AddSimpleChainToCallContext(
Object *const oPtr, /* Object to add call chain entries for. */
+ Class *const contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. [TIP 500] */
Tcl_Obj *const methodNameObj,
/* Name of method to add the call chain
* entries for. */
@@ -720,44 +879,62 @@ AddSimpleChainToCallContext(
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
- int i;
+ int i, foundPrivate = 0, blockedUnexported = 0;
+ Tcl_HashEntry *hPtr;
+ Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
- (char *) methodNameObj);
+ hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
if (hPtr != NULL) {
- Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
-
- if (flags & PUBLIC_METHOD) {
- if (!(mPtr->flags & PUBLIC_METHOD)) {
- return;
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (!IS_PRIVATE(mPtr)) {
+ if (WANT_PUBLIC(flags)) {
+ if (!IS_PUBLIC(mPtr)) {
+ blockedUnexported = 1;
+ } else {
+ flags |= DEFINITE_PUBLIC;
+ }
} else {
- flags |= DEFINITE_PUBLIC;
+ flags |= DEFINITE_PROTECTED;
}
- } else {
- flags |= DEFINITE_PROTECTED;
}
}
}
if (!(flags & SPECIAL)) {
- Tcl_HashEntry *hPtr;
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
- doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ if (contextCls) {
+ foundPrivate |= AddPrivatesFromClassChainToCallContext(
+ mixinPtr, contextCls, methodNameObj, cbPtr,
+ doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ }
+ foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
+ methodNameObj, cbPtr, doneFilters,
+ flags | TRAVERSED_MIXIN, filterDecl);
}
- if (oPtr->methodsPtr) {
+ if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
- AddMethodToCallChain((Method *)Tcl_GetHashValue(hPtr), cbPtr,
- doneFilters, filterDecl, flags);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
+ if (!IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
+ }
}
}
}
- AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
+ if (contextCls) {
+ foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
+ contextCls, methodNameObj, cbPtr, doneFilters, flags,
+ filterDecl);
+ }
+ if (!blockedUnexported) {
+ foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls,
+ methodNameObj, cbPtr, doneFilters, flags, filterDecl);
+ }
+ return foundPrivate;
}
/*
@@ -820,8 +997,8 @@ AddMethodToCallChain(
* should be sufficient for [incr Tcl] support though.
*/
- if (!(callPtr->flags & PRIVATE_METHOD)
- && (mPtr->flags & PRIVATE_METHOD)
+ if (!WANT_UNEXPORTED(callPtr->flags)
+ && IS_UNEXPORTED(mPtr)
&& (mPtr->declaringClassPtr != NULL)
&& (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
return;
@@ -961,6 +1138,12 @@ TclOOGetCallContext(
* Only the bits PUBLIC_METHOD, CONSTRUCTOR,
* PRIVATE_METHOD, DESTRUCTOR and
* FILTER_HANDLING are useful. */
+ Object *contextObj, /* Context object; when equal to oPtr, it
+ * means that private methods may also be
+ * added. [TIP 500] */
+ Class *contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. [TIP 500] */
Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is
* to be in the same object as the
* methodNameObj. */
@@ -969,7 +1152,7 @@ TclOOGetCallContext(
CallChain *callPtr;
struct ChainBuilder cb;
int i, count;
- int doFilters;
+ int doFilters, donePrivate = 0;
Tcl_HashEntry *hPtr;
Tcl_HashTable doneFilters;
@@ -1009,15 +1192,16 @@ TclOOGetCallContext(
* the object, and in the class).
*/
- const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+ const Tcl_ObjInternalRep *irPtr;
+ const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
- if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = (CallChain *)cacheInThisObj->internalRep.twoPtrValue.ptr1;
+ if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) {
+ callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
- FreeMethodNameRep(cacheInThisObj);
+ Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL);
}
if (oPtr->flags & USE_CLASS_CACHE) {
@@ -1061,10 +1245,11 @@ TclOOGetCallContext(
*/
if (flags & FORCE_UNKNOWN) {
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, 0, NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+ NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (callPtr->numChain == 0) {
@@ -1093,10 +1278,10 @@ TclOOGetCallContext(
OBJECT_MIXIN);
}
FOREACH(filterObj, oPtr->filters) {
- AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
- BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
- NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ filterObj, &cb, &doneFilters, 0, NULL);
}
AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
BUILDING_MIXINS);
@@ -1111,9 +1296,15 @@ TclOOGetCallContext(
* handle class mixins right.
*/
- AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
- flags|BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
+ if (oPtr == contextObj) {
+ donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj,
+ &cb, flags);
+ donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS);
+ }
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL);
+ donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
+ methodNameObj, &cb, NULL, flags, NULL);
/*
* Check to see if the method has no implementation. If so, we probably
@@ -1131,17 +1322,18 @@ TclOOGetCallContext(
TclOODeleteChain(callPtr);
return NULL;
}
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
- &cb, NULL, 0, NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
+ NULL);
+ AddSimpleChainToCallContext(oPtr, NULL,
+ oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
- } else if (doFilters) {
+ } else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
@@ -1247,8 +1439,7 @@ TclOOGetStereotypeCallChain(
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
- const int reuseMask =
- ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+ const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
@@ -1292,9 +1483,10 @@ TclOOGetStereotypeCallChain(
* Add the actual method implementations.
*/
- AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
+ AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
flags|BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags,
+ NULL);
/*
* Check to see if the method has no implementation. If so, we probably
@@ -1303,10 +1495,10 @@ TclOOGetStereotypeCallChain(
*/
if (count == callPtr->numChain) {
- AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
- NULL, BUILDING_MIXINS, NULL);
- AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
- NULL, 0, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+ &cb, NULL, BUILDING_MIXINS, NULL);
+ AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
+ &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
@@ -1387,9 +1579,9 @@ AddClassFiltersToCallContext(
(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
&isNew);
if (isNew) {
- AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+ AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
- AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
+ AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
doneFilters, clearedFlags, clsPtr);
}
}
@@ -1416,6 +1608,88 @@ AddClassFiltersToCallContext(
/*
* ----------------------------------------------------------------------
*
+ * AddPrivatesFromClassChainToCallContext --
+ *
+ * Helper for AddSimpleChainToCallContext that is used to find private
+ * methds and add them to the call chain. Returns true when a private
+ * method is found and added. [TIP 500]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+AddPrivatesFromClassChainToCallContext(
+ Class *classPtr, /* Class to add the call chain entries for. */
+ Class *const contextCls, /* Context class; the currently considered
+ * class is equal to this, private methods may
+ * also be added. */
+ Tcl_Obj *const methodName, /* Name of method to add the call chain
+ * entries for. */
+ struct ChainBuilder *const cbPtr,
+ /* Where to add the call chain entries. */
+ Tcl_HashTable *const doneFilters,
+ /* 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. */
+{
+ int 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.
+ * [Bug 1998221]
+ */
+
+ tailRecurse:
+ FOREACH(superPtr, classPtr->mixins) {
+ if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+ methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
+ filterDecl)) {
+ return 1;
+ }
+ }
+
+ if (classPtr == contextCls) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+ methodName);
+
+ if (hPtr != NULL) {
+ Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
+
+ if (IS_PRIVATE(mPtr)) {
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
+ return 1;
+ }
+ }
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
+ methodName, cbPtr, doneFilters, flags, filterDecl)) {
+ return 1;
+ }
+ }
+ /* FALLTHRU */
+ case 0:
+ return 0;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* AddSimpleClassChainToCallContext --
*
* Construct a call-chain from a class hierarchy.
@@ -1423,7 +1697,7 @@ AddClassFiltersToCallContext(
* ----------------------------------------------------------------------
*/
-static void
+static int
AddSimpleClassChainToCallContext(
Class *classPtr, /* Class to add the call chain entries for. */
Tcl_Obj *const methodNameObj,
@@ -1439,7 +1713,7 @@ AddSimpleClassChainToCallContext(
* NULL, either the filter was declared by the
* object or this isn't a filter. */
{
- int i;
+ int i, privateDanger = 0;
Class *superPtr;
/*
@@ -1452,8 +1726,9 @@ AddSimpleClassChainToCallContext(
tailRecurse:
FOREACH(superPtr, classPtr->mixins) {
- AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
- doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
+ privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+ methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
+ filterDecl);
}
if (flags & CONSTRUCTOR) {
@@ -1466,21 +1741,26 @@ AddSimpleClassChainToCallContext(
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
+ if (classPtr->flags & HAS_PRIVATE_METHODS) {
+ privateDanger |= 1;
+ }
if (hPtr != NULL) {
Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
- if (!(flags & KNOWN_STATE)) {
- if (flags & PUBLIC_METHOD) {
- if (mPtr->flags & PUBLIC_METHOD) {
+ if (!IS_PRIVATE(mPtr)) {
+ if (!(flags & KNOWN_STATE)) {
+ if (flags & PUBLIC_METHOD) {
+ if (!IS_PUBLIC(mPtr)) {
+ return privateDanger;
+ }
flags |= DEFINITE_PUBLIC;
} else {
- return;
+ flags |= DEFINITE_PROTECTED;
}
- } else {
- flags |= DEFINITE_PROTECTED;
}
+ AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
+ flags);
}
- AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags);
}
}
@@ -1490,12 +1770,12 @@ AddSimpleClassChainToCallContext(
goto tailRecurse;
default:
FOREACH(superPtr, classPtr->superclasses) {
- AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
- doneFilters, flags, filterDecl);
+ privateDanger |= AddSimpleClassChainToCallContext(superPtr,
+ methodNameObj, cbPtr, doneFilters, flags, filterDecl);
}
/* FALLTHRU */
case 0:
- return;
+ return privateDanger;
}
}
@@ -1515,7 +1795,7 @@ TclOORenderCallChain(
Tcl_Interp *interp,
CallChain *callPtr)
{
- Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
+ Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
Tcl_Obj *resultObj, *descObjs[4], **objv;
Foundation *fPtr = TclOOGetFoundation(interp);
int i;
@@ -1524,12 +1804,14 @@ TclOORenderCallChain(
* Allocate the literals (potentially) used in our description.
*/
- filterLiteral = Tcl_NewStringObj("filter", -1);
+ TclNewLiteralStringObj(filterLiteral, "filter");
Tcl_IncrRefCount(filterLiteral);
- methodLiteral = Tcl_NewStringObj("method", -1);
+ TclNewLiteralStringObj(methodLiteral, "method");
Tcl_IncrRefCount(methodLiteral);
- objectLiteral = Tcl_NewStringObj("object", -1);
+ TclNewLiteralStringObj(objectLiteral, "object");
Tcl_IncrRefCount(objectLiteral);
+ TclNewLiteralStringObj(privateLiteral, "private");
+ Tcl_IncrRefCount(privateLiteral);
/*
* Do the actual construction of the descriptions. They consist of a list
@@ -1550,6 +1832,7 @@ TclOORenderCallChain(
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
+ IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
methodLiteral;
descObjs[1] =
callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
@@ -1572,6 +1855,7 @@ TclOORenderCallChain(
Tcl_DecrRefCount(filterLiteral);
Tcl_DecrRefCount(methodLiteral);
Tcl_DecrRefCount(objectLiteral);
+ Tcl_DecrRefCount(privateLiteral);
/*
* Finish building the description and return it.
@@ -1583,6 +1867,499 @@ TclOORenderCallChain(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineContextNamespace --
+ *
+ * Responsible for determining which namespace to use for definitions.
+ * This is done by building a define chain, which models (strongly!) the
+ * way that a call chain works but with a different internal model.
+ *
+ * Then it walks the chain to find the first namespace name that actually
+ * resolves to an existing namespace.
+ *
+ * Returns:
+ * Name of namespace, or NULL if none can be found. Note that this
+ * function does *not* set an error message in the interpreter on failure.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */
+
+Tcl_Namespace *
+TclOOGetDefineContextNamespace(
+ Tcl_Interp *interp, /* In what interpreter should namespace names
+ * actually be resolved. */
+ Object *oPtr, /* The object to get the context for. */
+ int forClass) /* What sort of context are we looking for.
+ * If true, we are going to use this for
+ * [oo::define], otherwise, we are going to
+ * use this for [oo::objdefine]. */
+{
+ DefineChain define;
+ DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
+ DefineEntry *entryPtr;
+ Tcl_Namespace *nsPtr = NULL;
+ int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);
+
+ define.list = staticSpace;
+ define.num = 0;
+ define.size = DEFINE_CHAIN_STATIC_SIZE;
+
+ /*
+ * Add the actual define locations. We have to do this twice to handle
+ * class mixins right.
+ */
+
+ AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
+ AddSimpleDefineNamespaces(oPtr, &define, flags);
+
+ /*
+ * Go through the list until we find a namespace whose name we can
+ * resolve.
+ */
+
+ FOREACH_STRUCT(entryPtr, define) {
+ if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
+ &nsPtr) == TCL_OK) {
+ break;
+ }
+ Tcl_ResetResult(interp);
+ }
+ if (define.list != staticSpace) {
+ ckfree(define.list);
+ }
+ return nsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by an
+ * object's class and its mixins, taking into account everything they
+ * inherit from.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddSimpleDefineNamespaces(
+ 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;
+ int i;
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ AddSimpleClassDefineNamespaces(mixinPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassDefineNamespaces --
+ *
+ * Adds to the definition chain all the definitions provided by a class
+ * and its superclasses and its class mixins.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+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. */
+{
+ int 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.
+ */
+
+ tailRecurse:
+ FOREACH(superPtr, classPtr->mixins) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr,
+ flags | TRAVERSED_MIXIN);
+ }
+
+ if (flags & DEFINE_FOR_CLASS) {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
+ definePtr, flags);
+ } else {
+ AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
+ definePtr, flags);
+ }
+
+ switch (classPtr->superclasses.num) {
+ case 1:
+ classPtr = classPtr->superclasses.list[0];
+ goto tailRecurse;
+ default:
+ FOREACH(superPtr, classPtr->superclasses) {
+ AddSimpleClassDefineNamespaces(superPtr, definePtr, flags);
+ }
+ case 0:
+ return;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddDefinitionNamespaceToChain --
+ *
+ * Adds a single item to the definition chain (if it is meaningful),
+ * reallocating the space for the chain if necessary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+AddDefinitionNamespaceToChain(
+ Class *const definerCls, /* What class defines this entry. */
+ Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a
+ * no-op). */
+ DefineChain *const definePtr,
+ /* The define chain to add the method
+ * implementation to. */
+ int flags) /* Used to check if we're mixin-consistent
+ * only. Mixin-consistent means that either
+ * we're looking to add things from a mixin
+ * and we have passed a mixin, or we're not
+ * looking to add things from a mixin and have
+ * not passed a mixin. */
+{
+ int i;
+
+ /*
+ * Return if this entry is blank. This is also where we enforce
+ * mixin-consistency.
+ */
+
+ if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) {
+ return;
+ }
+
+ /*
+ * First test whether the method is already in the call chain.
+ */
+
+ for (i=0 ; i<definePtr->num ; i++) {
+ if (definePtr->list[i].definerCls == definerCls) {
+ /*
+ * Call chain semantics states that methods come as *late* in the
+ * call chain as possible. This is done by copying down the
+ * following methods. Note that this does not change the number of
+ * method invocations in the call chain; it just rearranges them.
+ *
+ * We skip changing anything if the place we found was already at
+ * the end of the list.
+ */
+
+ if (i < definePtr->num - 1) {
+ memmove(&definePtr->list[i], &definePtr->list[i + 1],
+ sizeof(DefineEntry) * (definePtr->num - i - 1));
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ }
+ return;
+ }
+ }
+
+ /*
+ * Need to really add the define. This is made a bit more complex by the
+ * fact that we are using some "static" space initially, and only start
+ * realloc-ing if the chain gets long.
+ */
+
+ if (definePtr->num == definePtr->size) {
+ definePtr->size *= 2;
+ if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
+ DefineEntry *staticList = definePtr->list;
+
+ definePtr->list =
+ (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size);
+ memcpy(definePtr->list, staticList,
+ sizeof(DefineEntry) * definePtr->num);
+ } else {
+ definePtr->list = (DefineEntry *)ckrealloc(definePtr->list,
+ sizeof(DefineEntry) * definePtr->size);
+ }
+ }
+ definePtr->list[i].definerCls = definerCls;
+ definePtr->list[i].namespaceName = namespaceName;
+ definePtr->num++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindClassProps --
+ *
+ * Discover the properties known to a class and its superclasses.
+ * The property names become the keys in the accumulator hash table
+ * (which is used as a set).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FindClassProps(
+ Class *clsPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether we're after the readable or writable
+ * property set. */
+ Tcl_HashTable *accumulator) /* Where to gather the names. */
+{
+ int i, dummy;
+ Tcl_Obj *propName;
+ Class *mixin, *sup;
+
+ tailRecurse:
+ if (writable) {
+ FOREACH(propName, clsPtr->properties.writable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ } else {
+ FOREACH(propName, clsPtr->properties.readable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ }
+ if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
+ /*
+ * We do *not* traverse upwards from the root!
+ */
+ return;
+ }
+ FOREACH(mixin, clsPtr->mixins) {
+ FindClassProps(mixin, writable, accumulator);
+ }
+ if (clsPtr->superclasses.num == 1) {
+ clsPtr = clsPtr->superclasses.list[0];
+ goto tailRecurse;
+ }
+ FOREACH(sup, clsPtr->superclasses) {
+ FindClassProps(sup, writable, accumulator);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindObjectProps --
+ *
+ * Discover the properties known to an object and all its classes.
+ * The property names become the keys in the accumulator hash table
+ * (which is used as a set).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+FindObjectProps(
+ Object *oPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether we're after the readable or writable
+ * property set. */
+ Tcl_HashTable *accumulator) /* Where to gather the names. */
+{
+ int i, dummy;
+ Tcl_Obj *propName;
+ Class *mixin;
+
+ if (writable) {
+ FOREACH(propName, oPtr->properties.writable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ } else {
+ FOREACH(propName, oPtr->properties.readable) {
+ Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
+ }
+ }
+ FOREACH(mixin, oPtr->mixins) {
+ FindClassProps(mixin, writable, accumulator);
+ }
+ FindClassProps(oPtr->selfCls, writable, accumulator);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetAllClassProperties --
+ *
+ * Get the list of all properties known to a class, including to its
+ * superclasses. Manages a cache so this operation is usually cheap.
+ * The order of properties in the resulting list is undefined.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOGetAllClassProperties(
+ Class *clsPtr, /* The class to inspect. Must exist. */
+ int writable, /* Whether to get writable properties. If
+ * false, readable properties will be returned
+ * instead. */
+ int *allocated) /* Address of variable to set to true if a
+ * Tcl_Obj was allocated and may be safely
+ * modified by the caller. */
+{
+ Tcl_HashTable hashTable;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *propName, *result;
+ void *dummy;
+
+ /*
+ * Look in the cache.
+ */
+
+ if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
+ if (writable) {
+ if (clsPtr->properties.allWritableCache) {
+ *allocated = 0;
+ return clsPtr->properties.allWritableCache;
+ }
+ } else {
+ if (clsPtr->properties.allReadableCache) {
+ *allocated = 0;
+ return clsPtr->properties.allReadableCache;
+ }
+ }
+ }
+
+ /*
+ * Gather the information. Unsorted! (Caller will sort.)
+ */
+
+ *allocated = 1;
+ Tcl_InitObjHashTable(&hashTable);
+ FindClassProps(clsPtr, writable, &hashTable);
+ TclNewObj(result);
+ FOREACH_HASH(propName, dummy, &hashTable) {
+ Tcl_ListObjAppendElement(NULL, result, propName);
+ }
+ Tcl_DeleteHashTable(&hashTable);
+
+ /*
+ * Cache the information. Also purges the cache.
+ */
+
+ if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
+ if (clsPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
+ clsPtr->properties.allWritableCache = NULL;
+ }
+ if (clsPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
+ clsPtr->properties.allReadableCache = NULL;
+ }
+ }
+ clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
+ if (writable) {
+ clsPtr->properties.allWritableCache = result;
+ } else {
+ clsPtr->properties.allReadableCache = result;
+ }
+ Tcl_IncrRefCount(result);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetAllObjectProperties --
+ *
+ * Get the list of all properties known to a object, including to its
+ * classes. Manages a cache so this operation is usually cheap.
+ * The order of properties in the resulting list is undefined.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOGetAllObjectProperties(
+ Object *oPtr, /* The object to inspect. Must exist. */
+ int writable, /* Whether to get writable properties. If
+ * false, readable properties will be returned
+ * instead. */
+ int *allocated) /* Address of variable to set to true if a
+ * Tcl_Obj was allocated and may be safely
+ * modified by the caller. */
+{
+ Tcl_HashTable hashTable;
+ FOREACH_HASH_DECLS;
+ Tcl_Obj *propName, *result;
+ void *dummy;
+
+ /*
+ * Look in the cache.
+ */
+
+ if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
+ if (writable) {
+ if (oPtr->properties.allWritableCache) {
+ *allocated = 0;
+ return oPtr->properties.allWritableCache;
+ }
+ } else {
+ if (oPtr->properties.allReadableCache) {
+ *allocated = 0;
+ return oPtr->properties.allReadableCache;
+ }
+ }
+ }
+
+ /*
+ * Gather the information. Unsorted! (Caller will sort.)
+ */
+
+ *allocated = 1;
+ Tcl_InitObjHashTable(&hashTable);
+ FindObjectProps(oPtr, writable, &hashTable);
+ TclNewObj(result);
+ FOREACH_HASH(propName, dummy, &hashTable) {
+ Tcl_ListObjAppendElement(NULL, result, propName);
+ }
+ Tcl_DeleteHashTable(&hashTable);
+
+ /*
+ * Cache the information.
+ */
+
+ if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ oPtr->properties.allWritableCache = NULL;
+ }
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ oPtr->properties.allReadableCache = NULL;
+ }
+ }
+ oPtr->properties.epoch = oPtr->fPtr->epoch;
+ if (writable) {
+ oPtr->properties.allWritableCache = result;
+ } else {
+ oPtr->properties.allReadableCache = result;
+ }
+ Tcl_IncrRefCount(result);
+ return result;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 647bbd5..6126fe2 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -59,18 +59,18 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method);
/* 11 */
TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
- int isPublic, const Tcl_MethodType *typePtr,
+ int flags, const Tcl_MethodType *typePtr,
void *clientData);
/* 12 */
TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
- Tcl_Obj *nameObj, int isPublic,
+ 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, int objc,
- Tcl_Obj *const *objv, int skip);
+ const char *nsNameStr, Tcl_Size objc,
+ Tcl_Obj *const *objv, Tcl_Size skip);
/* 14 */
TCLAPI int Tcl_ObjectDeleted(Tcl_Object object);
/* 15 */
@@ -81,7 +81,7 @@ TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
/* 17 */
TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
/* 18 */
-TCLAPI int Tcl_ObjectContextSkippedArgs(
+TCLAPI Tcl_Size Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context);
/* 19 */
TCLAPI void * Tcl_ClassGetMetadata(Tcl_Class clazz,
@@ -99,8 +99,8 @@ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object,
void *metadata);
/* 23 */
TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
- Tcl_ObjectContext context, int objc,
- Tcl_Obj *const *objv, int skip);
+ Tcl_ObjectContext context, Tcl_Size objc,
+ Tcl_Obj *const *objv, Tcl_Size skip);
/* 24 */
TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
Tcl_Object object);
@@ -116,9 +116,13 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp,
/* 28 */
TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
Tcl_Object object);
-/* Slot 29 is reserved */
-/* Slot 30 is reserved */
-/* Slot 31 is reserved */
+/* 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);
/* Slot 32 is reserved */
/* Slot 33 is reserved */
/* 34 */
@@ -143,27 +147,27 @@ typedef struct TclOOStubs {
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 isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 11 */
- Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, void *clientData); /* 12 */
- Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
+ 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, Tcl_Size objc, Tcl_Obj *const *objv, Tcl_Size 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 */
- int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
+ Tcl_Size (*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, int objc, Tcl_Obj *const *objv, int skip); /* 23 */
+ int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, Tcl_Size objc, Tcl_Obj *const *objv, Tcl_Size 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 */
- void (*reserved29)(void);
- void (*reserved30)(void);
- void (*reserved31)(void);
+ 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 */
void (*reserved32)(void);
void (*reserved33)(void);
void (*tclOOUnusedStubEntry) (void); /* 34 */
@@ -239,9 +243,12 @@ extern const TclOOStubs *tclOOStubsPtr;
(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
#define Tcl_GetObjectName \
(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
-/* Slot 29 is reserved */
-/* Slot 30 is reserved */
-/* Slot 31 is reserved */
+#define Tcl_MethodIsPrivate \
+ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
+#define Tcl_GetClassOfObject \
+ (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
+#define Tcl_GetObjectClassName \
+ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
/* Slot 32 is reserved */
/* Slot 33 is reserved */
#define TclOOUnusedStubEntry \
@@ -252,5 +259,9 @@ extern const TclOOStubs *tclOOStubsPtr;
/* !END!: Do not edit above this line. */
#undef TclOOUnusedStubEntry
+#define Tcl_MethodIsType2 Tcl_MethodIsType
+#define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod
+#define Tcl_NewMethod2 Tcl_NewMethod
+
#endif /* _TCLOODECLS */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 4b97740..5f10475 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
- * Copyright (c) 2006-2013 by Donal K. Fellows
+ * Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,12 @@
#include "tclOOInt.h"
/*
+ * The actual value used to mark private declaration frames.
+ */
+
+#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)
+
+/*
* The maximum length of fully-qualified object name to use in an errorinfo
* message. Longer than this will be curtailed.
*/
@@ -31,14 +37,17 @@ struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
+ const Tcl_MethodType resolverType;
};
-#define SLOT(name,getter,setter) \
+#define SLOT(name,getter,setter,resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
- setter, NULL, NULL}}
+ setter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+ resolver, NULL, NULL}}
/*
* A [string match] pattern used to determine if a method should be exported.
@@ -51,6 +60,7 @@ struct DeclaredSlot {
*/
static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
+static inline void BumpInstanceEpoch(Object *oPtr);
static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr);
static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
@@ -60,6 +70,8 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
static inline Class * GetClassInOuterContext(Tcl_Interp *interp,
Tcl_Obj *className, const char *errMsg);
+static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp,
+ Tcl_Obj *namespaceName);
static inline int InitDefineContext(Tcl_Interp *interp,
Tcl_Namespace *namespacePtr, Object *oPtr,
int objc, Tcl_Obj *const objv[]);
@@ -67,68 +79,76 @@ static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
-static int ClassFilterGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassFilterSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassMixinGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassMixinSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassSuperGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassSuperSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassVarsGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ClassVarsSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjFilterGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjFilterSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjMixinGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjMixinSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjVarsGet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjVarsSet(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
+static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet;
+static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet;
+static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
+static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet;
+static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet;
+static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
+static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet;
+static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet;
+static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
+static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet;
+static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
+static Tcl_MethodCallProc ResolveClass;
/*
* Now define the slots used in declarations.
*/
static const struct DeclaredSlot slots[] = {
- SLOT("define::filter", ClassFilterGet, ClassFilterSet),
- SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
- SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
- SLOT("define::variable", ClassVarsGet, ClassVarsSet),
- SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
- SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
- SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
- {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL),
+ SLOT("configuresupport::readableproperties",
+ ClassRPropsGet, ClassRPropsSet, NULL),
+ SLOT("configuresupport::writableproperties",
+ ClassWPropsGet, ClassWPropsSet, NULL),
+ SLOT("configuresupport::objreadableproperties",
+ ObjRPropsGet, ObjRPropsSet, NULL),
+ SLOT("configuresupport::objwritableproperties",
+ ObjWPropsGet, ObjWPropsSet, NULL),
+ {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};
+
+/*
+ * How to build the in-namespace name of a private variable. This is a pattern
+ * used with Tcl_ObjPrintf().
+ */
+
+#define PRIVATE_VARIABLE_PATTERN "%d : %s"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * IsPrivateDefine --
+ *
+ * Extracts whether the current context is handling private definitions.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+IsPrivateDefine(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (!iPtr->varFramePtr) {
+ return 0;
+ }
+ return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
+}
/*
* ----------------------------------------------------------------------
*
* BumpGlobalEpoch --
+ *
* Utility that ensures that call chains that are invalid will get thrown
* away at an appropriate time. Note that exactly which epoch gets
* advanced will depend on exactly what the class is tangled up in; in
@@ -157,13 +177,26 @@ BumpGlobalEpoch(
if (classPtr->thisPtr->mixins.num > 0) {
classPtr->thisPtr->epoch++;
+
+ /*
+ * Invalidate the property caches directly.
+ */
+
+ if (classPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(classPtr->properties.allReadableCache);
+ classPtr->properties.allReadableCache = NULL;
+ }
+ if (classPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(classPtr->properties.allWritableCache);
+ classPtr->properties.allWritableCache = NULL;
+ }
}
return;
}
/*
* Either there's no class (?!) or we're reconfiguring something that is
- * in use. Force regeneration of call chains.
+ * in use. Force regeneration of call chains and properties.
*/
TclOOGetFoundation(interp)->epoch++;
@@ -172,7 +205,35 @@ BumpGlobalEpoch(
/*
* ----------------------------------------------------------------------
*
+ * BumpInstanceEpoch --
+ *
+ * Advances the epoch and clears the property cache of an object. The
+ * equivalent for classes is BumpGlobalEpoch(), as classes have a more
+ * complex set of relationships to other entities.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+BumpInstanceEpoch(
+ Object *oPtr)
+{
+ oPtr->epoch++;
+ if (oPtr->properties.allReadableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allReadableCache);
+ oPtr->properties.allReadableCache = NULL;
+ }
+ if (oPtr->properties.allWritableCache) {
+ Tcl_DecrRefCount(oPtr->properties.allWritableCache);
+ oPtr->properties.allWritableCache = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -195,6 +256,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -234,9 +296,9 @@ TclOOObjectSetFilters(
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
- filtersList = ckalloc(size);
+ filtersList = (Tcl_Obj **)ckalloc(size);
} else {
- filtersList = ckrealloc(oPtr->filters.list, size);
+ filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -246,13 +308,14 @@ TclOOObjectSetFilters(
oPtr->filters.num = numFilters;
oPtr->flags &= ~USE_CLASS_CACHE;
}
- oPtr->epoch++; /* Only this object can be affected. */
+ BumpInstanceEpoch(oPtr); /* Only this object can be affected. */
}
/*
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -292,9 +355,9 @@ TclOOClassSetFilters(
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
- filtersList = ckalloc(size);
+ filtersList = (Tcl_Obj **)ckalloc(size);
} else {
- filtersList = ckrealloc(classPtr->filters.list, size);
+ filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
@@ -315,6 +378,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -347,10 +411,10 @@ TclOOObjectSetMixins(
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
- oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
+ oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
- oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
@@ -367,13 +431,14 @@ TclOOObjectSetMixins(
}
}
}
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
}
/*
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -404,10 +469,10 @@ TclOOClassSetMixins(
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
- classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
+ classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
- classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
+ classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
@@ -427,7 +492,126 @@ TclOOClassSetMixins(
/*
* ----------------------------------------------------------------------
*
+ * InstallStandardVariableMapping, InstallPrivateVariableMapping --
+ *
+ * Helpers for installing standard and private variable maps.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+InstallStandardVariableMapping(
+ VariableNameList *vnlPtr,
+ int varc,
+ Tcl_Obj *const *varv)
+{
+ Tcl_Obj *variableObj;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, *vnlPtr) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(vnlPtr->list);
+ } else if (i) {
+ vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
+ } else {
+ vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc);
+ }
+ }
+ vnlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ vnlPtr->list[n++] = varv[i];
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ vnlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+static inline void
+InstallPrivateVariableMapping(
+ PrivateVariableList *pvlPtr,
+ int varc,
+ Tcl_Obj *const *varv,
+ int creationEpoch)
+{
+ PrivateVariableMapping *privatePtr;
+ int i, n, created;
+ Tcl_HashTable uniqueTable;
+
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH_STRUCT(privatePtr, *pvlPtr) {
+ Tcl_DecrRefCount(privatePtr->variableObj);
+ Tcl_DecrRefCount(privatePtr->fullNameObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree(pvlPtr->list);
+ } else if (i) {
+ pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * varc);
+ } else {
+ pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc);
+ }
+ }
+
+ pvlPtr->num = 0;
+ if (varc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<varc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ if (created) {
+ privatePtr = &(pvlPtr->list[n++]);
+ privatePtr->variableObj = varv[i];
+ privatePtr->fullNameObj = Tcl_ObjPrintf(
+ PRIVATE_VARIABLE_PATTERN,
+ creationEpoch, Tcl_GetString(varv[i]));
+ Tcl_IncrRefCount(privatePtr->fullNameObj);
+ } else {
+ Tcl_DecrRefCount(varv[i]);
+ }
+ }
+ pvlPtr->num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != varc) {
+ pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
+ sizeof(PrivateVariableMapping) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* RenameDeleteMethod --
+ *
* Core of the code to rename and delete methods.
*
* ----------------------------------------------------------------------
@@ -451,7 +635,7 @@ RenameDeleteMethod(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"method %s does not exist", TclGetString(fromPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(fromPtr), NULL);
+ TclGetString(fromPtr), (void *)NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
@@ -465,14 +649,14 @@ RenameDeleteMethod(
renameToSelf:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot rename method to itself", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (void *)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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", (void *)NULL);
return TCL_ERROR;
}
}
@@ -497,7 +681,7 @@ RenameDeleteMethod(
* Complete the splicing by changing the method's name.
*/
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (toPtr) {
Tcl_IncrRefCount(toPtr);
Tcl_DecrRefCount(mPtr->namePtr);
@@ -517,6 +701,7 @@ RenameDeleteMethod(
* ----------------------------------------------------------------------
*
* TclOOUnknownDefinition --
+ *
* Handles what happens when an unknown command is encountered during the
* processing of a definition script. Works by finding a command in the
* operating definition namespace that the requested command is a unique
@@ -527,7 +712,7 @@ RenameDeleteMethod(
int
TclOOUnknownDefinition(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -541,20 +726,20 @@ TclOOUnknownDefinition(
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad call of unknown handler", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (void *)NULL);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
- soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
+ soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
- const char *nameStr = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+ const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
@@ -570,7 +755,7 @@ TclOOUnknownDefinition(
* Got one match, and only one match!
*/
- Tcl_Obj **newObjv =
+ Tcl_Obj **newObjv = (Tcl_Obj **)
TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
@@ -588,7 +773,7 @@ TclOOUnknownDefinition(
noMatch:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", soughtStr));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, (void *)NULL);
return TCL_ERROR;
}
@@ -596,6 +781,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -609,7 +795,7 @@ FindCommand(
Tcl_Namespace *const namespacePtr)
{
int length;
- const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
+ const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
@@ -656,6 +842,7 @@ FindCommand(
* ----------------------------------------------------------------------
*
* InitDefineContext --
+ *
* Does the magic incantations necessary to push the special stack frame
* used when processing object definitions. It is up to the caller to
* dispose of the frame (with TclPopStackFrame) when finished.
@@ -675,9 +862,8 @@ InitDefineContext(
if (namespacePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot process definitions; support namespace deleted",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ "no definition namespace available", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -698,6 +884,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -712,19 +899,20 @@ TclOOGetDefineCmdContext(
Tcl_Object object;
if ((iPtr->varFramePtr == NULL)
- || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+ || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
+ && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return NULL;
}
- object = iPtr->varFramePtr->clientData;
+ object = (Tcl_Object)iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
" deleted", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return NULL;
}
return object;
@@ -733,11 +921,12 @@ TclOOGetDefineCmdContext(
/*
* ----------------------------------------------------------------------
*
- * GetClassInOuterContext --
- * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
- * context that called oo::define (or equivalent). Note that this may
- * have to go up multiple levels to get the level that we started doing
- * definitions at.
+ * GetClassInOuterContext, GetNamespaceInOuterContext --
+ *
+ * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to
+ * perform the lookup in the context that called oo::define (or
+ * equivalent). Note that this may have to go up multiple levels to get
+ * the level that we started doing definitions at.
*
* ----------------------------------------------------------------------
*/
@@ -752,7 +941,8 @@ GetClassInOuterContext(
Object *oPtr;
CallFrame *savedFramePtr = iPtr->varFramePtr;
- while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
if (iPtr->varFramePtr->callerVarPtr == NULL) {
Tcl_Panic("getting outer context when already in global context");
}
@@ -766,16 +956,42 @@ GetClassInOuterContext(
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(className), NULL);
+ TclGetString(className), (void *)NULL);
return NULL;
}
return oPtr->classPtr;
}
+
+static inline Tcl_Namespace *
+GetNamespaceInOuterContext(
+ Tcl_Interp *interp,
+ Tcl_Obj *namespaceName)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Namespace *nsPtr;
+ int result;
+ CallFrame *savedFramePtr = iPtr->varFramePtr;
+
+ while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
+ || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
+ if (iPtr->varFramePtr->callerVarPtr == NULL) {
+ Tcl_Panic("getting outer context when already in global context");
+ }
+ iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
+ }
+ result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return nsPtr;
+}
/*
* ----------------------------------------------------------------------
*
* GenerateErrorInfo --
+ *
* Factored out code to generate part of the error trace messages.
*
* ----------------------------------------------------------------------
@@ -800,7 +1016,7 @@ GenerateErrorInfo(
int length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
- const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
+ const char *objName = TclGetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
@@ -814,6 +1030,7 @@ GenerateErrorInfo(
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
+ *
* Part of the implementation of the "oo::define" and "oo::objdefine"
* commands that is used to implement the more-than-one-argument case,
* applying ensemble-like tricks with dispatch so that error messages are
@@ -865,7 +1082,7 @@ MagicDefinitionInvoke(
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
/* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
- TclListObjGetElements(NULL, objPtr, &dummy, &objs);
+ TclListObjGetElementsM(NULL, objPtr, &dummy, &objs);
result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
if (isRoot) {
@@ -880,6 +1097,7 @@ MagicDefinitionInvoke(
* ----------------------------------------------------------------------
*
* TclOODefineObjCmd --
+ *
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
* object to be modified is known to the commands in the target
@@ -891,12 +1109,12 @@ MagicDefinitionInvoke(
int
TclOODefineObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -911,9 +1129,9 @@ TclOODefineObjCmd(
}
if (oPtr->classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s does not refer to a class",TclGetString(objv[1])));
+ "%s does not refer to a class", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objv[1]), NULL);
+ TclGetString(objv[1]), (void *)NULL);
return TCL_ERROR;
}
@@ -922,7 +1140,8 @@ TclOODefineObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -938,7 +1157,7 @@ TclOODefineObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -954,6 +1173,7 @@ TclOODefineObjCmd(
* ----------------------------------------------------------------------
*
* TclOOObjDefObjCmd --
+ *
* Implementation of the "oo::objdefine" command. Works by effectively
* doing the same as 'namespace eval', but with extra magic applied so
* that the object to be modified is known to the commands in the target
@@ -965,12 +1185,12 @@ TclOODefineObjCmd(
int
TclOOObjDefObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
@@ -989,7 +1209,8 @@ TclOOObjDefObjCmd(
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1005,7 +1226,7 @@ TclOOObjDefObjCmd(
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1021,6 +1242,7 @@ TclOOObjDefObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::define" command.
* Works by effectively doing the same as 'namespace eval', but with
* extra magic applied so that the object to be modified is known to the
@@ -1032,33 +1254,39 @@ TclOOObjDefObjCmd(
int
TclOODefineSelfObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
- Foundation *fPtr = TclOOGetFoundation(interp);
+ Tcl_Namespace *nsPtr;
Object *oPtr;
- int result;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
+ int result, isPrivate;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
+ if (objc < 2) {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+ }
+
+ isPrivate = IsPrivateDefine(interp);
+
/*
* Make the oo::objdefine namespace the current namespace and evaluate the
* command(s).
*/
- if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
+ if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
+ if (isPrivate) {
+ ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+ }
AddRef(oPtr);
if (objc == 2) {
@@ -1066,13 +1294,13 @@ TclOODefineSelfObjCmd(
Tcl_IncrRefCount(objNameObj);
result = TclEvalObjEx(interp, objv[1], 0,
- ((Interp *)interp)->cmdFramePtr, 2);
+ ((Interp *)interp)->cmdFramePtr, 1);
if (result == TCL_ERROR) {
GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
}
TclDecrRefCount(objNameObj);
} else {
- result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
+ result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv);
}
TclOODecrRefCount(oPtr);
@@ -1087,7 +1315,115 @@ TclOODefineSelfObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineObjSelfObjCmd --
+ *
+ * Implementation of the "self" subcommand of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjSelfObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefinePrivateObjCmd --
+ *
+ * Implementation of the "private" subcommand of the "oo::define"
+ * and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefinePrivateObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int isInstancePrivate = (clientData != NULL);
+ /* Just so that we can generate the correct
+ * error message depending on the context of
+ * usage of this function. */
+ Interp *iPtr = (Interp *) interp;
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int saved; /* The saved flag. We restore it on exit so
+ * that [private private ...] doesn't make
+ * things go weird. */
+ int result;
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
+ return TCL_OK;
+ }
+
+ /*
+ * Change the frame type flag while evaluating the body.
+ */
+
+ saved = iPtr->varFramePtr->isProcCallFrame;
+ iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
+
+ /*
+ * Evaluate the body; standard pattern.
+ */
+
+ AddRef(oPtr);
+ if (objc == 2) {
+ Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_IncrRefCount(objNameObj);
+ result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
+ if (result == TCL_ERROR) {
+ GenerateErrorInfo(interp, oPtr, objNameObj,
+ isInstancePrivate ? "object" : "class");
+ }
+ TclDecrRefCount(objNameObj);
+ } else {
+ result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
+ 1, objc, objv);
+ }
+ TclOODecrRefCount(oPtr);
+
+ /*
+ * Restore the frame type flag to what it was previously.
+ */
+
+ iPtr->varFramePtr->isProcCallFrame = saved;
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineClassObjCmd --
+ *
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
@@ -1096,7 +1432,7 @@ TclOODefineSelfObjCmd(
int
TclOODefineClassObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1117,13 +1453,13 @@ TclOODefineClassObjCmd(
if (oPtr->flags & ROOT_OBJECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the root object class", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
if (oPtr->flags & ROOT_CLASS) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not modify the class of the class of classes", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1143,7 +1479,7 @@ TclOODefineClassObjCmd(
if (oPtr == clsPtr->thisPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not change classes into an instance of themselves", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1186,7 +1522,7 @@ TclOODefineClassObjCmd(
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
}
}
return TCL_OK;
@@ -1196,6 +1532,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1204,7 +1541,7 @@ TclOODefineClassObjCmd(
int
TclOODefineConstructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1230,7 +1567,7 @@ TclOODefineConstructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[2], &bodyLength);
+ TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1263,7 +1600,93 @@ TclOODefineConstructorObjCmd(
/*
* ----------------------------------------------------------------------
*
+ * TclOODefineDefnNsObjCmd --
+ *
+ * Implementation of the "definitionnamespace" subcommand of the
+ * "oo::define" command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDefnNsObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Object *oPtr;
+ Tcl_Namespace *nsPtr;
+ Tcl_Obj *nsNamePtr, **storagePtr;
+
+ oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (!oPtr->classPtr) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to misuse API", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not modify the definition namespace of the root classes",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the arguments and work out what the user wants to do.
+ */
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_GetString(objv[objc - 1])[0]) {
+ nsNamePtr = NULL;
+ } else {
+ nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
+ if (nsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
+ Tcl_IncrRefCount(nsNamePtr);
+ }
+
+ /*
+ * Update the correct field of the class definition.
+ */
+
+ if (kind) {
+ storagePtr = &oPtr->classPtr->objDefinitionNs;
+ } else {
+ storagePtr = &oPtr->classPtr->clsDefinitionNs;
+ }
+ if (*storagePtr != NULL) {
+ Tcl_DecrRefCount(*storagePtr);
+ }
+ *storagePtr = nsNamePtr;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOODefineDeleteMethodObjCmd --
+ *
* Implementation of the "deletemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1293,7 +1716,7 @@ TclOODefineDeleteMethodObjCmd(
if (!isInstanceDeleteMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1309,7 +1732,7 @@ TclOODefineDeleteMethodObjCmd(
}
if (isInstanceDeleteMethod) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -1320,6 +1743,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1328,7 +1752,7 @@ TclOODefineDeleteMethodObjCmd(
int
TclOODefineDestructorObjCmd(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
@@ -1349,7 +1773,7 @@ TclOODefineDestructorObjCmd(
}
clsPtr = oPtr->classPtr;
- Tcl_GetStringFromObj(objv[1], &bodyLength);
+ TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
@@ -1384,6 +1808,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1417,7 +1842,7 @@ TclOODefineExportObjCmd(
if (!isInstanceExport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1433,7 +1858,7 @@ TclOODefineExportObjCmd(
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -1445,17 +1870,18 @@ TclOODefineExportObjCmd(
}
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
- if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+ if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
+ mPtr->flags &= ~TRUE_PRIVATE_METHOD;
changed = 1;
}
}
@@ -1466,7 +1892,7 @@ TclOODefineExportObjCmd(
if (changed) {
if (isInstanceExport) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -1478,6 +1904,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1509,11 +1936,14 @@ TclOODefineForwardObjCmd(
if (!isInstanceForward && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
? PUBLIC_METHOD : 0;
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ }
/*
* Create the method structure.
@@ -1538,6 +1968,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1551,12 +1982,28 @@ TclOODefineMethodObjCmd(
int objc,
Tcl_Obj *const *objv)
{
+ /*
+ * Table of export modes for methods and their corresponding enum.
+ */
+
+ static const char *const exportModes[] = {
+ "-export",
+ "-private",
+ "-unexport",
+ NULL
+ };
+ enum ExportMode {
+ MODE_EXPORT,
+ MODE_PRIVATE,
+ MODE_UNEXPORT
+ } exportMode;
+
int isInstanceMethod = (clientData != NULL);
Object *oPtr;
- int isPublic;
+ int isPublic = 0;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body");
return TCL_ERROR;
}
@@ -1567,11 +2014,33 @@ TclOODefineMethodObjCmd(
if (!isInstanceMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
- ? PUBLIC_METHOD : 0;
+ if (objc == 5) {
+ if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
+ 0, &exportMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (exportMode) {
+ case MODE_EXPORT:
+ isPublic = PUBLIC_METHOD;
+ break;
+ case MODE_PRIVATE:
+ isPublic = TRUE_PRIVATE_METHOD;
+ break;
+ case MODE_UNEXPORT:
+ isPublic = 0;
+ break;
+ }
+ } else {
+ if (IsPrivateDefine(interp)) {
+ isPublic = TRUE_PRIVATE_METHOD;
+ } else {
+ isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
+ ? PUBLIC_METHOD : 0;
+ }
+ }
/*
* Create the method by using the right back-end API.
@@ -1579,12 +2048,12 @@ TclOODefineMethodObjCmd(
if (isInstanceMethod) {
if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
} else {
if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
- objv[2], objv[3], NULL) == NULL) {
+ objv[objc - 2], objv[objc - 1], NULL) == NULL) {
return TCL_ERROR;
}
}
@@ -1595,6 +2064,7 @@ TclOODefineMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1623,7 +2093,7 @@ TclOODefineRenameMethodObjCmd(
if (!isInstanceRenameMethod && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1640,7 +2110,7 @@ TclOODefineRenameMethodObjCmd(
}
if (isInstanceRenameMethod) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, oPtr->classPtr);
}
@@ -1651,6 +2121,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1684,7 +2155,7 @@ TclOODefineUnexportObjCmd(
if (!isInstanceUnexport && !clsPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1700,7 +2171,7 @@ TclOODefineUnexportObjCmd(
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
+ oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
@@ -1712,17 +2183,17 @@ TclOODefineUnexportObjCmd(
}
if (isNew) {
- mPtr = ckalloc(sizeof(Method));
+ mPtr = (Method *)ckalloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
- if (isNew || mPtr->flags & PUBLIC_METHOD) {
- mPtr->flags &= ~PUBLIC_METHOD;
+ if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+ mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
changed = 1;
}
}
@@ -1733,7 +2204,7 @@ TclOODefineUnexportObjCmd(
if (changed) {
if (isInstanceUnexport) {
- oPtr->epoch++;
+ BumpInstanceEpoch(oPtr);
} else {
BumpGlobalEpoch(interp, clsPtr);
}
@@ -1745,6 +2216,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1799,6 +2271,7 @@ Tcl_ClassSetDestructor(
* ----------------------------------------------------------------------
*
* TclOODefineSlots --
+ *
* Create the "::oo::Slot" class and its standard instances. Class
* definition is empty at the stage (added by scripting).
*
@@ -1812,6 +2285,7 @@ TclOODefineSlots(
const struct DeclaredSlot *slotInfoPtr;
Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1);
Class *slotCls;
slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
@@ -1821,6 +2295,7 @@ TclOODefineSlots(
}
Tcl_IncrRefCount(getName);
Tcl_IncrRefCount(setName);
+ Tcl_IncrRefCount(resolveName);
for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
(Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0);
@@ -1832,9 +2307,14 @@ TclOODefineSlots(
&slotInfoPtr->getterType, NULL);
Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
+ if (slotInfoPtr->resolverType.callProc) {
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ &slotInfoPtr->resolverType, NULL);
+ }
}
Tcl_DecrRefCount(getName);
Tcl_DecrRefCount(setName);
+ Tcl_DecrRefCount(resolveName);
return TCL_OK;
}
@@ -1842,6 +2322,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1850,7 +2331,7 @@ TclOODefineSlots(
static int
ClassFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1870,7 +2351,7 @@ ClassFilterGet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1884,7 +2365,7 @@ ClassFilterGet(
static int
ClassFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1906,9 +2387,9 @@ ClassFilterSet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &filterc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1921,6 +2402,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -1929,7 +2411,7 @@ ClassFilterSet(
static int
ClassMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -1950,7 +2432,7 @@ ClassMixinGet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -1966,16 +2448,20 @@ ClassMixinGet(
static int
ClassMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc, i;
+ int mixinc, i, isNew;
Tcl_Obj **mixinv;
- Class **mixins;
+ Class **mixins;; /* The references to the classes to actually
+ * install. */
+ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a
+ * set of class references; it has no payload
+ * values and keys are always pointers. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -1989,14 +2475,15 @@ ClassMixinSet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &mixinc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2005,19 +2492,28 @@ ClassMixinSet(
i--;
goto freeAndError;
}
+ (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct mixin once", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ goto freeAndError;
+ }
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (void *)NULL);
goto freeAndError;
}
}
TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_OK;
freeAndError:
+ Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -2026,6 +2522,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2034,7 +2531,7 @@ ClassMixinSet(
static int
ClassSuperGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2055,7 +2552,7 @@ ClassSuperGet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
@@ -2070,7 +2567,7 @@ ClassSuperGet(
static int
ClassSuperSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2093,14 +2590,14 @@ ClassSuperSet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &superc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &superc,
&superv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2119,7 +2616,7 @@ ClassSuperSet(
*/
if (superc == 0) {
- superclasses = ckrealloc(superclasses, sizeof(Class *));
+ superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *));
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
} else {
@@ -2139,14 +2636,14 @@ ClassSuperSet(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
-1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(void *)NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (void *)NULL);
failedAfterAlloc:
for (; i-- > 0 ;) {
TclOODecrRefCount(superclasses[i]->thisPtr);
@@ -2176,7 +2673,7 @@ ClassSuperSet(
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
- ckfree((char *) oPtr->classPtr->superclasses.list);
+ ckfree(oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
oPtr->classPtr->superclasses.num = superc;
@@ -2192,6 +2689,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2200,14 +2698,14 @@ ClassSuperSet(
static int
ClassVarsGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2220,13 +2718,23 @@ ClassVarsGet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2234,7 +2742,7 @@ ClassVarsGet(
static int
ClassVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2242,7 +2750,7 @@ ClassVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
int i;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
@@ -2257,75 +2765,37 @@ ClassVarsSet(
} else if (!oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL);
return TCL_ERROR;
- } else if (TclListObjGetElements(interp, objv[0], &varc,
+ } else if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
- Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
- Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL);
return TCL_ERROR;
}
}
- for (i = 0; i < varc; i++) {
- Tcl_IncrRefCount(varv[i]);
- }
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != varc) {
- if (varc == 0) {
- ckfree((char *) oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
- } else {
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
- }
- }
-
- oPtr->classPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
-
- Tcl_InitObjHashTable(&uniqueTable);
- for (i = n = 0; i < varc; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
- if (created) {
- oPtr->classPtr->variables.list[n++] = varv[i];
- } else {
- Tcl_DecrRefCount(varv[i]);
- }
- }
- oPtr->classPtr->variables.num = n;
-
- /*
- * Shouldn't be necessary, but maintain num/list invariant.
- */
-
- oPtr->classPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
- Tcl_DeleteHashTable(&uniqueTable);
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
+ varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
}
return TCL_OK;
}
@@ -2334,6 +2804,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2342,7 +2813,7 @@ ClassVarsSet(
static int
ObjFilterGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2370,7 +2841,7 @@ ObjFilterGet(
static int
ObjFilterSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2388,7 +2859,7 @@ ObjFilterSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &filterc,
+ if (TclListObjGetElementsM(interp, objv[0], &filterc,
&filterv) != TCL_OK) {
return TCL_ERROR;
}
@@ -2401,6 +2872,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2409,7 +2881,7 @@ ObjFilterSet(
static int
ObjMixinGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2441,17 +2913,20 @@ ObjMixinGet(
static int
ObjMixinSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc;
+ int mixinc, i, isNew;
Tcl_Obj **mixinv;
- Class **mixins;
- int i;
+ Class **mixins; /* The references to the classes to actually
+ * install. */
+ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a
+ * set of class references; it has no payload
+ * values and keys are always pointers. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2461,31 +2936,45 @@ ObjMixinSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &mixinc,
+ if (TclListObjGetElementsM(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
- mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
- TclStackFree(interp, mixins);
- return TCL_ERROR;
+ goto freeAndError;
+ }
+ (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct mixin once", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ goto freeAndError;
}
}
TclOOObjectSetMixins(oPtr, mixinc, mixins);
TclStackFree(interp, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
+ return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
@@ -2494,14 +2983,14 @@ ObjMixinSet(
static int
ObjVarsGet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *resultObj, *variableObj;
+ Tcl_Obj *resultObj;
int i;
if (Tcl_ObjectContextSkippedArgs(context) != objc) {
@@ -2513,8 +3002,18 @@ ObjVarsGet(
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (IsPrivateDefine(interp)) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2522,7 +3021,7 @@ ObjVarsGet(
static int
ObjVarsSet(
- ClientData clientData,
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
@@ -2530,7 +3029,7 @@ ObjVarsSet(
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
- Tcl_Obj **varv, *variableObj;
+ Tcl_Obj **varv;
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2540,73 +3039,483 @@ ObjVarsSet(
return TCL_ERROR;
}
objv += Tcl_ObjectContextSkippedArgs(context);
- if (TclListObjGetElements(interp, objv[0], &varc,
+ if (TclListObjGetElementsM(interp, objv[0], &varc,
&varv) != TCL_OK) {
return TCL_ERROR;
}
for (i = 0; i < varc; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "contain namespace separators"));
- Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_StringMatch(varName, "*(*)")) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid declared variable name \"%s\": must not %s",
varName, "refer to an array element"));
- Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL);
return TCL_ERROR;
}
}
- for (i = 0; i < varc; i++) {
- Tcl_IncrRefCount(varv[i]);
+
+ if (IsPrivateDefine(interp)) {
+ InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
+ oPtr->creationEpoch);
+ } else {
+ InstallStandardVariableMapping(&oPtr->variables, varc, varv);
}
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ResolveClass --
+ *
+ * Implementation of the "Resolve" support method for some slots (those
+ * that are slots around a list of classes). This resolves possible class
+ * names to their fully-qualified names if possible.
+ *
+ * ----------------------------------------------------------------------
+ */
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
+static int
+ResolveClass(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int idx = Tcl_ObjectContextSkippedArgs(context);
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Class *clsPtr;
+
+ /*
+ * Check if were called wrongly. The definition context isn't used...
+ * except that GetClassInOuterContext() assumes that it is there.
+ */
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (objc != idx + 1) {
+ Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
+ return TCL_ERROR;
}
- if (i != varc) {
- if (varc == 0) {
- ckfree((char *) oPtr->variables.list);
+
+ /*
+ * Resolve the class if possible. If not, remove any resolution error and
+ * return what we've got anyway as the failure might not be fatal overall.
+ */
+
+ clsPtr = GetClassInOuterContext(interp, objv[idx],
+ "USER SHOULD NOT SEE THIS MESSAGE");
+ if (clsPtr == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, objv[idx]);
+ } else {
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
+ *
+ * Implementations of the "readableproperties" slot accessors for classes
+ * and instances.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InstallReadableProps(
+ PropertyStorage *props,
+ Tcl_Size objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *propObj;
+ Tcl_Size i, n;
+ int created;
+ Tcl_HashTable uniqueTable;
+
+ if (props->allReadableCache) {
+ Tcl_DecrRefCount(props->allReadableCache);
+ props->allReadableCache = NULL;
+ }
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+ FOREACH(propObj, props->readable) {
+ Tcl_DecrRefCount(propObj);
+ }
+ if (i != objc) {
+ if (objc == 0) {
+ ckfree(props->readable.list);
} else if (i) {
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * varc);
+ props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * objc);
} else {
- oPtr->variables.list = (Tcl_Obj **)
- ckalloc(sizeof(Tcl_Obj *) * varc);
+ props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
}
}
- oPtr->variables.num = 0;
- if (varc > 0) {
- int created, n;
- Tcl_HashTable uniqueTable;
+ props->readable.num = 0;
+ if (objc > 0) {
+ Tcl_InitObjHashTable(&uniqueTable);
+ for (i=n=0 ; i<objc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
+ if (created) {
+ props->readable.list[n++] = objv[i];
+ } else {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ }
+ props->readable.num = n;
+
+ /*
+ * Shouldn't be necessary, but maintain num/list invariant.
+ */
+
+ if (n != objc) {
+ props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
+ Tcl_DeleteHashTable(&uniqueTable);
+ }
+}
+static int
+ClassRPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ 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", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(resultObj);
+ FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassRPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Size varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != 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", (void *)NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ return TCL_OK;
+}
+
+static int
+ObjRPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ TclNewObj(resultObj);
+ FOREACH(propNameObj, oPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjRPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Size varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallReadableProps(&oPtr->properties, varc, varv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
+ *
+ * Implementations of the "writableproperties" slot accessors for classes
+ * and instances.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InstallWritableProps(
+ PropertyStorage *props,
+ Tcl_Size objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *propObj;
+ Tcl_Size i, n;
+ int created;
+ Tcl_HashTable uniqueTable;
+
+ if (props->allWritableCache) {
+ Tcl_DecrRefCount(props->allWritableCache);
+ props->allWritableCache = NULL;
+ }
+
+ for (i=0 ; i<objc ; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+ FOREACH(propObj, props->writable) {
+ Tcl_DecrRefCount(propObj);
+ }
+ if (i != objc) {
+ if (objc == 0) {
+ ckfree(props->writable.list);
+ } else if (i) {
+ props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * objc);
+ } else {
+ props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
+ }
+ }
+ props->writable.num = 0;
+ if (objc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
- for (i = n = 0; i < varc; i++) {
- Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+ for (i=n=0 ; i<objc ; i++) {
+ Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
if (created) {
- oPtr->variables.list[n++] = varv[i];
+ props->writable.list[n++] = objv[i];
} else {
- Tcl_DecrRefCount(varv[i]);
+ Tcl_DecrRefCount(objv[i]);
}
}
- oPtr->variables.num = n;
+ props->writable.num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
- oPtr->variables.list = (Tcl_Obj **)
- ckrealloc((char *) oPtr->variables.list,
- sizeof(Tcl_Obj *) * n);
+ if (n != objc) {
+ props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
+ sizeof(Tcl_Obj *) * n);
+ }
Tcl_DeleteHashTable(&uniqueTable);
}
+}
+
+static int
+ClassWPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ 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", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ TclNewObj(resultObj);
+ FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassWPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Size varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "propertyList");
+ 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", (void *)NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
+ BumpGlobalEpoch(interp, oPtr->classPtr);
+ return TCL_OK;
+}
+
+static int
+ObjWPropsGet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *propNameObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ TclNewObj(resultObj);
+ FOREACH(propNameObj, oPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjWPropsSet(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Size varc;
+ Tcl_Obj **varv;
+
+ if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "propertyList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ InstallWritableProps(&oPtr->properties, varc, varv);
return TCL_OK;
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 9f1233c..6aa3214 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo-related [info]
* subcommands.
*
- * Copyright (c) 2006-2011 by Donal K. Fellows
+ * Copyright © 2006-2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,21 +17,25 @@
#include "tclOOInt.h"
static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void SortPropList(Tcl_Obj *list);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
+static Tcl_ObjCmdProc InfoObjectIdCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
+static Tcl_ObjCmdProc InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
+static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
@@ -39,6 +43,7 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
+static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
@@ -50,6 +55,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
static const EnsembleImplMap infoObjectCmds[] = {
{"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+ {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -58,7 +64,8 @@ static const EnsembleImplMap infoObjectCmds[] = {
{"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
- {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -71,6 +78,7 @@ static const EnsembleImplMap infoClassCmds[] = {
{"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -78,9 +86,10 @@ static const EnsembleImplMap infoClassCmds[] = {
{"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
- {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -149,7 +158,7 @@ GetClassFromObj(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
- TclGetString(objPtr), NULL);
+ TclGetString(objPtr), (void *)NULL);
return NULL;
}
return oPtr->classPtr;
@@ -167,7 +176,7 @@ GetClassFromObj(
static int
InfoObjectClassCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -202,11 +211,11 @@ InfoObjectClassCmd(
continue;
}
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
return TCL_OK;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
return TCL_OK;
}
@@ -224,7 +233,7 @@ InfoObjectClassCmd(
static int
InfoObjectDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -254,15 +263,15 @@ InfoObjectDefnCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -281,7 +290,7 @@ InfoObjectDefnCmd(
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -298,7 +307,7 @@ InfoObjectDefnCmd(
static int
InfoObjectFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -337,7 +346,7 @@ InfoObjectFiltersCmd(
static int
InfoObjectForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -365,16 +374,16 @@ InfoObjectForwardCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -394,7 +403,7 @@ InfoObjectForwardCmd(
static int
InfoObjectIsACmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -513,21 +522,28 @@ InfoObjectIsACmd(
static int
InfoObjectMethodsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
- int flag = PUBLIC_METHOD, recurse = 0;
+ int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
static const char *const options[] = {
- "-all", "-localprivate", "-private", NULL
+ "-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
- OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+ };
+ static const char *const scopes[] = {
+ "private", "public", "unexported"
+ };
+ enum Scopes {
+ SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
+ SCOPE_LOCALPRIVATE
};
if (objc < 2) {
@@ -556,14 +572,45 @@ InfoObjectMethodsCmd(
case OPT_PRIVATE:
flag = 0;
break;
+ case OPT_SCOPE:
+ if (++i >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing option for -scope"));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+ (void *)NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+ &scope) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
}
}
}
+ if (scope != -1) {
+ recurse = 0;
+ switch (scope) {
+ case SCOPE_PRIVATE:
+ flag = TRUE_PRIVATE_METHOD;
+ break;
+ case SCOPE_PUBLIC:
+ flag = PUBLIC_METHOD;
+ break;
+ case SCOPE_LOCALPRIVATE:
+ flag = PRIVATE_METHOD;
+ break;
+ case SCOPE_UNEXPORTED:
+ flag = 0;
+ break;
+ }
+ }
TclNewObj(resultObj);
if (recurse) {
const char **names;
- int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
+ int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
+ &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -574,7 +621,7 @@ InfoObjectMethodsCmd(
}
} else if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
@@ -595,7 +642,7 @@ InfoObjectMethodsCmd(
static int
InfoObjectMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -623,10 +670,10 @@ InfoObjectMethodTypeCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -652,7 +699,7 @@ InfoObjectMethodTypeCmd(
static int
InfoObjectMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -686,6 +733,38 @@ InfoObjectMixinsCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoObjectIdCmd --
+ *
+ * Implements [info object creationid $objName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectIdCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectNsCmd --
*
* Implements [info object namespace $objName]
@@ -695,7 +774,7 @@ InfoObjectMixinsCmd(
static int
InfoObjectNsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -721,34 +800,50 @@ InfoObjectNsCmd(
*
* InfoObjectVariablesCmd --
*
- * Implements [info object variables $objName]
+ * Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
- Tcl_Obj *variableObj, *resultObj;
- int i;
+ Tcl_Obj *resultObj;
+ int i, isPrivate = 0;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "objName");
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
+ if (objc == 3) {
+ if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+ return TCL_ERROR;
+ }
+ isPrivate = 1;
+ }
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
- FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (isPrivate) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -766,7 +861,7 @@ InfoObjectVariablesCmd(
static int
InfoObjectVarsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -827,7 +922,7 @@ InfoObjectVarsCmd(
static int
InfoClassConstrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -852,7 +947,7 @@ InfoClassConstrCmd(
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (void *)NULL);
return TCL_ERROR;
}
@@ -888,7 +983,7 @@ InfoClassConstrCmd(
static int
InfoClassDefnCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -912,15 +1007,15 @@ InfoClassDefnCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+ procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -939,7 +1034,7 @@ InfoClassDefnCmd(
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -947,6 +1042,56 @@ InfoClassDefnCmd(
/*
* ----------------------------------------------------------------------
*
+ * InfoClassDefnNsCmd --
+ *
+ * Implements [info class definitionnamespace $clsName ?$kind?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassDefnNsCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *kindList[] = {
+ "-class",
+ "-instance",
+ NULL
+ };
+ int kind = 0;
+ Tcl_Obj *nsNamePtr;
+ Class *clsPtr;
+
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0,
+ &kind) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (kind) {
+ nsNamePtr = clsPtr->objDefinitionNs;
+ } else {
+ nsNamePtr = clsPtr->clsDefinitionNs;
+ }
+ if (nsNamePtr) {
+ Tcl_SetObjResult(interp, nsNamePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoClassDestrCmd --
*
* Implements [info class destructor $clsName]
@@ -956,7 +1101,7 @@ InfoClassDefnCmd(
static int
InfoClassDestrCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -980,7 +1125,7 @@ InfoClassDestrCmd(
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (void *)NULL);
return TCL_ERROR;
}
@@ -1000,7 +1145,7 @@ InfoClassDestrCmd(
static int
InfoClassFiltersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1038,7 +1183,7 @@ InfoClassFiltersCmd(
static int
InfoClassForwardCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1060,16 +1205,16 @@ InfoClassForwardCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+ prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
@@ -1089,7 +1234,7 @@ InfoClassForwardCmd(
static int
InfoClassInstancesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1130,27 +1275,33 @@ InfoClassInstancesCmd(
*
* InfoClassMethodsCmd --
*
- * Implements [info class methods $clsName ?-private?]
+ * Implements [info class methods $clsName ?options...?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMethodsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- int flag = PUBLIC_METHOD, recurse = 0;
+ int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
Class *clsPtr;
static const char *const options[] = {
- "-all", "-localprivate", "-private", NULL
+ "-all", "-localprivate", "-private", "-scope", NULL
};
enum Options {
- OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
+ OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
+ };
+ static const char *const scopes[] = {
+ "private", "public", "unexported"
+ };
+ enum Scopes {
+ SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
};
if (objc < 2) {
@@ -1179,9 +1330,36 @@ InfoClassMethodsCmd(
case OPT_PRIVATE:
flag = 0;
break;
+ case OPT_SCOPE:
+ if (++i >= objc) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing option for -scope"));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
+ (void *)NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
+ &scope) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
}
}
}
+ if (scope != -1) {
+ recurse = 0;
+ switch (scope) {
+ case SCOPE_PRIVATE:
+ flag = TRUE_PRIVATE_METHOD;
+ break;
+ case SCOPE_PUBLIC:
+ flag = PUBLIC_METHOD;
+ break;
+ case SCOPE_UNEXPORTED:
+ flag = 0;
+ break;
+ }
+ }
TclNewObj(resultObj);
if (recurse) {
@@ -1199,7 +1377,7 @@ InfoClassMethodsCmd(
FOREACH_HASH_DECLS;
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
@@ -1220,7 +1398,7 @@ InfoClassMethodsCmd(
static int
InfoClassMethodTypeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1244,10 +1422,10 @@ InfoClassMethodTypeCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[2]), (void *)NULL);
return TCL_ERROR;
}
- mPtr = Tcl_GetHashValue(hPtr);
+ mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
@@ -1272,7 +1450,7 @@ InfoClassMethodTypeCmd(
static int
InfoClassMixinsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1314,7 +1492,7 @@ InfoClassMixinsCmd(
static int
InfoClassSubsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1369,7 +1547,7 @@ InfoClassSubsCmd(
static int
InfoClassSupersCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1401,34 +1579,50 @@ InfoClassSupersCmd(
*
* InfoClassVariablesCmd --
*
- * Implements [info class variables $clsName]
+ * Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
- Tcl_Obj *variableObj, *resultObj;
- int i;
+ Tcl_Obj *resultObj;
+ int i, isPrivate = 0;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className");
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
+ if (objc == 3) {
+ if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
+ return TCL_ERROR;
+ }
+ isPrivate = 1;
+ }
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
TclNewObj(resultObj);
- FOREACH(variableObj, clsPtr->variables) {
- Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ if (isPrivate) {
+ PrivateVariableMapping *privatePtr;
+
+ FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
+ }
+ } else {
+ Tcl_Obj *variableObj;
+
+ FOREACH(variableObj, clsPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -1446,7 +1640,7 @@ InfoClassVariablesCmd(
static int
InfoObjectCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1467,7 +1661,8 @@ InfoObjectCallCmd(
* Get the call context and render its call chain.
*/
- contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+ contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
+ NULL);
if (contextPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot construct any call chain", -1));
@@ -1491,7 +1686,7 @@ InfoObjectCallCmd(
static int
InfoClassCallCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1524,6 +1719,184 @@ InfoClassCallCmd(
}
/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassPropCmd, InfoObjectPropCmd --
+ *
+ * Implements [info class properties $clsName ?$option...?] and
+ * [info object properties $objName ?$option...?]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+enum PropOpt {
+ PROP_ALL, PROP_READABLE, PROP_WRITABLE
+};
+static const char *const propOptNames[] = {
+ "-all", "-readable", "-writable",
+ NULL
+};
+
+static int
+InfoClassPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Class *clsPtr;
+ int i, idx, all = 0, writable = 0, allocated = 0;
+ Tcl_Obj *result, *propObj;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
+ return TCL_ERROR;
+ }
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
+ if (allocated) {
+ SortPropList(result);
+ }
+ } else {
+ TclNewObj(result);
+ if (writable) {
+ FOREACH(propObj, clsPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ } else {
+ FOREACH(propObj, clsPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+static int
+InfoObjectPropCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Object *oPtr;
+ int i, idx, all = 0, writable = 0, allocated = 0;
+ Tcl_Obj *result, *propObj;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
+ return TCL_ERROR;
+ }
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case PROP_ALL:
+ all = 1;
+ break;
+ case PROP_READABLE:
+ writable = 0;
+ break;
+ case PROP_WRITABLE:
+ writable = 1;
+ break;
+ }
+ }
+
+ /*
+ * Get the properties.
+ */
+
+ if (all) {
+ result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
+ if (allocated) {
+ SortPropList(result);
+ }
+ } else {
+ TclNewObj(result);
+ if (writable) {
+ FOREACH(propObj, oPtr->properties.writable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ } else {
+ FOREACH(propObj, oPtr->properties.readable) {
+ Tcl_ListObjAppendElement(NULL, result, propObj);
+ }
+ }
+ SortPropList(result);
+ }
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SortPropList --
+ * Sort a list of names of properties. Simple support function. Assumes
+ * that the list Tcl_Obj is unshared and doesn't have a string
+ * representation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PropNameCompare(
+ const void *a,
+ const void *b)
+{
+ Tcl_Obj *first = *(Tcl_Obj **) a;
+ Tcl_Obj *second = *(Tcl_Obj **) b;
+
+ return strcmp(Tcl_GetString(first), Tcl_GetString(second));
+}
+
+static void
+SortPropList(
+ Tcl_Obj *list)
+{
+ Tcl_Size ec;
+ Tcl_Obj **ev;
+
+ Tcl_ListObjGetElements(NULL, list, &ec, &ev);
+ qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 2931044..82422b9 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -46,7 +46,7 @@ typedef struct Method {
/* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. */
- int refCount;
+ Tcl_Size refCount;
void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
struct Object *declaringObjectPtr;
@@ -83,7 +83,7 @@ typedef struct ProcedureMethod {
* includes the argument definition and the
* body bytecodes. */
int flags; /* Flags to control features. */
- int refCount;
+ Tcl_Size refCount;
void *clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
@@ -125,6 +125,18 @@ typedef struct ForwardMethod {
} ForwardMethod;
/*
+ * Structure used in private variable mappings. Describes the mapping of a
+ * single variable from the user's local name to the system's storage name.
+ * [TIP #500]
+ */
+
+typedef struct {
+ Tcl_Obj *variableObj; /* Name used within methods. This is the part
+ * that is properly under user control. */
+ Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */
+} PrivateVariableMapping;
+
+/*
* Helper definitions that declare a "list" array. The two varieties are
* either optimized for simplicity (in the case that the whole array is
* typically assigned at once) or efficiency (in the case that the array is
@@ -137,9 +149,36 @@ typedef struct ForwardMethod {
*/
#define LIST_STATIC(listType_t) \
- struct { int num; listType_t *list; }
+ struct { Tcl_Size num; listType_t *list; }
#define LIST_DYNAMIC(listType_t) \
- struct { int num, size; listType_t *list; }
+ struct { Tcl_Size num, size; listType_t *list; }
+
+/*
+ * These types are needed in function arguments.
+ */
+
+typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
+typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
+
+/*
+ * This type is used in various places.
+ */
+
+typedef struct {
+ LIST_STATIC(Tcl_Obj *) readable;
+ /* The readable properties slot. */
+ LIST_STATIC(Tcl_Obj *) writable;
+ /* The writable properties slot. */
+ Tcl_Obj *allReadableCache; /* The cache of all readable properties
+ * exposed by this object or class (in its
+ * stereotypical instancs). Contains a sorted
+ * unique list if not NULL. */
+ Tcl_Obj *allWritableCache; /* The cache of all writable properties
+ * exposed by this object or class (in its
+ * stereotypical instances). Contains a sorted
+ * unique list if not NULL. */
+ int epoch; /* The epoch that the caches are valid for. */
+} PropertyStorage;
/*
* Now, the definition of what an object actually is.
@@ -163,20 +202,20 @@ typedef struct Object {
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
- * for everything else. It points to the class
- * structure. */
- int refCount; /* Number of strong references to this object.
+ * for everything else. It points to the class
+ * structure. */
+ Tcl_Size refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
* avoid Tcl_Preserve. */
int flags;
- int creationEpoch; /* Unique value to make comparisons of objects
+ Tcl_Size creationEpoch; /* Unique value to make comparisons of objects
* easier. */
- int epoch; /* Per-object epoch, incremented when the way
+ Tcl_Size epoch; /* Per-object epoch, incremented when the way
* an object should resolve call chains is
* changed. */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
- * the ClientData values that are the values
+ * the void *values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
@@ -186,13 +225,21 @@ typedef struct Object {
Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
- LIST_STATIC(Tcl_Obj *) variables;
+ VariableNameList variables;
+ PrivateVariableList privateVariables;
+ /* Configurations for the variable resolver
+ * used inside methods. */
+ Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
+ * command. */
+ PropertyStorage properties; /* Information relating to the lists of
+ * properties that this object *claims* to
+ * support. */
} Object;
-#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
- * been destroyed */
-#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the
- object has began */
+#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
+ * been destroyed */
+#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor
+ * script for the object has began */
#define OO_UNUSED_4 4 /* No longer used. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
@@ -211,7 +258,14 @@ typedef struct Object {
* 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. */
+#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
@@ -252,7 +306,7 @@ typedef struct Class {
Method *destructorPtr; /* Method record of the class destructor (if
* any). */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
- * the ClientData values that are the values
+ * the void *values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
@@ -266,7 +320,31 @@ typedef struct Class {
* object doesn't override with its own mixins
* (and filters and method implementations for
* when getting method chains). */
- LIST_STATIC(Tcl_Obj *) variables;
+ VariableNameList variables;
+ PrivateVariableList privateVariables;
+ /* Configurations for the variable resolver
+ * used inside methods. */
+ Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as classes. If NULL, use the value from the
+ * class hierarchy. It's an error at
+ * [oo::define] call time if this namespace is
+ * defined but doesn't exist; we also check at
+ * setting time but don't check between
+ * times. */
+ Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for
+ * definitions commands of instances of this
+ * class in when those instances are defined
+ * as instances. If NULL, use the value from
+ * the class hierarchy. It's an error at
+ * [oo::objdefine]/[self] call time if this
+ * namespace is defined but doesn't exist; we
+ * also check at setting time but don't check
+ * between times. */
+ PropertyStorage properties; /* Information relating to the lists of
+ * properties that this class *claims* to
+ * support. */
} Class;
/*
@@ -277,7 +355,7 @@ typedef struct Class {
*/
typedef struct ThreadLocalData {
- int nsCount; /* Epoch counter is used for keeping
+ Tcl_Size nsCount; /* Epoch counter is used for keeping
* the values used in Tcl_Obj internal
* representations sane. Must be thread-local
* because Tcl_Objs can cross interpreter
@@ -301,7 +379,7 @@ typedef struct Foundation {
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
- int epoch; /* Used to invalidate method chains when the
+ Tcl_Size epoch; /* Used to invalidate method chains when the
* class structure changes. */
ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
* namespace to each object. */
@@ -335,16 +413,16 @@ struct MInvoke {
};
typedef struct CallChain {
- int objectCreationEpoch; /* The object's creation epoch. Note that the
+ Tcl_Size objectCreationEpoch;/* The object's creation epoch. Note that the
* object reference is not stored in the call
* chain; it is in the call context. */
- int objectEpoch; /* Local (object structure) epoch counter
+ Tcl_Size objectEpoch; /* Local (object structure) epoch counter
* snapshot. */
- int epoch; /* Global (class structure) epoch counter
+ Tcl_Size epoch; /* Global (class structure) epoch counter
* snapshot. */
int flags; /* Assorted flags, see below. */
- int refCount; /* Reference count. */
- int numChain; /* Size of the call chain. */
+ Tcl_Size refCount; /* Reference count. */
+ Tcl_Size numChain; /* Size of the call chain. */
struct MInvoke *chain; /* Array of call chain entries. May point to
* staticChain if the number of entries is
* small. */
@@ -353,9 +431,9 @@ typedef struct CallChain {
typedef struct CallContext {
Object *oPtr; /* The object associated with this call. */
- int index; /* Index into the call chain of the currently
+ Tcl_Size index; /* Index into the call chain of the currently
* executing method implementation. */
- int skip; /* Current number of arguments to skip; can
+ Tcl_Size skip; /* Current number of arguments to skip; can
* vary depending on whether it is a direct
* method call or a continuation via the
* [next] command. */
@@ -372,6 +450,11 @@ typedef struct CallContext {
#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
#define CONSTRUCTOR 0x08 /* This is a constructor. */
#define DESTRUCTOR 0x10 /* This is a destructor. */
+#define TRUE_PRIVATE_METHOD 0x20
+ /* This is a private method only accessible
+ * from other methods defined on this class
+ * or instance. [TIP #500] */
+#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
/*
* Structure containing definition information about basic class methods.
@@ -390,89 +473,40 @@ typedef struct {
*/
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
-MODULE_SCOPE int TclOODefineObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOObjDefObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineConstructorObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineDestructorObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineExportObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineForwardObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineRenameMethodObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineUnexportObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineClassObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineSelfObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOUnknownDefinition(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOCopyObjectCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOONextObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOONextToObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOSelfObjCmd(void *clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
+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 int TclOO_Class_Constructor(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_Create(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_CreateNs(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Class_New(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Destroy(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Eval(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_LinkVar(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_Unknown(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOO_Object_VarName(void *clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
+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
@@ -486,8 +520,8 @@ MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
- const char *nsNameStr, int objc,
- Tcl_Obj *const *objv, int skip,
+ const char *nsNameStr, Tcl_Size objc,
+ Tcl_Obj *const *objv, Tcl_Size skip,
Tcl_Object *objectPtr);
MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
Class *classPtr,
@@ -502,9 +536,16 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp,
Object *oPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
+MODULE_SCOPE Tcl_Obj * TclOOGetAllClassProperties(Class *clsPtr,
+ int writable, int *allocated);
+MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr,
+ int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
+ Object *contextObjPtr, Class *contextClsPtr,
Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
+ 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);
@@ -513,7 +554,8 @@ MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
int flags, const char ***stringsPtr);
-MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
+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);
@@ -521,8 +563,8 @@ 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, int objc,
- Tcl_Obj *const *objv, int skip);
+ Tcl_ObjectContext context, Tcl_Size objc,
+ Tcl_Obj *const *objv, Tcl_Size skip);
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
@@ -564,21 +606,32 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
} 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
+ * variable set to a pointer to each of those elements in turn.
+ * REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details.
+ */
+
+#define FOREACH_STRUCT(var,ary) \
+ if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++)
+
+/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
* does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
* only iterates over values.
+ * REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
- ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
- (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
+ (*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\
+ *(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
- ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
+ (*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
index 6a5cfd3..730a73a 100644
--- a/generic/tclOOIntDecls.h
+++ b/generic/tclOOIntDecls.h
@@ -42,7 +42,7 @@ TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
ProcedureMethod **pmPtrPtr);
/* 5 */
TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv,
+ Tcl_Size objc, Tcl_Obj *const *objv,
int publicOnly, Class *startCls);
/* 6 */
TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr);
@@ -75,21 +75,21 @@ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp,
/* 11 */
TCLAPI int TclOOInvokeObject(Tcl_Interp *interp,
Tcl_Object object, Tcl_Class startCls,
- int publicPrivate, int objc,
+ int publicPrivate, Tcl_Size objc,
Tcl_Obj *const *objv);
/* 12 */
-TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters,
- Tcl_Obj *const *filters);
+TCLAPI void TclOOObjectSetFilters(Object *oPtr,
+ Tcl_Size numFilters, Tcl_Obj *const *filters);
/* 13 */
TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp,
- Class *classPtr, int numFilters,
+ Class *classPtr, Tcl_Size numFilters,
Tcl_Obj *const *filters);
/* 14 */
-TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins,
- Class *const *mixins);
+TCLAPI void TclOOObjectSetMixins(Object *oPtr,
+ Tcl_Size numMixins, Class *const *mixins);
/* 15 */
TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp,
- Class *classPtr, int numMixins,
+ Class *classPtr, Tcl_Size numMixins,
Class *const *mixins);
typedef struct TclOOIntStubs {
@@ -101,17 +101,17 @@ typedef struct TclOOIntStubs {
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, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */
+ int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, Tcl_Size 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, int objc, Tcl_Obj *const *objv); /* 11 */
- void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */
- void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */
- void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */
- void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */
+ int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, Tcl_Size objc, Tcl_Obj *const *objv); /* 11 */
+ void (*tclOOObjectSetFilters) (Object *oPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 12 */
+ void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numFilters, Tcl_Obj *const *filters); /* 13 */
+ void (*tclOOObjectSetMixins) (Object *oPtr, Tcl_Size numMixins, Class *const *mixins); /* 14 */
+ void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, Tcl_Size numMixins, Class *const *mixins); /* 15 */
} TclOOIntStubs;
extern const TclOOIntStubs *tclOOIntStubsPtr;
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index edaa593..893c05e 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -3,7 +3,7 @@
*
* This file contains code to create and manage methods.
*
- * Copyright (c) 2005-2011 Donal K. Fellows
+ * Copyright © 2005-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.
@@ -80,12 +80,9 @@ static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
static void DeleteProcedureMethod(void *clientData);
static int CloneProcedureMethod(Tcl_Interp *interp,
void *clientData, void **newClientData);
-static void MethodErrorHandler(Tcl_Interp *interp,
- Tcl_Obj *procNameObj);
-static void ConstructorErrorHandler(Tcl_Interp *interp,
- Tcl_Obj *procNameObj);
-static void DestructorErrorHandler(Tcl_Interp *interp,
- Tcl_Obj *procNameObj);
+static ProcErrorProc MethodErrorHandler;
+static ProcErrorProc ConstructorErrorHandler;
+static ProcErrorProc DestructorErrorHandler;
static Tcl_Obj * RenderDeclarerName(void *clientData);
static int InvokeForwardMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
@@ -93,13 +90,8 @@ static int InvokeForwardMethod(void *clientData,
static void DeleteForwardMethod(void *clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
void *clientData, void **newClientData);
-static int ProcedureMethodVarResolver(Tcl_Interp *interp,
- const char *varName, Tcl_Namespace *contextNs,
- int flags, Tcl_Var *varPtr);
-static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
- const char *varName, int length,
- Tcl_Namespace *contextNs,
- Tcl_ResolvedVarInfo **rPtrPtr);
+static Tcl_ResolveVarProc ProcedureMethodVarResolver;
+static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
/*
* The types of methods defined by the core OO system.
@@ -121,7 +113,7 @@ static const Tcl_MethodType fwdMethodType = {
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
- ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
@@ -135,7 +127,7 @@ static const Tcl_MethodType fwdMethodType = {
Tcl_Method
Tcl_NewInstanceMethod(
- Tcl_Interp *interp, /* Unused? */
+ 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,
@@ -186,7 +178,11 @@ Tcl_NewInstanceMethod(
mPtr->declaringObjectPtr = oPtr;
mPtr->declaringClassPtr = NULL;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ oPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
oPtr->epoch++;
return (Tcl_Method) mPtr;
@@ -204,7 +200,7 @@ Tcl_NewInstanceMethod(
Tcl_Method
Tcl_NewMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
+ 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
@@ -250,7 +246,11 @@ Tcl_NewMethod(
mPtr->declaringObjectPtr = NULL;
mPtr->declaringClassPtr = clsPtr;
if (flags) {
- mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
+ mPtr->flags |= flags &
+ (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
+ if (flags & TRUE_PRIVATE_METHOD) {
+ clsPtr->flags |= HAS_PRIVATE_METHODS;
+ }
}
return (Tcl_Method) mPtr;
@@ -339,7 +339,7 @@ TclOONewProcInstanceMethod(
ProcedureMethod *pmPtr;
Tcl_Method method;
- if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
@@ -397,7 +397,7 @@ TclOONewProcMethod(
TclNewObj(argsObj);
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
- } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+ } else if (TclListObjLengthM(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
@@ -793,6 +793,7 @@ PushMethodCallFrame(
int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
+ ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
@@ -858,10 +859,8 @@ PushMethodCallFrame(
* alternative is *so* slow...
*/
- if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
-
+ ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr) {
codePtr->nsPtr = nsPtr;
}
result = TclProcCompileProc(interp, pmPtr->procPtr,
@@ -930,7 +929,7 @@ PushMethodCallFrame(
* variables used in methods. The compiled variable resolver is more
* important, but both are needed as it is possible to have a variable
* that is only referred to in ways that aren't compilable and we can't
- * force LVT presence. [TIP #320]
+ * force LVT presence. [TIP #320, #500]
*
* ----------------------------------------------------------------------
*/
@@ -953,7 +952,7 @@ ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
- int flags,
+ TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
Tcl_Var *varPtr)
{
int result;
@@ -986,6 +985,7 @@ ProcedureMethodCompiledVarConnect(
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
+ PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
int i, isNew, cacheIt, varLen, len;
const char *match, *varName;
@@ -1019,6 +1019,15 @@ ProcedureMethodCompiledVarConnect(
varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
if (contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr != NULL) {
+ FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
+ .mPtr->declaringClassPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 0;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
@@ -1028,6 +1037,14 @@ ProcedureMethodCompiledVarConnect(
}
}
} else {
+ FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
+ match = TclGetStringFromObj(privateVar->variableObj, &len);
+ if ((len == varLen) && !memcmp(match, varName, len)) {
+ variableObj = privateVar->fullNameObj;
+ cacheIt = 1;
+ goto gotMatch;
+ }
+ }
FOREACH(variableObj, contextPtr->oPtr->variables) {
match = TclGetStringFromObj(variableObj, &len);
if ((len == varLen) && !memcmp(match, varName, len)) {
@@ -1082,10 +1099,10 @@ ProcedureMethodCompiledVarDelete(
static int
ProcedureMethodCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *varName,
int length,
- Tcl_Namespace *contextNs,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
@@ -1153,6 +1170,8 @@ RenderDeclarerName(
* ----------------------------------------------------------------------
*/
+/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
+
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
@@ -1160,15 +1179,15 @@ RenderDeclarerName(
static void
MethodErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* We pull the method name out of context instead of from argument */
{
int nameLen, objectNameLen;
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
- Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
+ TclGetStringFromObj(mPtr->namePtr, &nameLen);
Object *declarerPtr;
- (void)methodNameObj;/* We pull the method name out of context instead of from argument */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1181,7 +1200,7 @@ MethodErrorHandler(
kindName = "class";
}
- objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
@@ -1192,14 +1211,14 @@ MethodErrorHandler(
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the constructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
- (void)methodNameObj;/* Ignore. We know it is the constructor. */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1212,7 +1231,7 @@ ConstructorErrorHandler(
kindName = "class";
}
- objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" constructor line %d)", kindName,
@@ -1222,14 +1241,14 @@ ConstructorErrorHandler(
static void
DestructorErrorHandler(
Tcl_Interp *interp,
- Tcl_Obj *methodNameObj)
+ TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
+ /* Ignore. We know it is the destructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
- (void)methodNameObj; /* Ignore. We know it is the destructor. */
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
@@ -1242,7 +1261,7 @@ DestructorErrorHandler(
kindName = "class";
}
- objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
+ objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" destructor line %d)", kindName,
@@ -1319,7 +1338,7 @@ CloneProcedureMethod(
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
Tcl_GetString(bodyObj);
- TclFreeIntRep(bodyObj);
+ Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
@@ -1370,13 +1389,13 @@ TclOONewForwardInstanceMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (void *)NULL);
return NULL;
}
@@ -1409,13 +1428,13 @@ TclOONewForwardMethod(
int prefixLen;
ForwardMethod *fmPtr;
- if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (void *)NULL);
return NULL;
}
@@ -1457,7 +1476,7 @@ InvokeForwardMethod(
* can ignore here.
*/
- TclListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
+ TclListObjGetElementsM(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
@@ -1505,7 +1524,7 @@ DeleteForwardMethod(
static int
CloneForwardMethod(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
@@ -1548,9 +1567,7 @@ TclOOGetMethodBody(
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
- if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
- }
+ (void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
@@ -1677,6 +1694,13 @@ Tcl_MethodIsPublic(
{
return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
}
+
+int
+Tcl_MethodIsPrivate(
+ Tcl_Method method)
+{
+ return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
+}
/*
* Extended method construction for itcl-ng.
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..eb6a96e
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,493 @@
+/*
+ * tclOOScript.h --
+ *
+ * This file contains support scripts for TclOO. They are defined here so
+ * that the code can be definitely run even in safe interpreters; TclOO's
+ * core setup is safe.
+ *
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ *
+ * Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which
+ * contains the commented version of everything; *this* file is automatically
+ * generated.
+ */
+
+static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
+"::namespace eval ::oo {\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\tnamespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name args} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\t\t}\n"
+"\t\t::set cls [::uplevel 1 self]\n"
+"\t\t::if {$argc == 4} {\n"
+"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get -unexport {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set -unexport list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Resolve -unexport list {\n"
+"\t\t\treturn $list\n"
+"\t\t}\n"
+"\t\tmethod -set -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\ttailcall my Set $args\n"
+"\t\t}\n"
+"\t\tmethod -append -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -appendifnew -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
+"\t\t\t\tif {$a ni $current} {\n"
+"\t\t\t\t\tlappend current $a\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\ttailcall my Set $current\n"
+"\t\t}\n"
+"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
+"\t\tmethod -prepend -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
+"\t\t}\n"
+"\t\tmethod -remove -export args {\n"
+"\t\t\tset my [namespace which my]\n"
+"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
+"\t\t\tset current [uplevel 1 [list $my Get]]\n"
+"\t\t\ttailcall my Set [lmap val $current {\n"
+"\t\t\t\tif {$val in $args} continue else {set val}\n"
+"\t\t\t}]\n"
+"\t\t}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown -unexport {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\tunexport destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> -unexport {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> -unexport {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
+"\t::namespace eval configuresupport {\n"
+"\t\tnamespace path ::tcl\n"
+"\t\tproc PropertyImpl {readslot writeslot args} {\n"
+"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
+"\t\t\t\tset prop [lindex $args $i]\n"
+"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {$prop ne [list $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
+"\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
+"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
+"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
+"\t\t\t\tset kind readwrite\n"
+"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
+"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
+"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
+"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
+"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
+"\t\t\t\t\t\t-get {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset getter $arg\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t-set {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset setter $arg\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t-kind {\n"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
+"\t\t\t\t\t\t\t}\n"
+"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
+"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
+"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
+"\t\t\t\t\t\t\t\treadable readwrite writable\n"
+"\t\t\t\t\t\t\t} $arg]\n"
+"\t\t\t\t\t\t}\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t\tset reader <ReadProp$realprop>\n"
+"\t\t\t\tset writer <WriteProp$realprop>\n"
+"\t\t\t\tswitch $kind {\n"
+"\t\t\t\t\treadable {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\twritable {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\treadwrite {\n"
+"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
+"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t\tnamespace eval configurableclass {\n"
+"\t\t\t::proc property args {\n"
+"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
+"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
+"\t\t\t}\n"
+"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t\t::namespace path ::oo::define\n"
+"\t\t\t::namespace export property\n"
+"\t\t}\n"
+"\t\tnamespace eval configurableobject {\n"
+"\t\t\t::proc property args {\n"
+"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
+"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
+"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
+"\t\t\t}\n"
+"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t\t::namespace path ::oo::objdefine\n"
+"\t\t\t::namespace export property\n"
+"\t\t}\n"
+"\t\tproc ReadAll {object my} {\n"
+"\t\t\tset result {}\n"
+"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $result\n"
+"\t\t}\n"
+"\t\tproc ReadOne {object my propertyName} {\n"
+"\t\t\tset props [info object properties $object -all -readable]\n"
+"\t\t\ttry {\n"
+"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
+"\t\t\t} on error {msg} {\n"
+"\t\t\t\tcatch {\n"
+"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
+"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
+"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
+"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
+"\t\t\t}\n"
+"\t\t\ttry {\n"
+"\t\t\t\tset value [$my <ReadProp$prop>]\n"
+"\t\t\t} on error {msg opt} {\n"
+"\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on return {msg opt} {\n"
+"\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on break {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t} on continue {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t}\n"
+"\t\t\treturn $value\n"
+"\t\t}\n"
+"\t\tproc WriteMany {object my setterMap} {\n"
+"\t\t\tset props [info object properties $object -all -writable]\n"
+"\t\t\tforeach {prop value} $setterMap {\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
+"\t\t\t\t} on error {msg} {\n"
+"\t\t\t\t\tcatch {\n"
+"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
+"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
+"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
+"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
+"\t\t\t\t}\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\t$my <WriteProp$prop> $value\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\t::oo::class create configurable {\n"
+"\t\t\tprivate variable my\n"
+"\t\t\tmethod configure -export args {\n"
+"\t\t\t\t::if {![::info exists my]} {\n"
+"\t\t\t\t\t::set my [::namespace which my]\n"
+"\t\t\t\t}\n"
+"\t\t\t\t::if {[::llength $args] == 0} {\n"
+"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
+"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
+"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
+"\t\t\t\t\t\t[::lindex $args 0]\n"
+"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
+"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
+"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
+"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tdefinitionnamespace -instance configurableobject\n"
+"\t\t\tdefinitionnamespace -class configurableclass\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create configurable {\n"
+"\t\tsuperclass class\n"
+"\t\tconstructor {{definitionScript \"\"}} {\n"
+"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
+"\t\t\tnext $definitionScript\n"
+"\t\t}\n"
+"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
+"\t}\n"
+"}\n"
+/* !END!: Do not edit above this line. */
+;
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index 735d871..1923037 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -75,9 +75,9 @@ const TclOOStubs tclOOStubs = {
Tcl_ClassSetConstructor, /* 26 */
Tcl_ClassSetDestructor, /* 27 */
Tcl_GetObjectName, /* 28 */
- 0, /* 29 */
- 0, /* 30 */
- 0, /* 31 */
+ Tcl_MethodIsPrivate, /* 29 */
+ Tcl_GetClassOfObject, /* 30 */
+ Tcl_GetObjectClassName, /* 31 */
0, /* 32 */
0, /* 33 */
TclOOUnusedStubEntry, /* 34 */
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index a9fa212..221d99a 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -35,14 +35,19 @@ TclOOInitializeStubs(
const char *version)
{
int exact = 0;
- const char *packageName = "TclOO";
+ const char *packageName = "tcl::oo";
const char *errMsg = NULL;
TclOOStubs *stubsPtr = NULL;
const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
- return NULL;
+ packageName = "TclOO";
+ actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
+ if (actualVersion == NULL) {
+ return NULL;
+ }
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 4abfa49..7f41765 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4,19 +4,20 @@
* This file contains Tcl object-related functions that are used by many
* Tcl commands.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
- * Copyright (c) 2001 by ActiveState Corporation.
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
+ * Copyright © 2001 ActiveState Corporation.
+ * Copyright © 2005 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* 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 "tommath.h"
+#include "tclTomMath.h"
#include <math.h>
+#include <assert.h>
/*
* Table of all object types.
@@ -37,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL;
* TclNewObj macro, however, so must be visible.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
MODULE_SCOPE Tcl_Mutex tclObjMutex;
Tcl_Mutex tclObjMutex;
#endif
@@ -49,16 +50,15 @@ Tcl_Mutex tclObjMutex;
*/
char tclEmptyString = '\0';
-char *tclEmptyStringRep = &tclEmptyString;
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
/*
* Structure for tracking the source file and line number where a given
* Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
* for sanity checking purposes.
*/
-typedef struct ObjData {
+typedef struct {
Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
const char *file; /* The name of the source file calling this
* function; used for debugging. */
@@ -76,7 +76,7 @@ typedef struct ObjData {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
@@ -88,7 +88,7 @@ typedef struct ThreadSpecificData {
* tclCompile.h for the definition of this
* structure, and for references to all
* related places in the core. */
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
* that a Tcl_Obj was not allocated by some
* other thread. */
@@ -97,7 +97,7 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
-static void TclThreadFinalizeContLines(ClientData clientData);
+static void TclThreadFinalizeContLines(void *clientData);
static ThreadSpecificData *TclGetContLineTable(void);
/*
@@ -157,7 +157,7 @@ typedef struct PendingObjData {
/*
* Macro to set up the local reference to the deletion context.
*/
-#ifndef TCL_THREADS
+#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
@@ -169,7 +169,7 @@ static __thread PendingObjData pendingObjData;
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
- Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
+ (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
@@ -182,26 +182,12 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*temp = bignum; \
(objPtr)->internalRep.twoPtrValue.ptr1 = temp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \
- } else { \
- if ((bignum).alloc > 0x7FFF) { \
- mp_shrink(&(bignum)); \
- } \
+ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \
(objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \
| ((bignum).alloc << 15) | ((bignum).used)); \
}
-#define UNPACK_BIGNUM(objPtr, bignum) \
- if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \
- (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \
- } else { \
- (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \
- (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \
- (bignum).alloc = \
- (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7FFF; \
- (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7FFF; \
- }
-
/*
* Prototypes for functions defined later in this file:
*/
@@ -211,9 +197,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef TCL_WIDE_INT_IS_LONG
-static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
-static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void UpdateStringOfOldInt(Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -243,6 +228,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
@@ -250,6 +236,7 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
+#endif
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
@@ -265,19 +252,23 @@ const Tcl_ObjType tclDoubleType = {
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG)
"int", /* name */
+#else
+ "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/
+#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef TCL_WIDE_INT_IS_LONG
-const Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static const Tcl_ObjType oldIntType = {
+ "int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+ UpdateStringOfOldInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
@@ -345,23 +336,23 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ unsigned long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
+ Tcl_Size refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
+ Tcl_Size cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName object
+ size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -396,21 +387,26 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
- Tcl_RegisterObjType(&tclEndOffsetType);
- Tcl_RegisterObjType(&tclIntType);
+#if !defined(TCL_NO_DEPRECATED)
Tcl_RegisterObjType(&tclStringType);
+ /* Only registered for 8.7, not for 9.0 any more.
+ * See [https://core.tcl-lang.org/tk/tktview/6b49149b4e] */
+ Tcl_RegisterObjType(&tclUniCharStringType);
+#endif
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
- Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ Tcl_RegisterObjType(&tclIntType);
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ Tcl_RegisterObjType(&oldIntType);
+#endif
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef TCL_WIDE_INT_IS_LONG
- Tcl_RegisterObjType(&tclWideIntType);
#endif
#ifdef TCL_COMPILE_STATS
@@ -448,7 +444,7 @@ TclInitObjSubsystem(void)
void
TclFinalizeThreadObjects(void)
{
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -457,7 +453,7 @@ TclFinalizeThreadObjects(void)
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
@@ -569,14 +565,14 @@ TclGetContLineTable(void)
ContLineLoc *
TclContinuationsEnter(
Tcl_Obj *objPtr,
- int num,
+ Tcl_Size num,
int *loc)
{
int newEntry;
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
- ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(TclOffset(ContLineLoc, loc) + (num + 1U) *sizeof(int));
+ ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(int));
if (!newEntry) {
/*
@@ -636,7 +632,8 @@ TclContinuationsEnterDerived(
int start,
int *clNext)
{
- int length, end, num;
+ Tcl_Size length;
+ int end, num;
int *wordCLLast = clNext;
/*
@@ -733,7 +730,7 @@ TclContinuationsCopy(
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
- ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
+ ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
@@ -769,7 +766,7 @@ TclContinuationsGet(
if (!hPtr) {
return NULL;
}
- return Tcl_GetHashValue(hPtr);
+ return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
@@ -792,7 +789,7 @@ TclContinuationsGet(
static void
TclThreadFinalizeContLines(
- ClientData clientData)
+ TCL_UNUSED(void *))
{
/*
* Release the hashtable tracking invisible continuation lines.
@@ -878,13 +875,13 @@ Tcl_AppendAllObjTypes(
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
- int numElems;
+ Tcl_Size numElems;
/*
* Get the test for a valid list out of the way first.
*/
- if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
+ if (TclListObjLengthM(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
@@ -897,7 +894,7 @@ Tcl_AppendAllObjTypes(
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
+ Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
@@ -930,7 +927,7 @@ Tcl_GetObjType(
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
- typePtr = Tcl_GetHashValue(hPtr);
+ typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
@@ -976,7 +973,7 @@ Tcl_ConvertToType(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't convert value to type %s", typePtr->name));
- Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", (void *)NULL);
}
return TCL_ERROR;
}
@@ -1001,11 +998,11 @@ Tcl_ConvertToType(
*--------------------------------------------------------------
*/
+#if TCL_THREADS && defined(TCL_MEM_DEBUG)
void
TclDbDumpActiveObjects(
FILE *outFile)
{
-#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
@@ -1014,10 +1011,10 @@ TclDbDumpActiveObjects(
tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
- fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
+ fprintf(outFile, "total objects: %" TCL_SIZE_MODIFIER "d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
@@ -1030,8 +1027,14 @@ TclDbDumpActiveObjects(
}
}
}
-#endif
}
+#else
+void
+TclDbDumpActiveObjects(
+ TCL_UNUSED(FILE *))
+{
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -1061,11 +1064,10 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
objPtr->typePtr = NULL;
+ TclInitEmptyStringRep(objPtr);
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Add entry to a thread local map used to check if a Tcl_Obj was
* allocated by the currently executing thread.
@@ -1202,12 +1204,12 @@ Tcl_DbNewObj(
Tcl_Obj *
Tcl_DbNewObj(
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- return Tcl_NewObj();
+ Tcl_Obj *objPtr;
+ TclNewObj(objPtr);
+ return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1301,7 +1303,7 @@ TclFreeObj(
ObjInitDeletionContext(context);
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -1323,7 +1325,7 @@ TclFreeObj(
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
- ObjData *objData = Tcl_GetHashValue(hPtr);
+ ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
@@ -1348,16 +1350,16 @@ TclFreeObj(
* sure we do not accept a second free when falling from 0 to -1.
* Skip that possibility so any double free will trigger the panic.
*/
- objPtr->refCount = -1;
+ objPtr->refCount = TCL_INDEX_NONE;
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
- * with 'length == -1'.
+ * with 'length == TCL_INDEX_NONE'.
*/
TclInvalidateStringRep(objPtr);
- objPtr->length = -1;
+ objPtr->length = TCL_INDEX_NONE;
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
@@ -1379,7 +1381,7 @@ TclFreeObj(
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
- TclFreeIntRep(objToFree);
+ TclFreeInternalRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
ckfree(objToFree);
@@ -1425,7 +1427,7 @@ TclFreeObj(
*/
TclInvalidateStringRep(objPtr);
- objPtr->length = -1;
+ objPtr->length = TCL_INDEX_NONE;
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
@@ -1527,7 +1529,7 @@ int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
- return (objPtr->length == -1);
+ return (objPtr->length == TCL_INDEX_NONE);
}
/*
@@ -1564,7 +1566,7 @@ TclObjBeingDeleted(
const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
const char *bytes = (objPtr)->bytes; \
if (bytes) { \
- TclInitStringRep((dupPtr), bytes, (objPtr)->length); \
+ (void)TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \
} else { \
(dupPtr)->bytes = NULL; \
} \
@@ -1598,7 +1600,7 @@ TclSetDuplicateObj(
Tcl_Panic("%s called with shared object", "TclSetDuplicateObj");
}
TclInvalidateStringRep(dupPtr);
- TclFreeIntRep(dupPtr);
+ TclFreeInternalRep(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
}
@@ -1623,37 +1625,36 @@ TclSetDuplicateObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetString
char *
Tcl_GetString(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
- if (objPtr->bytes != NULL) {
- return objPtr->bytes;
- }
-
- /*
- * Note we do not check for objPtr->typePtr == NULL. An invariant of
- * a properly maintained Tcl_Obj is that at least one of objPtr->bytes
- * and objPtr->typePtr must not be NULL. If broken extensions fail to
- * maintain that invariant, we can crash here.
- */
-
- if (objPtr->typePtr->updateStringProc == NULL) {
+ if (objPtr->bytes == NULL) {
/*
- * Those Tcl_ObjTypes which choose not to define an updateStringProc
- * must be written in such a way that (objPtr->bytes) never becomes
- * NULL. This panic was added in Tcl 8.1.
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
*/
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- objPtr->typePtr->updateStringProc(objPtr);
- if (objPtr->bytes == NULL || objPtr->length < 0
- || objPtr->bytes[objPtr->length] != '\0') {
- Tcl_Panic("UpdateStringProc for type '%s' "
- "failed to create a valid string rep", objPtr->typePtr->name);
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
}
return objPtr->bytes;
}
@@ -1689,8 +1690,31 @@ Tcl_GetStringFromObj(
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
- (void) TclGetString(objPtr);
+ if (objPtr->bytes == NULL) {
+ /*
+ * Note we do not check for objPtr->typePtr == NULL. An invariant
+ * of a properly maintained Tcl_Obj is that at least one of
+ * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
+ * extensions fail to maintain that invariant, we can crash here.
+ */
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ /*
+ * Those Tcl_ObjTypes which choose not to define an
+ * updateStringProc must be written in such a way that
+ * (objPtr->bytes) never becomes NULL.
+ */
+ Tcl_Panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->bytes == NULL || objPtr->length < 0
+ || objPtr->bytes[objPtr->length] != '\0') {
+ Tcl_Panic("UpdateStringProc for type '%s' "
+ "failed to create a valid string rep",
+ objPtr->typePtr->name);
+ }
+ }
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
@@ -1700,6 +1724,107 @@ Tcl_GetStringFromObj(
/*
*----------------------------------------------------------------------
*
+ * Tcl_InitStringRep --
+ *
+ * This function is called in several configurations to provide all
+ * the tools needed to set an object's string representation. The
+ * function is determined by the arguments.
+ *
+ * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0)
+ * Invalid call -- panic!
+ *
+ * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0
+ * Allocation only - allocate space for (numBytes+1) chars.
+ * store in objPtr->bytes and return. Also sets
+ * objPtr->length to 0 and objPtr->bytes[0] to NUL.
+ *
+ * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0
+ * Allocate and copy. bytes is assumed to point to chars to
+ * copy into the string rep. objPtr->length = numBytes. Allocate
+ * array of (numBytes + 1) chars. store in objPtr->bytes. Copy
+ * numBytes chars from bytes to objPtr->bytes; Set
+ * objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
+ * Caller must guarantee there are numBytes chars at bytes to
+ * be copied.
+ *
+ * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0
+ * Truncate. Set objPtr->length to numBytes and
+ * objPr->bytes[numBytes] to NUL. Caller has to guarantee
+ * that a prior allocating call allocated enough bytes for
+ * this to be valid. Return objPtr->bytes.
+ *
+ * Caller is expected to ascertain that the bytes copied into
+ * the string rep make up complete valid UTF-8 characters.
+ *
+ * Results:
+ * A pointer to the string rep of objPtr.
+ *
+ * Side effects:
+ * As described above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_InitStringRep(
+ Tcl_Obj *objPtr, /* Object whose string rep is to be set */
+ const char *bytes,
+ unsigned int numBytes)
+{
+ assert(objPtr->bytes == NULL || bytes == NULL);
+
+ if (numBytes > INT_MAX) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ if (objPtr->bytes == NULL) {
+ /* Start with no string rep */
+ if (numBytes == 0) {
+ TclInitEmptyStringRep(objPtr);
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ if (bytes) {
+ memcpy(objPtr->bytes, bytes, numBytes);
+ }
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
+ } else if (objPtr->bytes == &tclEmptyString) {
+ /* Start with empty string rep (not allocated) */
+ if (numBytes == 0) {
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
+ } else {
+ /* Start with non-empty string rep (allocated) */
+ if (numBytes == 0) {
+ ckfree(objPtr->bytes);
+ TclInitEmptyStringRep(objPtr);
+ return objPtr->bytes;
+ } else {
+ objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes,
+ numBytes + 1);
+ if (objPtr->bytes) {
+ objPtr->length = (int) numBytes;
+ objPtr->bytes[objPtr->length] = '\0';
+ }
+ }
+ }
+
+ return objPtr->bytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_InvalidateStringRep --
*
* This function is called to invalidate an object's string
@@ -1726,6 +1851,117 @@ Tcl_InvalidateStringRep(
/*
*----------------------------------------------------------------------
*
+ * Tcl_HasStringRep --
+ *
+ * This function reports whether object has a string representation.
+ *
+ * Results:
+ * Boolean.
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_HasStringRep(
+ Tcl_Obj *objPtr) /* Object to test */
+{
+ return TclHasStringRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_StoreInternalRep --
+ *
+ * Called to set the object's internal representation to match a
+ * particular type.
+ *
+ * It is the caller's responsibility to guarantee that
+ * the value of the submitted internalrep is in agreement with
+ * the value of any existing string rep.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_StoreInternalRep(
+ Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
+ const Tcl_ObjType *typePtr, /* New type for the object */
+ const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */
+{
+ /* Clear out any existing internalrep ( "shimmer" ) */
+ TclFreeInternalRep(objPtr);
+
+ /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */
+ if (irPtr) {
+ /* Copy the new internalrep into place */
+ objPtr->internalRep = *irPtr;
+
+ /* Set the type to match */
+ objPtr->typePtr = typePtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FetchInternalRep --
+ *
+ * This function is called to retrieve the object's internal
+ * representation matching a requested type, if any.
+ *
+ * Results:
+ * A read-only pointer to the associated Tcl_ObjInternalRep, or
+ * NULL if no such internal representation exists.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets the internalRep and typePtr fields to the submitted values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_ObjInternalRep *
+Tcl_FetchInternalRep(
+ Tcl_Obj *objPtr, /* Object to fetch from. */
+ const Tcl_ObjType *typePtr) /* Requested type */
+{
+ return TclFetchInternalRep(objPtr, typePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeInternalRep --
+ *
+ * This function is called to free an object's internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
+ * Sets typePtr field to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeInternalRep(
+ Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */
+{
+ TclFreeInternalRep(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
@@ -1734,7 +1970,7 @@ Tcl_InvalidateStringRep(
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
- * of calling the debugging version Tcl_DbNewBooleanObj.
+ * of calling the debugging version Tcl_DbNewLongObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
@@ -1753,7 +1989,7 @@ Tcl_Obj *
Tcl_NewBooleanObj(
int intValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewBooleanObj(intValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -1764,7 +2000,7 @@ Tcl_NewBooleanObj(
{
Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, intValue);
+ TclNewIntObj(objPtr, intValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1795,6 +2031,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
@@ -1809,9 +2046,10 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (intValue? 1 : 0);
+ objPtr->internalRep.wideValue = (intValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1821,10 +2059,8 @@ Tcl_DbNewBooleanObj(
Tcl_Obj *
Tcl_DbNewBooleanObj(
int intValue, /* Boolean used to initialize new object. */
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBooleanObj(intValue);
}
@@ -1858,13 +2094,14 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetLongObj(objPtr, (intValue)!=0);
+ TclSetIntObj(objPtr, intValue!=0);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
- * Tcl_GetBooleanFromObj --
+ * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
* includes conversion from any of Tcl's numeric types.
@@ -1880,20 +2117,36 @@ Tcl_SetBooleanObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetBoolFromObj
int
-Tcl_GetBooleanFromObj(
+Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
- int *intPtr) /* Place to store resulting boolean. */
+ int flags,
+ char *charPtr) /* Place to store resulting boolean. */
{
+ int result;
+
+ if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
+ result = -1;
+ goto boolEnd;
+ } else if (objPtr == NULL) {
+ if (interp) {
+ TclNewObj(objPtr);
+ TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
+ ? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0);
+ Tcl_DecrRefCount(objPtr);
+ }
+ return TCL_ERROR;
+ }
do {
if (objPtr->typePtr == &tclIntType) {
- *intPtr = (objPtr->internalRep.longValue != 0);
- return TCL_OK;
+ result = (objPtr->internalRep.wideValue != 0);
+ goto boolEnd;
}
if (objPtr->typePtr == &tclBooleanType) {
- *intPtr = (int) objPtr->internalRep.longValue;
- return TCL_OK;
+ result = objPtr->internalRep.longValue != 0;
+ goto boolEnd;
}
if (objPtr->typePtr == &tclDoubleType) {
/*
@@ -1909,24 +2162,45 @@ Tcl_GetBooleanFromObj(
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
- *intPtr = (d != 0.0);
- return TCL_OK;
+ result = (d != 0.0);
+ goto boolEnd;
}
if (objPtr->typePtr == &tclBignumType) {
- *intPtr = 1;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *intPtr = (objPtr->internalRep.wideValue != 0);
+ result = 1;
+ boolEnd:
+ if (charPtr != NULL) {
+ flags &= (TCL_NULL_OK-2);
+ if (flags) {
+ if (flags == (int)sizeof(int)) {
+ *(int *)charPtr = result;
+ return TCL_OK;
+ } else if (flags == (int)sizeof(short)) {
+ *(short *)charPtr = result;
+ return TCL_OK;
+ } else {
+ Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj");
+ }
+ }
+ *charPtr = result;
+ }
return TCL_OK;
}
-#endif
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
- TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
+ TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
+ ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
}
+#undef Tcl_GetBooleanFromObj
+int
+Tcl_GetBooleanFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* The object from which to get boolean. */
+ int *intPtr) /* Place to store resulting boolean. */
+{
+ return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1942,7 +2216,12 @@ Tcl_GetBooleanFromObj(
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
- * representation and the type of "objPtr" is set to boolean.
+ * representation and the type of "objPtr" is set to boolean or int/wideInt.
+ *
+ * Warning: If the returned type is "wideInt" (32-bit platforms) and your
+ * platform is bigendian, you cannot use internalRep.longValue to distinguish
+ * between false and true. On Windows and most other platforms this still will
+ * work fine, but basically it is non-portable.
*
*----------------------------------------------------------------------
*/
@@ -1960,8 +2239,7 @@ TclSetBooleanFromAny(
if (objPtr->bytes == NULL) {
if (objPtr->typePtr == &tclIntType) {
- switch (objPtr->internalRep.longValue) {
- case 0L: case 1L:
+ if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
@@ -1971,12 +2249,6 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- goto badBoolean;
- }
-#endif
-
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
@@ -1988,15 +2260,15 @@ TclSetBooleanFromAny(
badBoolean:
if (interp != NULL) {
- int length;
- const char *str = TclGetStringFromObj(objPtr, &length);
+ Tcl_Size length;
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (void *)NULL);
}
return TCL_ERROR;
}
@@ -2005,14 +2277,15 @@ static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
{
- int i, length, newBool;
+ int newBool;
char lowerCase[6];
- const char *str = TclGetStringFromObj(objPtr, &length);
+ Tcl_Size i, length;
+ const char *str = Tcl_GetStringFromObj(objPtr, &length);
- if ((length == 0) || (length > 5)) {
+ if ((length <= 0) || (length > 5)) {
/*
- * Longest valid boolean string rep. is "false".
- */
+ * Longest valid boolean string rep. is "false".
+ */
return TCL_ERROR;
}
@@ -2105,14 +2378,14 @@ ParseBoolean(
*/
goodBoolean:
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
- TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = newBool;
+ TclFreeInternalRep(objPtr);
+ objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
@@ -2201,6 +2474,7 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
@@ -2213,10 +2487,8 @@ Tcl_DbNewDoubleObj(
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
@@ -2280,12 +2552,12 @@ Tcl_GetDoubleFromObj(
{
do {
if (objPtr->typePtr == &tclDoubleType) {
- if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -2293,22 +2565,16 @@ Tcl_GetDoubleFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *dblPtr = objPtr->internalRep.longValue;
+ *dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
- UNPACK_BIGNUM(objPtr, big);
+ TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *dblPtr = (double) objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
@@ -2367,15 +2633,12 @@ static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
- char buffer[TCL_DOUBLE_SPACE];
- int len;
+ char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
- Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
- len = strlen(buffer);
+ TclOOM(dst, TCL_DOUBLE_SPACE + 1);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
+ Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
+ (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
@@ -2408,6 +2671,7 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
@@ -2415,7 +2679,7 @@ Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
- return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -2430,6 +2694,7 @@ Tcl_NewIntObj(
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2448,7 +2713,7 @@ Tcl_NewIntObj(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
@@ -2461,32 +2726,30 @@ Tcl_SetIntObj(
TclSetIntObj(objPtr, intValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
- * Retrieve the integer value of 'objPtr'.
- *
- * Value
+ * Attempt to return an int from the Tcl object "objPtr". If the object
+ * is not already an int, an attempt will be made to convert it to one.
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * An error occurred during conversion or the integral value can not
- * be represented as an integer (it might be too large). An error
- * message is left in the interpreter's result if 'interp' is not
- * NULL.
+ * Integer and long integer objects share the same "integer" type
+ * implementation. We store all integers as longs and Tcl_GetIntFromObj
+ * checks whether the current value of the long can be represented by an
+ * int.
*
- * Effect
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion or if the long integer held by the object can not be
+ * represented by an int, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
- * 'objPtr' is converted to an integer if necessary if it is not one
- * already. The conversion frees any previously-existing internal
- * representation.
+ * Side effects:
+ * If the object is not already an int, the conversion will free any old
+ * internal representation.
*
*----------------------------------------------------------------------
*/
@@ -2500,32 +2763,25 @@ Tcl_GetIntFromObj(
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
- void *p;
- int type;
+ long l;
- if ((TclGetNumberFromObj(NULL, objPtr, &p, &type) != TCL_OK)
- || (type == TCL_NUMBER_DOUBLE)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "expected integer but got \"%s\"", Tcl_GetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
- }
+ if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
return TCL_ERROR;
}
- if ((type != TCL_NUMBER_LONG) || ((ULONG_MAX > UINT_MAX)
- && ((*(long *)p > UINT_MAX) || (*(long *)p < -(long)UINT_MAX)))) {
+ 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);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL);
}
return TCL_ERROR;
}
- *intPtr = (int)*(long *)p;
+ *intPtr = (int) l;
return TCL_OK;
#endif
}
+
/*
*----------------------------------------------------------------------
@@ -2548,9 +2804,8 @@ SetIntFromAny(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
- long l;
-
- return TclGetLongFromObj(interp, objPtr, &l);
+ Tcl_WideInt w;
+ return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
/*
@@ -2576,15 +2831,25 @@ static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
- char buffer[TCL_INTEGER_SPACE];
- int len;
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
- len = TclFormatInt(buffer, objPtr->internalRep.longValue);
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.wideValue));
+}
+
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void
+UpdateStringOfOldInt(
+ Tcl_Obj *objPtr) /* Int object whose string rep to update. */
+{
+ char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
+ TclOOM(dst, TCL_INTEGER_SPACE + 1);
+ (void) Tcl_InitStringRep(objPtr, NULL,
+ TclFormatInt(dst, objPtr->internalRep.longValue));
}
+#endif
/*
*----------------------------------------------------------------------
@@ -2616,15 +2881,16 @@ UpdateStringOfInt(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewLongObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
- return Tcl_DbNewLongObj(longValue, "unknown", 0);
+ return Tcl_DbNewWideIntObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -2636,10 +2902,11 @@ Tcl_NewLongObj(
{
Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, longValue);
+ TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2673,6 +2940,8 @@ Tcl_NewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
@@ -2687,9 +2956,10 @@ Tcl_DbNewLongObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
+ /* Optimized TclInvalidateStringRep */
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = longValue;
+ objPtr->internalRep.wideValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -2700,14 +2970,13 @@ Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
- return Tcl_NewLongObj(longValue);
+ return Tcl_NewWideIntObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2727,6 +2996,8 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2737,8 +3008,9 @@ Tcl_SetLongObj(
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- TclSetLongObj(objPtr, longValue);
+ TclSetIntObj(objPtr, longValue);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2768,14 +3040,15 @@ Tcl_GetLongFromObj(
long *longPtr) /* Place to store resulting long. */
{
do {
+#ifdef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclIntType) {
- *longPtr = objPtr->internalRep.longValue;
+ *longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
+#else
+ if (objPtr->typePtr == &tclIntType) {
/*
- * We return any integer in the range -ULONG_MAX to ULONG_MAX
+ * We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
@@ -2784,9 +3057,9 @@ Tcl_GetLongFromObj(
Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX)
+ if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
- *longPtr = Tcl_WideAsLong(w);
+ *longPtr = (long)w;
return TCL_OK;
}
goto tooLarge;
@@ -2797,7 +3070,7 @@ Tcl_GetLongFromObj(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
@@ -2809,28 +3082,30 @@ Tcl_GetLongFromObj(
* values in the unsigned long range will fit in a long.
*/
+ {
mp_int big;
+ unsigned long scratch, value = 0;
+ unsigned char *bytes = (unsigned char *) &scratch;
+ size_t numBytes;
- UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1)
- / MP_DIGIT_BIT) {
- unsigned long value = 0;
- size_t numBytes;
- long scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
- while (numBytes-- > 0) {
+ TclUnpackBignum(objPtr, big);
+ if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ if (value <= 1 + (unsigned long)LONG_MAX) {
+ *longPtr = (long)(-value);
+ return TCL_OK;
}
- if (big.sign) {
- *longPtr = (long) (-value);
- } else {
- *longPtr = (long) value;
+ } else {
+ if (value <= (unsigned long)ULONG_MAX) {
+ *longPtr = (long)value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
+ }
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
@@ -2839,7 +3114,7 @@ Tcl_GetLongFromObj(
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL);
}
return TCL_ERROR;
}
@@ -2847,49 +3122,6 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfWideInt --
- *
- * Update the string representation for a wide integer object. Note: this
- * function does not free 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
- * wideInt-to-string conversion.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfWideInt(
- Tcl_Obj *objPtr) /* Int object whose string rep to update. */
-{
- char buffer[TCL_INTEGER_SPACE+2];
- unsigned len;
- Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
-
- /*
- * Note that snprintf will generate a compiler warning under Mingw claiming
- * %I64 is an unknown format specifier. Just ignore this warning. We can't
- * use %L as the format specifier since that gets printed as a 32 bit
- * value.
- */
-
- snprintf(buffer, sizeof(buffer), "%" TCL_LL_MODIFIER "d", wideVal);
- len = strlen(buffer);
- objPtr->bytes = (char *)ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
-}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -2939,7 +3171,7 @@ Tcl_NewWideIntObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2991,7 +3223,7 @@ Tcl_DbNewWideIntObj(
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
@@ -3002,10 +3234,8 @@ Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(wideValue);
}
@@ -3040,13 +3270,7 @@ Tcl_SetWideIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((wideValue < (Tcl_WideInt) LONG_MIN)
- || (wideValue > (Tcl_WideInt) LONG_MAX)) {
- TclSetWideIntObj(objPtr, wideValue);
- } else
-#endif
- TclSetLongObj(objPtr, (long) wideValue);
+ TclSetIntObj(objPtr, wideValue);
}
/*
@@ -3078,14 +3302,8 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *wideIntPtr = objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
if (objPtr->typePtr == &tclIntType) {
- *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
+ *wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
@@ -3093,7 +3311,7 @@ Tcl_GetWideIntFromObj(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3104,25 +3322,26 @@ Tcl_GetWideIntFromObj(
*/
mp_int big;
-
- UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt)
- + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- Tcl_WideUInt value = 0;
- size_t numBytes;
- Tcl_WideInt scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ TclUnpackBignum(objPtr, big);
+ if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
+ *wideIntPtr = (Tcl_WideInt)(-value);
+ return TCL_OK;
}
- if (big.sign) {
- *wideIntPtr = (Tcl_WideInt) (-value);
- } else {
- *wideIntPtr = (Tcl_WideInt) value;
+ } else {
+ if (value <= (Tcl_WideUInt)WIDE_MAX) {
+ *wideIntPtr = (Tcl_WideInt)value;
+ return TCL_OK;
}
- return TCL_OK;
}
}
if (interp != NULL) {
@@ -3130,7 +3349,7 @@ Tcl_GetWideIntFromObj(
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
Tcl_SetObjResult(interp, msg);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL);
}
return TCL_ERROR;
}
@@ -3138,33 +3357,160 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
*
- * SetWideIntFromAny --
+ * Tcl_GetWideUIntFromObj --
*
- * Attempts to force the internal representation for a Tcl object to
- * tclWideIntType, specifically.
+ * Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the
+ * object is not already a wide int object or a bignum object, an attempt will
+ * be made to convert it to one.
*
* Results:
- * The return value is a standard object Tcl result. If an error occurs
+ * The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
+ * Side effects:
+ * If the object is not already an int object, the conversion will free
+ * any old internal representation.
+ *
*----------------------------------------------------------------------
*/
-static int
-SetWideIntFromAny(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *objPtr) /* Pointer to the object to convert */
+int
+Tcl_GetWideUIntFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideUInt *wideUIntPtr)
+ /* Place to store resulting long. */
{
- Tcl_WideInt w;
- return Tcl_GetWideIntFromObj(interp, objPtr, &w);
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ if (objPtr->internalRep.wideValue < 0) {
+ wideUIntOutOfRange:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected unsigned integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ goto wideUIntOutOfRange;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ /*
+ * Must check for those bignum values that can fit in a
+ * Tcl_WideUInt, even when auto-narrowing is enabled.
+ */
+
+ mp_int big;
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideUInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ TclUnpackBignum(objPtr, big);
+ if (big.sign == MP_NEG) {
+ goto wideUIntOutOfRange;
+ }
+ if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ *wideUIntPtr = (Tcl_WideUInt)value;
+ return TCL_OK;
+ }
+
+ if (interp != NULL) {
+ const char *s = "integer value too large to represent";
+ Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
+
+ Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetWideBitsFromObj --
+ *
+ * Attempt to return a wide integer from the Tcl object "objPtr". If the
+ * object is not already a int, double or bignum, an attempt will be made
+ * to convert it to one of these. Out-of-range values don't result in an
+ * error, but only the least significant 64 bits will be returned.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int, double or bignum object, the
+ * conversion will free any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetWideBitsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
+{
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+ mp_err err;
+
+ Tcl_WideUInt value = 0, scratch;
+ size_t numBytes;
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ Tcl_GetBignumFromObj(NULL, objPtr, &big);
+ err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
+ if (err == MP_OKAY) {
+ err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes);
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value;
+ mp_clear(&big);
+ return TCL_OK;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3185,7 +3531,7 @@ FreeBignum(
{
mp_int toFree; /* Bignum to free */
- UNPACK_BIGNUM(objPtr, toFree);
+ TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
ckfree(objPtr->internalRep.twoPtrValue.ptr1);
@@ -3218,7 +3564,7 @@ DupBignum(
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
- UNPACK_BIGNUM(srcPtr, bignumVal);
+ TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
@@ -3251,12 +3597,10 @@ UpdateStringOfBignum(
{
mp_int bignumVal;
int size;
- int status;
char *stringVal;
- UNPACK_BIGNUM(objPtr, bignumVal);
- status = mp_radix_size(&bignumVal, 10, &size);
- if (status != MP_OKAY) {
+ TclUnpackBignum(objPtr, bignumVal);
+ if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
if (size < 2) {
@@ -3271,13 +3615,13 @@ UpdateStringOfBignum(
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
- stringVal = (char *)ckalloc(size);
- status = mp_to_radix(&bignumVal, stringVal, size, NULL, 10);
- if (status != MP_OKAY) {
+
+ stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1);
+
+ TclOOM(stringVal, size);
+ if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
- objPtr->bytes = stringVal;
- objPtr->length = size - 1; /* size includes a trailing NUL byte. */
}
/*
@@ -3301,14 +3645,14 @@ UpdateStringOfBignum(
Tcl_Obj *
Tcl_NewBignumObj(
- mp_int *bignumValue)
+ void *bignumValue)
{
return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(
- mp_int *bignumValue)
+ void *bignumValue)
{
Tcl_Obj *objPtr;
@@ -3339,7 +3683,7 @@ Tcl_NewBignumObj(
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
+ void *bignumValue,
const char *file,
int line)
{
@@ -3352,9 +3696,9 @@ Tcl_DbNewBignumObj(
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
- mp_int *bignumValue,
- const char *file,
- int line)
+ void *bignumValue,
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBignumObj(bignumValue);
}
@@ -3393,43 +3737,40 @@ GetBignumFromObj(
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
- UNPACK_BIGNUM(objPtr, temp);
+ TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "insufficient memory to unpack bignum", -1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- }
return TCL_ERROR;
}
} else {
- UNPACK_BIGNUM(objPtr, *bignumValue);
+ TclUnpackBignum(objPtr, *bignumValue);
+ /* Optimized TclFreeInternalRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
+ /*
+ * TODO: If objPtr has a string rep, this leaves
+ * it undisturbed. Not clear that's proper. Pure
+ * bignum values are converted to empty string.
+ */
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- TclBNInitBignumFromWideInt(bignumValue,
- objPtr->internalRep.wideValue);
+ if (mp_init_i64(bignumValue,
+ objPtr->internalRep.wideValue) != MP_OKAY) {
+ return TCL_ERROR;
+ }
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
@@ -3467,9 +3808,9 @@ int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
- mp_int *bignumValue) /* Returned bignum value. */
+ void *bignumValue) /* Returned bignum value. */
{
- return GetBignumFromObj(interp, objPtr, 1, bignumValue);
+ return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue);
}
/*
@@ -3502,9 +3843,9 @@ int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
- mp_int *bignumValue) /* Returned bignum value. */
+ void *bignumValue) /* Returned bignum value. */
{
- return GetBignumFromObj(interp, objPtr, 0, bignumValue);
+ return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue);
}
/*
@@ -3527,65 +3868,36 @@ Tcl_TakeBignumFromObj(
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
- mp_int *bignumValue) /* Value to store */
+ void *big) /* Value to store */
{
+ Tcl_WideUInt value = 0;
+ size_t numBytes;
+ Tcl_WideUInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
+ mp_int *bignumValue = (mp_int *) big;
+
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
- if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- unsigned long value = 0;
- size_t numBytes;
- long scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_ubin(bignumValue, bytes, sizeof(long), &numBytes) != MP_OKAY) {
- goto tooLargeForLong;
- }
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
- }
- if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
- goto tooLargeForLong;
- }
- if (bignumValue->sign) {
- TclSetLongObj(objPtr, (long)(-value));
- } else {
- TclSetLongObj(objPtr, (long)value);
- }
- mp_clear(bignumValue);
- return;
+ if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) {
+ goto tooLargeForWide;
}
- tooLargeForLong:
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) {
- Tcl_WideUInt value = 0;
- size_t numBytes;
- Tcl_WideInt scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
-
- if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideInt), &numBytes) != MP_OKAY) {
- goto tooLargeForWide;
- }
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
- }
- if (value > ((UWIDE_MAX >> 1) + bignumValue->sign)) {
- goto tooLargeForWide;
- }
- if (bignumValue->sign) {
- TclSetWideIntObj(objPtr, (Tcl_WideInt)(-value));
- } else {
- TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
- }
- mp_clear(bignumValue);
- return;
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
}
+ if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) {
+ goto tooLargeForWide;
+ }
+ if (bignumValue->sign) {
+ TclSetIntObj(objPtr, (Tcl_WideInt)(-value));
+ } else {
+ TclSetIntObj(objPtr, (Tcl_WideInt)value);
+ }
+ mp_clear(bignumValue);
+ return;
tooLargeForWide:
-#endif
TclInvalidateStringRep(objPtr);
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
TclSetBignumInternalRep(objPtr, bignumValue);
}
@@ -3610,8 +3922,9 @@ Tcl_SetBignumObj(
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
- mp_int *bignumValue)
+ void *big)
{
+ mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
@@ -3630,7 +3943,7 @@ TclSetBignumInternalRep(
/*
*----------------------------------------------------------------------
*
- * TclGetNumberFromObj --
+ * Tcl_GetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
@@ -3648,15 +3961,15 @@ TclSetBignumInternalRep(
*/
int
-TclGetNumberFromObj(
+Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
- ClientData *clientDataPtr,
+ void **clientDataPtr,
int *typePtr)
{
do {
if (objPtr->typePtr == &tclDoubleType) {
- if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
@@ -3665,23 +3978,16 @@ TclGetNumberFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *typePtr = TCL_NUMBER_LONG;
- *clientDataPtr = &objPtr->internalRep.longValue;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *typePtr = TCL_NUMBER_WIDE;
+ *typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
- mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
- (int) sizeof(mp_int));
+ mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
+ sizeof(mp_int));
- UNPACK_BIGNUM(objPtr, *bigPtr);
+ TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
@@ -3690,6 +3996,99 @@ TclGetNumberFromObj(
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
return TCL_ERROR;
}
+
+int
+Tcl_GetNumber(
+ Tcl_Interp *interp,
+ const char *bytes,
+ int numBytes,
+ void **clientDataPtr,
+ int *typePtr)
+{
+ static Tcl_ThreadDataKey numberCacheKey;
+ Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey,
+ sizeof(Tcl_Obj));
+
+ Tcl_FreeInternalRep(objPtr);
+
+ if (bytes == NULL) {
+ bytes = &tclEmptyString;
+ numBytes = 0;
+ }
+ if (numBytes < 0) {
+ numBytes = (int)strlen(bytes);
+ }
+
+ objPtr->bytes = (char *) bytes;
+ objPtr->length = numBytes;
+
+ return Tcl_GetNumberFromObj(interp, objPtr, clientDataPtr, typePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IncrRefCount --
+ *
+ * Increments the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IncrRefCount
+void
+Tcl_IncrRefCount(
+ Tcl_Obj *objPtr) /* The object we are registering a reference to. */
+{
+ ++(objPtr)->refCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DecrRefCount --
+ *
+ * Decrements the reference count of the object.
+ *
+ * Results:
+ * The storage for objPtr may be freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_DecrRefCount
+void
+Tcl_DecrRefCount(
+ Tcl_Obj *objPtr) /* The object we are releasing a reference to. */
+{
+ if (objPtr->refCount-- <= 1) {
+ TclFreeObj(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsShared --
+ *
+ * Tests if the object has a ref count greater than one.
+ *
+ * Results:
+ * Boolean value that is the result of the test.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_IsShared
+int
+Tcl_IsShared(
+ Tcl_Obj *objPtr) /* The object to test for being shared. */
+{
+ return ((objPtr)->refCount > 1);
+}
/*
*----------------------------------------------------------------------
@@ -3712,6 +4111,7 @@ TclGetNumberFromObj(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
@@ -3721,14 +4121,13 @@ Tcl_DbIncrRefCount(
int line) /* Line number in the source file; used for
* debugging. */
{
-#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("incrementing refCount of previously disposed object");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3750,9 +4149,19 @@ Tcl_DbIncrRefCount(
}
}
# endif /* TCL_THREADS */
-#endif /* TCL_MEM_DEBUG */
++(objPtr)->refCount;
}
+#else /* !TCL_MEM_DEBUG */
+void
+Tcl_DbIncrRefCount(
+ Tcl_Obj *objPtr, /* The object we are registering a reference
+ * to. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ ++(objPtr)->refCount;
+}
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -3775,6 +4184,7 @@ Tcl_DbIncrRefCount(
*----------------------------------------------------------------------
*/
+#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
@@ -3784,14 +4194,13 @@ Tcl_DbDecrRefCount(
int line) /* Line number in the source file; used for
* debugging. */
{
-#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("decrementing refCount of previously disposed object");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3813,12 +4222,24 @@ Tcl_DbDecrRefCount(
}
}
# endif /* TCL_THREADS */
-#endif /* TCL_MEM_DEBUG */
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
+#else /* !TCL_MEM_DEBUG */
+void
+Tcl_DbDecrRefCount(
+ Tcl_Obj *objPtr, /* The object we are releasing a reference
+ * to. */
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+{
+ if (objPtr->refCount-- <= 1) {
+ TclFreeObj(objPtr);
+ }
+}
+#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
@@ -3844,10 +4265,15 @@ Tcl_DbDecrRefCount(
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
+#ifdef TCL_MEM_DEBUG
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. */
+#else
+ TCL_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
+#endif
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
@@ -3856,7 +4282,7 @@ Tcl_DbIsShared(
Tcl_Panic("checking whether previously disposed object is shared");
}
-# ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Check to make sure that the Tcl_Obj was allocated by the current
* thread. Don't do this check when shutting down since thread local
@@ -3941,7 +4367,7 @@ Tcl_InitObjHashTable(
static Tcl_HashEntry *
AllocObjEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
@@ -3976,8 +4402,8 @@ TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
- Tcl_Obj *objPtr1 = keyPtr;
- Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
+ Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
+ Tcl_Obj *objPtr2 = (Tcl_Obj *)hPtr->key.oneWordValue;
const char *p1, *p2;
size_t l1, l2;
@@ -4060,15 +4486,15 @@ TclFreeObjEntry(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclHashObjKey(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
- Tcl_Obj *objPtr = keyPtr;
- int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
- unsigned int result = 0;
+ Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
+ Tcl_Size length;
+ const char *string = Tcl_GetStringFromObj(objPtr, &length);
+ TCL_HASH_TYPE result = 0;
/*
* I tried a zillion different hash functions and asked many other people
@@ -4163,12 +4589,11 @@ Tcl_GetCommandFromObj(
* to discard the old rep and create a new one.
*/
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) {
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (objPtr->typePtr == &tclCmdNameType) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
- && !(cmdPtr->flags & CMD_IS_DELETED)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
@@ -4188,11 +4613,11 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- /* See [] why we cannot call SetCmdNameFromAny() directly here. */
+ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
@@ -4216,57 +4641,78 @@ Tcl_GetCommandFromObj(
*----------------------------------------------------------------------
*/
-void
-TclSetCmdNameObj(
- Tcl_Interp *interp, /* Points to interpreter containing command
- * that should be cached in objPtr. */
- Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
- * CmdName object. */
- Command *cmdPtr) /* Points to Command structure that the
- * CmdName object should refer to. */
+static void
+SetCmdNameObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Command *cmdPtr,
+ ResolvedCmdName *resPtr)
{
Interp *iPtr = (Interp *) interp;
- ResolvedCmdName *resPtr;
- Namespace *currNsPtr;
- const char *name;
+ ResolvedCmdName *fillPtr;
+ const char *name = TclGetString(objPtr);
- if (objPtr->typePtr == &tclCmdNameType) {
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
- return;
- }
+ if (resPtr) {
+ fillPtr = resPtr;
+ } else {
+ fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
+ fillPtr->refCount = 1;
}
+ fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
+ fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
- name = TclGetString(objPtr);
- if ((*name++ == ':') && (*name == ':')) {
+ /* NOTE: relying on NULL termination here. */
+ if ((name[0] == ':') && (name[1] == ':')) {
/*
- * The name is fully qualified: set the referring namespace to
- * NULL.
+ * Fully qualified names always resolve to same thing. No need
+ * to record resolution context information.
*/
- resPtr->refNsPtr = NULL;
+ fillPtr->refNsPtr = NULL;
+ fillPtr->refNsId = 0; /* Will not be read */
+ fillPtr->refNsCmdEpoch = 0; /* Will not be read */
} else {
/*
- * Get the current namespace.
+ * Record current state of current namespace as the resolution
+ * context of this command name lookup.
*/
+ Namespace *currNsPtr = iPtr->varFramePtr->nsPtr;
+
+ fillPtr->refNsPtr = currNsPtr;
+ fillPtr->refNsId = currNsPtr->nsId;
+ fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ }
+
+ if (resPtr == NULL) {
+ TclFreeInternalRep(objPtr);
+
+ objPtr->internalRep.twoPtrValue.ptr1 = fillPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
+ }
+}
- currNsPtr = iPtr->varFramePtr->nsPtr;
+void
+TclSetCmdNameObj(
+ Tcl_Interp *interp, /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
+ * CmdName object. */
+ Command *cmdPtr) /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ ResolvedCmdName *resPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ if (objPtr->typePtr == &tclCmdNameType) {
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
}
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+ SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
/*
@@ -4295,15 +4741,14 @@ FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
- ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
- if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
- if (resPtr->refCount-- == 1) {
+ if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
@@ -4315,7 +4760,6 @@ FreeCmdNameInternalRep(
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
- }
objPtr->typePtr = NULL;
}
@@ -4344,13 +4788,11 @@ DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- ResolvedCmdName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- if (resPtr != NULL) {
resPtr->refCount++;
- }
copyPtr->typePtr = &tclCmdNameType;
}
@@ -4380,10 +4822,8 @@ SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
- Interp *iPtr = (Interp *) interp;
const char *name;
Command *cmdPtr;
- Namespace *currNsPtr;
ResolvedCmdName *resPtr;
if (interp == NULL) {
@@ -4403,59 +4843,31 @@ SetCmdNameFromAny(
Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0);
/*
- * Free the old internalRep before setting the new one. Do this after
- * getting the string rep to allow the conversion code (in particular,
- * Tcl_GetStringFromObj) to use that old internalRep.
+ * Stop shimmering and caching nothing when we found nothing. Just
+ * report the failure to find the command as an error.
*/
- if (cmdPtr) {
- cmdPtr->refCount++;
- resPtr = objPtr->internalRep.twoPtrValue.ptr1;
- if ((objPtr->typePtr == &tclCmdNameType)
- && resPtr && (resPtr->refCount == 1)) {
- /*
- * Reuse the old ResolvedCmdName struct instead of freeing it
- */
-
- Command *oldCmdPtr = resPtr->cmdPtr;
-
- if (--oldCmdPtr->refCount == 0) {
- TclCleanupCommandMacro(oldCmdPtr);
- }
- } else {
- TclFreeIntRep(objPtr);
- resPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- }
- resPtr->cmdPtr = cmdPtr;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- if ((*name++ == ':') && (*name == ':')) {
- /*
- * The name is fully qualified: set the referring namespace to
- * NULL.
- */
+ if (cmdPtr == NULL || !TclRoutineHasName(cmdPtr)) {
+ return TCL_ERROR;
+ }
- resPtr->refNsPtr = NULL;
- } else {
- /*
- * Get the current namespace.
- */
+ resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
+ if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
+ /*
+ * Re-use existing ResolvedCmdName struct when possible.
+ * Cleanup the old fields that need it.
+ */
- currNsPtr = iPtr->varFramePtr->nsPtr;
+ Command *oldCmdPtr = resPtr->cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ if (oldCmdPtr->refCount-- <= 1) {
+ TclCleanupCommandMacro(oldCmdPtr);
}
} else {
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
+ resPtr = NULL;
}
+
+ SetCmdNameObj(interp, objPtr, cmdPtr, resPtr);
return TCL_OK;
}
@@ -4477,12 +4889,11 @@ SetCmdNameFromAny(
int
Tcl_RepresentationCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
@@ -4496,36 +4907,20 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- snprintf(ptrBuffer, sizeof(ptrBuffer), "%p", (void *) objv[1]);
- descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
- " object pointer at %s",
- objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
- objv[1]->refCount, ptrBuffer);
+ descObj = Tcl_ObjPrintf("value is a %s with a refcount of %" TCL_SIZE_MODIFIER "d,"
+ " object pointer at %p",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, objv[1]);
- /*
- * This is a workaround to silence reports from `make valgrind`
- * on 64-bit systems. The problem is that the test suite
- * includes calling the [representation] command on values of
- * &tclDoubleType. When these values are created, the "doubleValue"
- * is set, but when the "twoPtrValue" is examined, its "ptr2"
- * field has never been initialized. Since [representation]
- * presents the value of the ptr2 value in its output, valgrind
- * alerts about the read of uninitialized memory.
- *
- * The general problem with [representation], that it can read
- * and report uninitialized fields, is still present. This is
- * just the minimal workaround to silence one particular test.
- */
-
- if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) {
- objv[1]->internalRep.twoPtrValue.ptr2 = NULL;
- }
if (objv[1]->typePtr) {
- snprintf(ptrBuffer, sizeof(ptrBuffer), "%p:%p",
- (void *) objv[1]->internalRep.twoPtrValue.ptr1,
- (void *) objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
- ptrBuffer);
+ if (objv[1]->typePtr == &tclDoubleType) {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
+ objv[1]->internalRep.doubleValue);
+ } else {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ }
}
if (objv[1]->bytes) {
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index 03daa40..de28b0c 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -3,7 +3,7 @@
*
* This file contains the bytecode optimizer.
*
- * Copyright (c) 2013 by Donal Fellows.
+ * Copyright © 2013 Donal Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -233,7 +233,7 @@ ConvertZeroEffectToNOP(
TclGetUInt1AtPtr(currentInstPtr + 1));
int numBytes;
- (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ (void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
@@ -248,7 +248,7 @@ ConvertZeroEffectToNOP(
TclGetUInt4AtPtr(currentInstPtr + 1));
int numBytes;
- (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ (void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
@@ -429,9 +429,9 @@ void
TclOptimizeBytecode(
void *envPtr)
{
- ConvertZeroEffectToNOP(envPtr);
- AdvanceJumps(envPtr);
- TrimUnreachable(envPtr);
+ ConvertZeroEffectToNOP((CompileEnv *)envPtr);
+ AdvanceJumps((CompileEnv *)envPtr);
+ TrimUnreachable((CompileEnv *)envPtr);
}
/*
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 16b3ece..1f5ef27 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -5,9 +5,9 @@
* applications will probably call Tcl_SetPanicProc() to set an
* application-specific panic procedure.
*
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1988-1993 The Regents of the University of California.
+ * Copyright © 1994 Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -23,8 +23,8 @@
* procedure.
*/
-#if defined(__CYGWIN__)
-static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic;
+#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8))
+static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic;
#else
static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
#endif
@@ -45,19 +45,21 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
*----------------------------------------------------------------------
*/
-void
+#undef Tcl_SetPanicProc
+const char *
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
- if ((proc != tclWinDebugPanic) || (panicProc == NULL))
+ if (((Tcl_PanicProc *)proc != tclWinDebugPanic) || (panicProc == NULL))
#elif defined(__CYGWIN__)
if (proc == NULL)
panicProc = tclWinDebugPanic;
else
#endif
panicProc = proc;
+ return Tcl_InitSubsystems();
}
/*
@@ -141,8 +143,6 @@ Tcl_PanicVA(
*----------------------------------------------------------------------
*/
-/* ARGSUSED */
-
/*
* The following comment is here so that Coverity's static analyzer knows that
* a Tcl_Panic() call can never return and avoids lots of false positives.
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 0b9ecdd..aab69f3 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -5,8 +5,8 @@
* general-purpose fashion that can be used for many different purposes,
* including compilation, direct execution, code analysis, etc.
*
- * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Ajuba Solutions.
+ * Copyright © 1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions.
* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution of
@@ -19,12 +19,7 @@
/*
* The following table provides parsing information about each possible 8-bit
- * character. The table is designed to be referenced with either signed or
- * unsigned characters, so it has 384 entries. The first 128 entries
- * correspond to negative character values, the next 256 correspond to
- * positive character values. The last 128 entries are identical to the first
- * 128. The table is always indexed with a 128-byte offset (the 128th entry
- * corresponds to a character value of 0).
+ * character. The table is designed to be referenced with unsigned characters.
*
* The macro CHAR_TYPE is used to index into the table and return information
* about its character argument. The following return values are defined.
@@ -44,42 +39,6 @@
*/
const char tclCharTypeTable[] = {
- /*
- * Negative character values, from -128 to -1:
- */
-
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
- TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
/*
* Positive character values, from 0-127:
@@ -160,13 +119,15 @@ const char tclCharTypeTable[] = {
* Prototypes for local functions defined in this file:
*/
-static inline int CommandComplete(const char *script, int numBytes);
+static int CommandComplete(const char *script, int numBytes);
static int ParseComment(const char *src, int numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, int numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static int ParseWhiteSpace(const char *src, int numBytes,
int *incompletePtr, char *typePtr);
+static int ParseAllWhiteSpace(const char *src, int numBytes,
+ int *incompletePtr);
static int ParseHex(const char *src, int numBytes,
int *resultPtr);
@@ -300,9 +261,43 @@ Tcl_ParseCommand(
*/
parsePtr->commandStart = src;
+ type = CHAR_TYPE(*src);
+ scanned = 1; /* Can't have missing whitepsace before first word. */
while (1) {
int expandWord = 0;
+ /* Are we at command termination? */
+
+ if ((numBytes == 0) || (type & terminators) != 0) {
+ parsePtr->term = src;
+ parsePtr->commandSize = src + (numBytes != 0)
+ - parsePtr->commandStart;
+ return TCL_OK;
+ }
+
+ /* Are we missing white space after previous word? */
+
+ if (scanned == 0) {
+ if (src[-1] == '"') {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
+ }
+ parsePtr->term = src;
+ error:
+ Tcl_FreeParse(parsePtr);
+ parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
+ return TCL_ERROR;
+ }
+
/*
* Create the token for the word.
*/
@@ -312,23 +307,6 @@ Tcl_ParseCommand(
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->type = TCL_TOKEN_WORD;
- /*
- * Skip white space before the word. Also skip a backslash-newline
- * sequence: it should be treated just like white space.
- */
-
- scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- src += scanned;
- numBytes -= scanned;
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
@@ -548,52 +526,12 @@ Tcl_ParseCommand(
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
- /*
- * Do two additional checks: (a) make sure we're really at the end of
- * a word (there might have been garbage left after a quoted or braced
- * word), and (b) check for the end of the command.
- */
+ /* Parse the whitespace between words. */
scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
- if (scanned) {
- src += scanned;
- numBytes -= scanned;
- continue;
- }
-
- if (numBytes == 0) {
- parsePtr->term = src;
- break;
- }
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
- break;
- }
- if (src[-1] == '"') {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-quote", -1));
- }
- parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
- } else {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "extra characters after close-brace", -1));
- }
- parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
- }
- parsePtr->term = src;
- goto error;
+ src += scanned;
+ numBytes -= scanned;
}
-
- parsePtr->commandSize = src - parsePtr->commandStart;
- return TCL_OK;
-
- error:
- Tcl_FreeParse(parsePtr);
- parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
- return TCL_ERROR;
}
/*
@@ -735,23 +673,32 @@ ParseWhiteSpace(
*----------------------------------------------------------------------
*/
-int
-TclParseAllWhiteSpace(
+static int
+ParseAllWhiteSpace(
const char *src, /* First character to parse. */
- int numBytes) /* Max number of byes to scan */
+ int numBytes, /* Max number of byes to scan */
+ int *incompletePtr) /* Set true if parse is incomplete. */
{
- int dummy;
char type;
const char *p = src;
do {
- int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type);
+ int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);
p += scanned;
numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++, --numBytes));
return (p-src);
}
+
+int
+TclParseAllWhiteSpace(
+ const char *src, /* First character to parse. */
+ int numBytes) /* Max number of byes to scan */
+{
+ int dummy;
+ return ParseAllWhiteSpace(src, numBytes, &dummy);
+}
/*
*----------------------------------------------------------------------
@@ -839,13 +786,13 @@ TclParseBackslash(
* of bytes scanned should be written. */
char *dst) /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
- * written. At most TCL_UTF_MAX bytes will be
- * written there. */
+ * written. At most 4 bytes will be written there. */
{
const char *p = src+1;
+ int unichar;
int result;
int count;
- char buf[TCL_UTF_MAX] = "";
+ char buf[4] = "";
if (numBytes == 0) {
if (readPtr != NULL) {
@@ -921,7 +868,6 @@ TclParseBackslash(
* No hexdigits -> This is just "u".
*/
result = 'u';
-#if TCL_UTF_MAX > 3
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
@@ -932,7 +878,6 @@ TclParseBackslash(
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
-#endif
}
break;
case 'U':
@@ -942,11 +887,9 @@ TclParseBackslash(
* No hexdigits -> This is just "U".
*/
result = 'U';
-#if TCL_UTF_MAX > 3
- } else if ((result & ~0x7FF) == 0xD800) {
+ } else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
result = 0xFFFD;
-#endif
}
break;
case '\n':
@@ -992,15 +935,16 @@ TclParseBackslash(
* #217987] test subst-3.2
*/
- if (TclUCS4Complete(p, numBytes - 1)) {
- count = TclUtfToUCS4(p, &result) + 1; /* +1 for '\' */
+ if (Tcl_UtfCharComplete(p, numBytes - 1)) {
+ count = Tcl_UtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[8];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
- count = TclUtfToUCS4(utfBytes, &result) + 1;
+ count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1;
}
+ result = unichar;
break;
}
@@ -1008,12 +952,12 @@ TclParseBackslash(
if (readPtr != NULL) {
*readPtr = count;
}
-#if TCL_UTF_MAX < 4
- if (result > 0xFFFF) {
- result = 0xFFFD;
+ count = Tcl_UniCharToUtf(result, dst);
+ if ((result >= 0xD800) && (count < 3)) {
+ /* Special case for handling high surrogates. */
+ count += Tcl_UniCharToUtf(-1, dst + count);
}
-#endif
- return TclUCS4ToUtf(result, dst);
+ return count;
}
/*
@@ -1043,17 +987,12 @@ ParseComment(
* command. */
{
const char *p = src;
+ int incomplete = parsePtr->incomplete;
while (numBytes) {
- char type;
- int scanned;
-
- do {
- scanned = ParseWhiteSpace(p, numBytes,
- &parsePtr->incomplete, &type);
- p += scanned;
- numBytes -= scanned;
- } while (numBytes && (*p == '\n') && (p++,numBytes--));
+ int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
+ p += scanned;
+ numBytes -= scanned;
if ((numBytes == 0) || (*p != '#')) {
break;
@@ -1062,35 +1001,28 @@ ParseComment(
parsePtr->commentStart = p;
}
+ p++;
+ numBytes--;
while (numBytes) {
+ if (*p == '\n') {
+ p++;
+ numBytes--;
+ break;
+ }
if (*p == '\\') {
- scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete,
- &type);
- if (scanned) {
- p += scanned;
- numBytes -= scanned;
- } else {
- /*
- * General backslash substitution in comments isn't part
- * of the formal spec, but test parse-15.47 and history
- * indicate that it has been the de facto rule. Don't
- * change it now.
- */
-
- TclParseBackslash(p, numBytes, &scanned, NULL);
- p += scanned;
- numBytes -= scanned;
- }
- } else {
p++;
numBytes--;
- if (p[-1] == '\n') {
+ if (numBytes == 0) {
break;
}
}
+ incomplete = (*p == '\n');
+ p++;
+ numBytes--;
}
parsePtr->commentSize = p - parsePtr->commentStart;
}
+ parsePtr->incomplete = incomplete;
return (p - src);
}
@@ -1213,7 +1145,7 @@ ParseTokens(
src++;
numBytes--;
- nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
+ nestedPtr = (Tcl_Parse *)TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
const char *curEnd;
@@ -1600,7 +1532,7 @@ Tcl_ParseVar(
{
Tcl_Obj *objPtr;
int code;
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
TclStackFree(interp, parsePtr);
@@ -2079,7 +2011,7 @@ TclSubstParse(
Tcl_Token *tokenPtr;
const char *lastTerm = parsePtr->term;
- Tcl_Parse *nestedPtr =
+ Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
while (TCL_OK ==
@@ -2221,7 +2153,7 @@ TclSubstTokens(
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
- clPosition = ckalloc(maxNumCL * sizeof(int));
+ clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
@@ -2230,7 +2162,7 @@ TclSubstTokens(
Tcl_Obj *appendObj = NULL;
const char *append = NULL;
int appendByteLength = 0;
- char utfCharBytes[TCL_UTF_MAX] = "";
+ char utfCharBytes[4] = "";
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
@@ -2266,12 +2198,12 @@ TclSubstTokens(
if (result == 0) {
clPos = 0;
} else {
- Tcl_GetStringFromObj(result, &clPos);
+ TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
- clPosition = ckrealloc(clPosition,
+ clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
@@ -2464,7 +2396,7 @@ TclSubstTokens(
*----------------------------------------------------------------------
*/
-static inline int
+static int
CommandComplete(
const char *script, /* Script to check. */
int numBytes) /* Number of bytes in script. */
@@ -2542,7 +2474,7 @@ TclObjCommandComplete(
* check. */
{
int length;
- const char *script = Tcl_GetStringFromObj(objPtr, &length);
+ const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
diff --git a/generic/tclParse.h b/generic/tclParse.h
index 9247602..5f75c9a 100644
--- a/generic/tclParse.h
+++ b/generic/tclParse.h
@@ -12,6 +12,6 @@
#define TYPE_CLOSE_BRACK 0x20
#define TYPE_BRACE 0x40
-#define CHAR_TYPE(c) (tclCharTypeTable+128)[(unsigned char)(c)]
+#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)]
MODULE_SCOPE const char tclCharTypeTable[];
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index f5571e2..7282709 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -5,7 +5,7 @@
* to represent and manipulate a general (virtual) filesystem entity in
* an efficient manner.
*
- * Copyright (c) 2003 Vince Darley.
+ * Copyright © 2003 Vince Darley.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -30,13 +30,16 @@ static int IsSeparatorOrNull(int ch);
static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr);
static int MakePathFromNormalized(Tcl_Interp *interp,
Tcl_Obj *pathPtr);
+static int MakeTildeRelativePath(Tcl_Interp *interp,
+ const char *user, const char *subPath,
+ Tcl_DString *dsPtr);
/*
* Define the 'path' object type, which Tcl uses to represent file paths
* internally.
*/
-static const Tcl_ObjType tclFsPathType = {
+static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -47,46 +50,21 @@ static const Tcl_ObjType tclFsPathType = {
/*
* struct FsPath --
*
- * Internal representation of a Tcl_Obj of "path" type. This can be used to
- * represent relative or absolute paths, and has certain optimisations when
- * used to represent paths which are already normalized and absolute.
- *
- * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular
- * reference to the container Tcl_Obj of this FsPath.
- *
- * There are two cases, with the first being the most common:
- *
- * (i) flags == 0, => Ordinary path.
- *
- * translatedPathPtr contains the translated path (which may be a circular
- * reference to the object itself). If it is NULL then the path is pure
- * normalized (and the normPathPtr will be a circular reference). cwdPtr is
- * null for an absolute path, and non-null for a relative path (unless the cwd
- * has never been set, in which case the cwdPtr may also be null for a
- * relative path).
- *
- * (ii) flags != 0, => Special path, see TclNewFSPathObj
- *
- * Now, this is a path like 'file join $dir $tail' where, cwdPtr is the $dir
- * and normPathPtr is the $tail.
- *
+ * Internal representation of a Tcl_Obj of fsPathType
*/
typedef struct FsPath {
- Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this
- * is NULL, then this is a pure normalized,
- * absolute path object, in which the parent
- * Tcl_Obj's string rep is already both
- * translated and normalized. */
- Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or
- * ~user sequences. If the Tcl_Obj containing
- * this FsPath is already normalized, this may
- * be a circular reference back to the
- * container. If that is NOT the case, we have
- * a refCount on the object. */
- Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points
- * to the cwd object used for this path. We
- * have a refCount on the object. */
+ Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags ==
+ * 0), this is NULL. Otherwise it is a path
+ * in which any ~user sequences have been
+ * translated away. */
+ Tcl_Obj *normPathPtr; /* If the path has been normalized (flags ==
+ * 0), this is an absolute path without ., ..
+ * or ~user components. Otherwise it is a
+ * path, possibly absolute, to normalize
+ * relative to cwdPtr. */
+ Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or
+ * normPathPtr exists and is absolute. */
int flags; /* Flags to describe interpretation - see
* below. */
ClientData nativePathPtr; /* Native representation of this path, which
@@ -110,9 +88,14 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
+#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \
+ } while (0)
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
@@ -135,17 +118,17 @@ typedef struct FsPath {
* pathPtr may have a refCount of zero, or may be a shared object.
*
* Results:
- * The result is returned in a Tcl_Obj with a refCount of 1, which is
- * therefore owned by the caller. It must be freed (with
- * Tcl_DecrRefCount) by the caller when no longer needed.
+ * The result is returned in a Tcl_Obj with a refCount already
+ * incremented, which gives the caller ownership of it. The caller must
+ * arrange for Tcl_DecRefCount to be called when the object is no-longer
+ * needed.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special note:
- * This code was originally based on code from Matt Newman and
- * Jean-Claude Wippler, but has since been totally rewritten by Vince
- * Darley to deal with symbolic links.
+ * Originally based on code from Matt Newman and Jean-Claude Wippler.
+ * Totally rewritten later by Vince Darley to handle symbolic links.
*
*---------------------------------------------------------------------------
*/
@@ -160,9 +143,17 @@ TclFSNormalizeAbsolutePath(
* directory separator - we can't use '..' to
* remove the volume in a path. */
Tcl_Obj *retVal = NULL;
+ int zipVolumeLen;
dirSep = TclGetString(pathPtr);
- if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ zipVolumeLen = TclIsZipfsPath(dirSep);
+ if (zipVolumeLen) {
+ /*
+ * NOTE: file normalization for zipfs is very specific to
+ * format of zipfs volume being of the form //xxx:/
+ */
+ dirSep += zipVolumeLen-1; /* Start parse after : */
+ } else if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if ( (dirSep[0] == '/' || dirSep[0] == '\\')
&& (dirSep[1] == '/' || dirSep[1] == '\\')
&& (dirSep[2] == '?')
@@ -232,7 +223,7 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
@@ -258,18 +249,22 @@ TclFSNormalizeAbsolutePath(
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
- linkObj = Tcl_FSLink(retVal, NULL, 0);
+ if (zipVolumeLen) {
+ linkObj = NULL;
+ } else {
+ linkObj = Tcl_FSLink(retVal, NULL, 0);
- /* Safety check in case driver caused sharing */
- if (Tcl_IsShared(retVal)) {
- TclDecrRefCount(retVal);
- retVal = Tcl_DuplicateObj(retVal);
- Tcl_IncrRefCount(retVal);
+ /* Safety check in case driver caused sharing */
+ if (Tcl_IsShared(retVal)) {
+ TclDecrRefCount(retVal);
+ retVal = Tcl_DuplicateObj(retVal);
+ Tcl_IncrRefCount(retVal);
+ }
}
if (linkObj != NULL) {
@@ -289,7 +284,7 @@ TclFSNormalizeAbsolutePath(
*/
const char *path =
- Tcl_GetStringFromObj(retVal, &curLen);
+ TclGetStringFromObj(retVal, &curLen);
while (--curLen >= 0) {
if (IsSeparatorOrNull(path[curLen])) {
@@ -304,7 +299,7 @@ TclFSNormalizeAbsolutePath(
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
@@ -317,7 +312,7 @@ TclFSNormalizeAbsolutePath(
} else {
retVal = linkObj;
}
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
@@ -334,15 +329,17 @@ TclFSNormalizeAbsolutePath(
}
}
} else {
- linkStr = Tcl_GetStringFromObj(retVal, &curLen);
+ linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
* Either way, we now remove the last path element (but
- * not the first character of the path).
+ * not the first character of the path). In the case of
+ * zipfs, make sure not to go beyond the zipfs volume.
*/
- while (--curLen >= 0) {
+ int minLen = zipVolumeLen ? zipVolumeLen - 1 : 0;
+ while (--curLen >= minLen) {
if (IsSeparatorOrNull(linkStr[curLen])) {
if (curLen) {
Tcl_SetObjLength(retVal, curLen);
@@ -401,13 +398,21 @@ TclFSNormalizeAbsolutePath(
/*
* Ensure a windows drive like C:/ has a trailing separator.
+ * Likewise for zipfs volumes.
*/
-
- if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
+ int needTrailingSlash = 0;
int len;
- const char *path = Tcl_GetStringFromObj(retVal, &len);
-
- if (len == 2 && path[0] != 0 && path[1] == ':') {
+ const char *path = TclGetStringFromObj(retVal, &len);
+ if (zipVolumeLen) {
+ if (len == (zipVolumeLen - 1))
+ needTrailingSlash = 1;
+ } else {
+ if (len == 2 && path[0] != 0 && path[1] == ':') {
+ needTrailingSlash = 1;
+ }
+ }
+ if (needTrailingSlash) {
if (Tcl_IsShared(retVal)) {
TclDecrRefCount(retVal);
retVal = Tcl_DuplicateObj(retVal);
@@ -564,7 +569,7 @@ TclPathPart(
Tcl_Obj *pathPtr, /* Path to take dirname of */
Tcl_PathPart portion) /* Requested portion of name */
{
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0) {
@@ -580,7 +585,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -618,7 +623,7 @@ TclPathPart(
int numBytes;
const char *rest =
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
@@ -647,7 +652,7 @@ TclPathPart(
const char *fileName, *extension;
int length;
- fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
+ fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
@@ -699,7 +704,7 @@ TclPathPart(
int length;
const char *fileName, *extension;
- fileName = Tcl_GetStringFromObj(pathPtr, &length);
+ fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
@@ -714,9 +719,8 @@ TclPathPart(
}
/*
- * The behaviour we want here is slightly different to the standard
* Tcl_FSSplitPath in the handling of home directories;
- * Tcl_FSSplitPath preserves the "~" while this code computes the
+ * Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
@@ -833,12 +837,12 @@ Tcl_FSJoinPath(
int objc;
Tcl_Obj **objv;
- if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) {
+ if (TclListObjLengthM(NULL, listObj, &objc) != TCL_OK) {
return NULL;
}
elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
- TclListObjGetElements(NULL, listObj, &objc, &objv);
+ TclListObjGetElementsM(NULL, listObj, &objc, &objv);
res = TclJoinPath(elements, objv, 0);
return res;
}
@@ -865,6 +869,7 @@ TclJoinPath(
if (elements == 2) {
Tcl_Obj *elt = objv[0];
+ Tcl_ObjInternalRep *eltIr = TclFetchInternalRep(elt, &fsPathType);
/*
* This is a special case where we can be much more efficient, where
@@ -875,10 +880,10 @@ TclJoinPath(
* could expand that in the future.
*
* Bugfix [a47641a0]. TclNewFSPathObj requires first argument
- * to be an absolute path. Added a check for that elt is absolute.
+ * to be an absolute path. Added a check to ensure that elt is absolute.
*/
- if ((elt->typePtr == &tclFsPathType)
+ if ((eltIr)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
Tcl_Obj *tailObj = objv[1];
@@ -891,7 +896,7 @@ TclJoinPath(
const char *str;
int len;
- str = Tcl_GetStringFromObj(tailObj, &len);
+ str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
@@ -962,7 +967,7 @@ TclJoinPath(
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
- strElt = Tcl_GetStringFromObj(elt, &strEltLen);
+ strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
/* if forceRelative - all paths excepting first one are relative */
type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
@@ -1058,10 +1063,8 @@ TclJoinPath(
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
- ptr = Tcl_GetStringFromObj(res, &length);
- } else {
- ptr = Tcl_GetStringFromObj(res, &length);
}
+ ptr = TclGetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the beginning of
@@ -1094,7 +1097,7 @@ TclJoinPath(
if (sep != NULL) {
separator = TclGetString(sep)[0];
- Tcl_DecrRefCount(sep);
+ TclDecrRefCount(sep);
}
/* Safety check in case the VFS driver caused sharing */
if (Tcl_IsShared(res)) {
@@ -1106,7 +1109,7 @@ TclJoinPath(
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
- Tcl_GetStringFromObj(res, &length);
+ TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
@@ -1172,39 +1175,16 @@ Tcl_FSConvertToPathType(
* path.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) {
return TCL_OK;
}
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
}
return SetFsPathFromAny(interp, pathPtr);
-
- /*
- * We used to have more complex code here:
- *
- * FsPath *fsPathPtr = PATHOBJ(pathPtr);
- * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
- * return TCL_OK;
- * } else {
- * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- * return TCL_OK;
- * } else {
- * if (pathPtr->bytes == NULL) {
- * UpdateStringOfFsPath(pathPtr);
- * }
- * FreeFsPathInternalRep(pathPtr);
- * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
- * }
- * }
- *
- * But we no longer believe this is necessary.
- */
}
/*
@@ -1319,7 +1299,7 @@ TclNewFSPathObj(
}
TclNewObj(pathPtr);
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
@@ -1336,9 +1316,7 @@ TclNewFSPathObj(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
- pathPtr->typePtr = &tclFsPathType;
- pathPtr->bytes = NULL;
- pathPtr->length = 0;
+ TclInvalidateStringRep(pathPtr);
/*
* Look for path components made up of only "."
@@ -1400,7 +1378,7 @@ AppendPath(
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
- bytes = Tcl_GetStringFromObj(tail, &numBytes);
+ bytes = TclGetStringFromObj(tail, &numBytes);
if (numBytes == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
@@ -1433,14 +1411,15 @@ AppendPath(
Tcl_Obj *
TclFSMakePathRelative(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* The path we have. */
Tcl_Obj *cwdPtr) /* Make it relative to this. */
{
int cwdLen, len;
const char *tempStr;
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(pathPtr, &fsPathType);
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
@@ -1459,7 +1438,7 @@ TclFSMakePathRelative(
* too little below, leading to wrong answers returned by glob.
*/
- tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ tempStr = TclGetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
@@ -1479,7 +1458,7 @@ TclFSMakePathRelative(
}
break;
}
- tempStr = Tcl_GetStringFromObj(pathPtr, &len);
+ tempStr = TclGetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -1503,36 +1482,16 @@ TclFSMakePathRelative(
static int
MakePathFromNormalized(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
- /*
- * Free old representation
- */
-
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't find object string representation", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
- NULL);
- }
- return TCL_ERROR;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
@@ -1540,11 +1499,7 @@ MakePathFromNormalized(
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
@@ -1553,7 +1508,6 @@ MakePathFromNormalized(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1563,7 +1517,7 @@ MakePathFromNormalized(
*
* Tcl_FSNewNativePath --
*
- * This function performs the something like the reverse of the usual
+ * Performs the something like the reverse of the usual
* obj->path->nativerep conversions. If some code retrieves a path in
* native form (from, e.g. readlink or a native dialog), and that path is
* to be used at the Tcl level, then calling this function is an
@@ -1604,25 +1558,12 @@ Tcl_FSNewNativePath(
* safe.
*/
- if (pathPtr->typePtr != NULL) {
- if (pathPtr->bytes == NULL) {
- if (pathPtr->typePtr->updateStringProc == NULL) {
- return NULL;
- }
- pathPtr->typePtr->updateStringProc(pathPtr);
- }
- TclFreeIntRep(pathPtr);
- }
-
- fsPathPtr = ckalloc(sizeof(FsPath));
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
- /*
- * Circular reference, by design.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
@@ -1630,7 +1571,6 @@ Tcl_FSNewNativePath(
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return pathPtr;
}
@@ -1640,16 +1580,18 @@ Tcl_FSNewNativePath(
*
* Tcl_FSGetTranslatedPath --
*
- * This function attempts to extract the translated path from the given
+ * Attempts to extract the translated path from the given
* Tcl_Obj. If the translation succeeds (i.e. the object is a valid
- * path), then it is returned. Otherwise NULL will be returned, and an
- * error message may be left in the interpreter (if it is non-NULL)
+ * path), then it is returned. Otherwise NULL is returned and an
+ * error message may be left in the interpreter if it is not NULL.
*
* Results:
- * NULL or a valid Tcl_Obj pointer.
+ * A Tcl_Obj pointer or NULL.
*
* Side effects:
- * Only those of 'Tcl_FSConvertToPathType'
+ * pathPtr is converted to fsPathType if necessary.
+ *
+ * FsPath members are modified as needed.
*
*---------------------------------------------------------------------------
*/
@@ -1667,7 +1609,12 @@ Tcl_FSGetTranslatedPath(
}
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
- if (PATHFLAGS(pathPtr) != 0) {
+ if (PATHFLAGS(pathPtr) == 0) {
+ /*
+ * Path is already normalized
+ */
+ retObj = srcFsPathPtr->normPathPtr;
+ } else {
/*
* We lack a translated path result, but we have a directory
* (cwdPtr) and a tail (normPathPtr), and if we join the
@@ -1677,29 +1624,23 @@ Tcl_FSGetTranslatedPath(
Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp,
srcFsPathPtr->cwdPtr);
+ Tcl_ObjInternalRep *translatedCwdIrPtr;
+
if (translatedCwdPtr == NULL) {
return NULL;
}
retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1,
&srcFsPathPtr->normPathPtr);
- srcFsPathPtr->translatedPathPtr = retObj;
- if (translatedCwdPtr->typePtr == &tclFsPathType) {
+ Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj);
+ translatedCwdIrPtr = TclFetchInternalRep(translatedCwdPtr, &fsPathType);
+ if (translatedCwdIrPtr) {
srcFsPathPtr->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
- Tcl_IncrRefCount(retObj);
Tcl_DecrRefCount(translatedCwdPtr);
- } else {
- /*
- * It is a pure absolute, normalized path object. This is
- * something like being a 'pure list'. The object's string,
- * translatedPath and normalizedPath are all identical.
- */
-
- retObj = srcFsPathPtr->normPathPtr;
}
} else {
/*
@@ -1743,8 +1684,8 @@ Tcl_FSGetTranslatedStringPath(
if (transPtr != NULL) {
int len;
- const char *orig = Tcl_GetStringFromObj(transPtr, &len);
- char *result = ckalloc(len+1);
+ const char *orig = TclGetStringFromObj(transPtr, &len);
+ char *result = (char *)ckalloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
@@ -1800,11 +1741,9 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
/* TODO: Figure out why this is needed. */
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
+ TclGetString(pathPtr);
- Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
+ TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
@@ -1817,7 +1756,7 @@ Tcl_FSGetNormalizedPath(
* We now own a reference on both 'dir' and 'copy'
*/
- (void) Tcl_GetStringFromObj(dir, &cwdLen);
+ (void) TclGetStringFromObj(dir, &cwdLen);
/* Normalize the combined string. */
@@ -1854,7 +1793,7 @@ Tcl_FSGetNormalizedPath(
/*
* NOTE: here we are (dangerously?) assuming that origDir points
- * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The
+ * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The
* pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
* above that set the pathType value should have established that,
* but it's far less clear on what basis we know there's been no
@@ -1869,10 +1808,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
@@ -1881,10 +1816,6 @@ Tcl_FSGetNormalizedPath(
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
- /*
- * That's our reference to copy used.
- */
-
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
@@ -1896,10 +1827,8 @@ Tcl_FSGetNormalizedPath(
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
@@ -1910,7 +1839,7 @@ Tcl_FSGetNormalizedPath(
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
- (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
+ (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/*
@@ -1925,10 +1854,9 @@ Tcl_FSGetNormalizedPath(
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
- int pureNormalized = 1;
/*
- * Since normPathPtr is NULL, but this is a valid path object, we know
+ * Since normPathPtr is NULL but this is a valid path object, we know
* that the translatedPathPtr cannot be NULL.
*/
@@ -1975,7 +1903,6 @@ Tcl_FSGetNormalizedPath(
return NULL;
}
- pureNormalized = 0;
Tcl_DecrRefCount(absolutePath);
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
@@ -1995,7 +1922,6 @@ Tcl_FSGetNormalizedPath(
if (absolutePath == NULL) {
return NULL;
}
- pureNormalized = 0;
#endif /* _WIN32 */
}
}
@@ -2004,35 +1930,12 @@ Tcl_FSGetNormalizedPath(
* Already has refCount incremented.
*/
+ if (fsPathPtr->normPathPtr) {
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ }
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp,
absolutePath);
- /*
- * Check if path is pure normalized (this can only be the case if it
- * is an absolute path).
- */
-
- if (pureNormalized) {
- int normPathLen, pathLen;
- const char *normPath;
-
- path = TclGetStringFromObj(pathPtr, &pathLen);
- normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen);
- if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) {
- /*
- * The path was already normalized. Get rid of the duplicate.
- */
-
- TclDecrRefCount(fsPathPtr->normPathPtr);
-
- /*
- * We do *not* increment the refCount for this circular
- * reference.
- */
-
- fsPathPtr->normPathPtr = pathPtr;
- }
- }
if (useThisCwd != NULL) {
/*
* We just need to free an object we allocated above for relative
@@ -2053,19 +1956,23 @@ Tcl_FSGetNormalizedPath(
*
* Tcl_FSGetInternalRep --
*
- * Extract the internal representation of a given path object, in the
- * given filesystem. If the path object belongs to a different
- * filesystem, we return NULL.
+ * Produces a native representation of a given path object in the given
+ * filesystem.
*
- * If the internal representation is currently NULL, we attempt to
- * generate it, by calling the filesystem's
- * 'Tcl_FSCreateInternalRepProc'.
+ * In the future it might be desirable to have separate versions
+ * of this function with different signatures, for example
+ * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
+ * native paths are all string based, we use just one function.
*
* Results:
- * NULL or a valid internal representation.
+ *
+ * The native handle for the path, or NULL if the path is not handled by
+ * the given filesystem
*
* Side effects:
- * An attempt may be made to convert the object.
+ *
+ * Tcl_FSCreateInternalRepProc if needed to produce the native
+ * handle, which is then stored in the internal representation of pathPtr.
*
*---------------------------------------------------------------------------
*/
@@ -2083,49 +1990,36 @@ Tcl_FSGetInternalRep(
srcFsPathPtr = PATHOBJ(pathPtr);
/*
- * We will only return the native representation for the caller's
- * filesystem. Otherwise we will simply return NULL. This means that there
- * must be a unique bi-directional mapping between paths and filesystems,
- * and that this mapping will not allow 'remapped' files -- files which
- * are in one filesystem but mapped into another. Another way of putting
- * this is that 'stacked' filesystems are not allowed. We recognise that
- * this is a potentially useful feature for the future.
+ * Currently there must be a unique bi-directional mapping between a path
+ * and a filesystem, and therefore there is no way to "remap" a file, i.e.,
+ * to map a file in one filesystem into another. Another way of putting
+ * this is that 'stacked' filesystems are not allowed. It could be useful
+ * in the future to redesign the system to allow that.
*
* Even something simple like a 'pass through' filesystem which logs all
* activity and passes the calls onto the native system would be nice, but
- * not easily achievable with the current implementation.
+ * not currently easily achievable.
*/
if (srcFsPathPtr->fsPtr == NULL) {
- /*
- * This only usually happens in wrappers like TclpStat which create a
- * string object and pass it to TclpObjStat. Code which calls the
- * Tcl_FS.. functions should always have a filesystem already set.
- * Whether this code path is legal or not depends on whether we decide
- * to allow external code to call the native filesystem directly. It
- * is at least safer to allow this sub-optimal routing.
- */
-
Tcl_FSGetFileSystemForPath(pathPtr);
- /*
- * If we fail through here, then the path is probably not a valid path
- * in the filesystsem, and is most likely to be a use of the empty
- * path "" via a direct call to one of the objectified interfaces
- * (e.g. from the Tcl testsuite).
- */
-
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->fsPtr == NULL) {
+ /*
+ * The path is probably not a valid path in the filesystsem, and is
+ * most likely to be a use of the empty path "" via a direct call
+ * to one of the objectified interfaces (e.g. from the Tcl
+ * testsuite).
+ */
return NULL;
}
}
/*
- * There is still one possibility we should consider; if the file belongs
- * to a different filesystem, perhaps it is actually linked through to a
- * file in our own filesystem which we do care about. The way we can check
- * for this is we ask what filesystem this path belongs to.
+ * If the file belongs to a different filesystem, perhaps it is actually
+ * linked through to a file in the given filesystem. Check this by
+ * inspecting the filesystem associated with the given path.
*/
if (fsPtr != srcFsPathPtr->fsPtr) {
@@ -2146,7 +2040,7 @@ Tcl_FSGetInternalRep(
return NULL;
}
- nativePathPtr = proc(pathPtr);
+ nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
@@ -2160,15 +2054,15 @@ Tcl_FSGetInternalRep(
*
* TclFSEnsureEpochOk --
*
- * This will ensure the pathPtr is up to date and can be converted into a
- * "path" type, and that we are able to generate a complete normalized
- * path which is used to determine the filesystem match.
+ * Ensure that the path is a valid path, and that it has a
+ * fsPathType internal representation that is not stale.
*
* Results:
- * Standard Tcl return code.
+ * A standard Tcl return code.
*
* Side effects:
- * An attempt may be made to convert the object.
+ * The internal representation of fsPtrPtr is converted to fsPathType if
+ * possible.
*
*---------------------------------------------------------------------------
*/
@@ -2180,37 +2074,31 @@ TclFSEnsureEpochOk(
{
FsPath *srcFsPathPtr;
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
srcFsPathPtr = PATHOBJ(pathPtr);
- /*
- * Check if the filesystem has changed in some way since this object's
- * internal representation was calculated.
- */
-
if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
/*
- * We have to discard the stale representation and recalculate it.
+ * The filesystem has changed in some way since the internal
+ * representation for this object was calculated. Discard the stale
+ * representation and recalculate it.
*/
- if (pathPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathPtr);
- }
- FreeFsPathInternalRep(pathPtr);
+ TclGetString(pathPtr);
+ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = PATHOBJ(pathPtr);
}
- /*
- * Check whether the object is already assigned to a fs.
- */
-
if (srcFsPathPtr->fsPtr != NULL) {
+ /*
+ * There is already a filesystem assigned to this path.
+ */
*fsPtrPtr = srcFsPathPtr->fsPtr;
}
return TCL_OK;
@@ -2244,7 +2132,7 @@ TclFSSetPathDetails(
* Make sure pathPtr is of the correct type.
*/
- if (pathPtr->typePtr != &tclFsPathType) {
+ if (!TclHasInternalRep(pathPtr, &fsPathType)) {
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return;
}
@@ -2318,11 +2206,12 @@ Tcl_FSEqualPaths(
*
* SetFsPathFromAny --
*
- * This function tries to convert the given Tcl_Obj to a valid Tcl path
- * type.
+ * Attempt to convert the internal representation of pathPtr to
+ * fsPathType.
*
- * The filename may begin with "~" (to indicate current user's home
- * directory) or "~<user>" (to indicate any user's home directory).
+ * A tilde ("~") character at the beginnig of the filename indicates the
+ * current user's home directory, and "~<user>" indicates a particular
+ * user's directory.
*
* Results:
* Standard Tcl error code.
@@ -2341,9 +2230,9 @@ SetFsPathFromAny(
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
- char *name;
+ const char *name;
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
@@ -2361,7 +2250,7 @@ SetFsPathFromAny(
* cmdAH.test exercise most of the code).
*/
- name = Tcl_GetStringFromObj(pathPtr, &len);
+ name = TclGetStringFromObj(pathPtr, &len);
/*
* Handle tilde substitutions, if needed.
@@ -2397,7 +2286,7 @@ SetFsPathFromAny(
"couldn't find HOME environment variable to"
" expand path", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
- "HOMELESS", NULL);
+ "HOMELESS", (void *)NULL);
}
return TCL_ERROR;
}
@@ -2406,7 +2295,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&dirString);
} else {
/*
- * We have a user name '~user'
+ * There is a '~user'
*/
const char *expandedUser;
@@ -2422,7 +2311,7 @@ SetFsPathFromAny(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", expandedUser));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
- NULL);
+ (void *)NULL);
}
Tcl_DStringFree(&userName);
Tcl_DStringFree(&temp);
@@ -2431,7 +2320,7 @@ SetFsPathFromAny(
Tcl_DStringFree(&userName);
}
- transPtr = TclDStringToObj(&temp);
+ transPtr = Tcl_DStringToObj(&temp);
if (split != len) {
/*
@@ -2449,7 +2338,7 @@ SetFsPathFromAny(
Tcl_Obj **objv;
Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);
- TclListObjGetElements(NULL, parts, &objc, &objv);
+ TclListObjGetElementsM(NULL, parts, &objc, &objv);
/*
* Skip '~'. It's replaced by its expansion.
@@ -2483,29 +2372,25 @@ SetFsPathFromAny(
* slashes on Windows, and will not contain any ~user sequences.
*/
- fsPathPtr = ckalloc(sizeof(FsPath));
+ fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
- fsPathPtr->translatedPathPtr = transPtr;
- if (transPtr != pathPtr) {
- Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
- /* Redo translation when $env(HOME) changes */
- fsPathPtr->filesystemEpoch = TclFSEpoch();
+ if (transPtr == pathPtr) {
+ (void)TclGetString(pathPtr);
+ TclFreeInternalRep(pathPtr);
+ transPtr = Tcl_DuplicateObj(pathPtr);
+ fsPathPtr->filesystemEpoch = 0;
} else {
- fsPathPtr->filesystemEpoch = 0;
+ fsPathPtr->filesystemEpoch = TclFSEpoch();
}
+ Tcl_IncrRefCount(transPtr);
+ fsPathPtr->translatedPathPtr = transPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsPtr = NULL;
- /*
- * Free old representation before installing our new one.
- */
-
- TclFreeIntRep(pathPtr);
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
- pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -2528,6 +2413,7 @@ FreeFsPathInternalRep(
}
if (fsPathPtr->cwdPtr != NULL) {
TclDecrRefCount(fsPathPtr->cwdPtr);
+ fsPathPtr->cwdPtr = NULL;
}
if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) {
Tcl_FSFreeInternalRepProc *freeProc =
@@ -2540,7 +2426,6 @@ FreeFsPathInternalRep(
}
ckfree(fsPathPtr);
- pathPtr->typePtr = NULL;
}
static void
@@ -2549,28 +2434,18 @@ DupFsPathInternalRep(
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
- FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath));
+ FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
- if (srcFsPathPtr->translatedPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->translatedPathPtr = copyPtr;
- } else {
- copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
- if (copyFsPathPtr->translatedPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
- }
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ if (copyFsPathPtr->translatedPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
- if (srcFsPathPtr->normPathPtr == srcPtr) {
- /* Cycle in src -> make cycle in copy. */
- copyFsPathPtr->normPathPtr = copyPtr;
- } else {
- copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
- if (copyFsPathPtr->normPathPtr != NULL) {
- Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
- }
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != NULL) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
@@ -2596,8 +2471,6 @@ DupFsPathInternalRep(
}
copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
-
- copyPtr->typePtr = &tclFsPathType;
}
/*
@@ -2629,11 +2502,15 @@ UpdateStringOfFsPath(
}
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
+ if (Tcl_IsShared(copy)) {
+ copy = Tcl_DuplicateObj(copy);
+ }
- pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
+ Tcl_IncrRefCount(copy);
+ /* Steal copy's string rep */
+ pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
- copy->bytes = tclEmptyStringRep;
- copy->length = 0;
+ TclInitEmptyStringRep(copy);
TclDecrRefCount(copy);
}
@@ -2661,7 +2538,7 @@ UpdateStringOfFsPath(
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(ClientData *))
{
/*
* A special case is required to handle the empty path "". This is a valid
@@ -2670,7 +2547,7 @@ TclNativePathInFilesystem(
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
- if (pathPtr->typePtr == &tclFsPathType) {
+ if (TclHasInternalRep(pathPtr, &fsPathType)) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/*
* We reject the empty path "".
@@ -2685,13 +2562,13 @@ TclNativePathInFilesystem(
} else {
/*
* It is somewhat unusual to reach this code path without the object
- * being of tclFsPathType. However, we do our best to deal with the
+ * being of fsPathType. However, we do our best to deal with the
* situation.
*/
int len;
- (void) Tcl_GetStringFromObj(pathPtr, &len);
+ (void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
@@ -2709,6 +2586,253 @@ TclNativePathInFilesystem(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * 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", (void *)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",
+ (void *)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 Tcl_DStringToObj(&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;
+ int len;
+ int split;
+ Tcl_DString resolvedPath;
+
+ path = TclGetStringFromObj(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 Tcl_DStringToObj(&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;
+ int objc;
+ int 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
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index 31e1143..8b6eb11 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -4,7 +4,7 @@
* This file contains the generic portion of the command channel driver
* as well as various utility routines used in managing subprocesses.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -111,7 +111,7 @@ FileForRedirect(
Tcl_GetChannelName(chan),
((writing) ? "writing" : "reading")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "BADCHAN", NULL);
+ "BADCHAN", (void *)NULL);
}
return NULL;
}
@@ -155,7 +155,7 @@ FileForRedirect(
badLastArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't specify \"%s\" as last word in command", arg));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", (void *)NULL);
return NULL;
}
@@ -188,7 +188,7 @@ Tcl_DetachPids(
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
- detPtr = ckalloc(sizeof(Detached));
+ detPtr = (Detached *)ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
@@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void)
{
Detached *detPtr;
Detached *nextPtr, *prevPtr;
- int status;
- Tcl_Pid pid;
+ int status, code;
Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
- pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
- if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
+ status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
+ if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
+ && code != ECHILD)) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
continue;
@@ -277,38 +277,21 @@ TclCleanupChildren(
{
int result = TCL_OK;
int i, abnormalExit, anyErrorInfo;
- Tcl_Pid pid;
- int waitStatus;
- const char *msg;
- unsigned long resolvedPid;
+ TclProcessWaitStatus waitStatus;
+ int code;
+ Tcl_Obj *msg, *error;
abnormalExit = 0;
for (i = 0; i < numPids; i++) {
- /*
- * We need to get the resolved pid before we wait on it as the windows
- * implementation of Tcl_WaitPid deletes the information such that any
- * following calls to TclpGetPid fail.
- */
-
- resolvedPid = TclpGetPid(pidPtr[i]);
- pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
- if (pid == (Tcl_Pid) -1) {
+ waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
+ if (waitStatus == TCL_PROCESS_ERROR) {
result = TCL_ERROR;
if (interp != NULL) {
- msg = Tcl_PosixError(interp);
- if (errno == ECHILD) {
- /*
- * This changeup in message suggested by Mark Diekhans to
- * remind people that ECHILD errors can occur on some
- * systems if SIGCHLD isn't in its default state.
- */
-
- msg =
- "child process lost (is SIGCHLD ignored or trapped?)";
- }
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error waiting for process to exit: %s", msg));
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
continue;
}
@@ -319,39 +302,19 @@ TclCleanupChildren(
* removed).
*/
- if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
- char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
-
+ if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
result = TCL_ERROR;
- snprintf(msg1, sizeof(msg1), "%lu", resolvedPid);
- if (WIFEXITED(waitStatus)) {
+ if (waitStatus == TCL_PROCESS_EXITED) {
if (interp != NULL) {
- snprintf(msg2, sizeof(msg2), "%u", WEXITSTATUS(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
+ Tcl_SetObjErrorCode(interp, error);
}
abnormalExit = 1;
} else if (interp != NULL) {
- const char *p;
-
- if (WIFSIGNALED(waitStatus)) {
- p = Tcl_SignalMsg(WTERMSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
- Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child killed: %s\n", p));
- } else if (WIFSTOPPED(waitStatus)) {
- p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
- Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child suspended: %s\n", p));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "child wait status didn't make sense\n", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "ODDWAITRESULT", msg1, NULL);
- }
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
}
}
@@ -370,7 +333,7 @@ TclCleanupChildren(
int count;
Tcl_Obj *objPtr;
- Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
+ Tcl_Seek(errorChan, 0, SEEK_SET);
TclNewObj(objPtr);
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
@@ -550,7 +513,7 @@ TclCreatePipeline(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "PIPESYNTAX", NULL);
+ "PIPESYNTAX", (void *)NULL);
goto error;
}
}
@@ -579,7 +542,7 @@ TclCreatePipeline(
"can't specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "PIPESYNTAX", NULL);
+ "PIPESYNTAX", (void *)NULL);
goto error;
}
skip = 2;
@@ -696,7 +659,7 @@ TclCreatePipeline(
"must specify \"%s\" as last word in command",
argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "PIPESYNTAX", NULL);
+ "PIPESYNTAX", (void *)NULL);
goto error;
}
errorFile = outputFile;
@@ -738,7 +701,7 @@ TclCreatePipeline(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal use of | or |& in command", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
- NULL);
+ (void *)NULL);
goto error;
}
@@ -861,7 +824,7 @@ TclCreatePipeline(
*/
Tcl_ReapDetachedProcs();
- pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid));
+ pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
@@ -936,6 +899,7 @@ TclCreatePipeline(
pidPtr[numPids] = pid;
numPids++;
+ TclProcessCreated(pid);
/*
* Close off our copies of file descriptors that were set up for this
@@ -1091,7 +1055,7 @@ Tcl_OpenCommandChannel(
"can't read output from command:"
" standard output was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "BADREDIRECT", NULL);
+ "BADREDIRECT", (void *)NULL);
goto error;
}
if ((flags & TCL_STDIN) && (inPipe == NULL)) {
@@ -1099,7 +1063,7 @@ Tcl_OpenCommandChannel(
"can't write input to command:"
" standard input was redirected", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "BADREDIRECT", NULL);
+ "BADREDIRECT", (void *)NULL);
goto error;
}
}
@@ -1110,7 +1074,7 @@ Tcl_OpenCommandChannel(
if (channel == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"pipe for command could not be created", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", (void *)NULL);
goto error;
}
return channel;
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index ec932f1..b5b5582 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -4,8 +4,8 @@
* This file implements package and version control for Tcl via the
* "package" command and a few C APIs.
*
- * Copyright (c) 1996 Sun Microsystems, Inc.
- * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 1996 Sun Microsystems, Inc.
+ * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,6 +17,10 @@
#include "tclInt.h"
+MODULE_SCOPE char *tclEmptyStringRep;
+
+char *tclEmptyStringRep = &tclEmptyString;
+
/*
* Each invocation of the "package ifneeded" command creates a structure of
* the following type, which is used to load the package into the interpreter
@@ -28,10 +32,24 @@ typedef struct PkgAvail {
char *script; /* Script to invoke to provide this version of
* the package. Malloc'ed and protected by
* Tcl_Preserve and Tcl_Release. */
+ char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being
+ * initialized. */
+ char name[TCLFLEXARRAY];
+} PkgName;
+
+typedef struct PkgFiles {
+ PkgName *names; /* Package names being initialized. Must be
+ * first field. */
+ Tcl_HashTable table; /* Table which contains files for each
+ * package. */
+} PkgFiles;
+
/*
* For each package that is known in any way to an interpreter, there is one
* record of the following type. These records are stored in the
@@ -47,7 +65,7 @@ typedef struct Package {
} Package;
typedef struct Require {
- void * clientDataPtr;
+ void *clientDataPtr;
const char *name;
Package *pkgPtr;
char *versionToProvide;
@@ -93,10 +111,10 @@ static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int
*/
#define DupBlock(v,s,len) \
- ((v) = ckalloc(len), memcpy((v),(s),(len)))
+ ((v) = (char *)ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
- unsigned local__len = (unsigned) (strlen(s) + 1); \
+ size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
@@ -174,7 +192,7 @@ Tcl_PkgProvideEx(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"conflicting versions provided for package \"%s\": %s, then %s",
name, Tcl_GetString(pkgPtr->version), version));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (void *)NULL);
return TCL_ERROR;
}
@@ -205,6 +223,78 @@ Tcl_PkgProvideEx(
*----------------------------------------------------------------------
*/
+static void
+PkgFilesCleanupProc(
+ ClientData clientData,
+ TCL_UNUSED(Tcl_Interp *))
+{
+ PkgFiles *pkgFiles = (PkgFiles *) clientData;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *entry;
+
+ while (pkgFiles->names) {
+ PkgName *name = pkgFiles->names;
+
+ pkgFiles->names = name->nextPtr;
+ ckfree(name);
+ }
+ entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
+ while (entry) {
+ Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
+
+ Tcl_DecrRefCount(obj);
+ entry = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&pkgFiles->table);
+ ckfree(pkgFiles);
+ return;
+}
+
+void *
+TclInitPkgFiles(
+ Tcl_Interp *interp)
+{
+ /*
+ * If assocdata "tclPkgFiles" doesn't exist yet, create it.
+ */
+
+ PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+
+ if (!pkgFiles) {
+ pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles));
+ pkgFiles->names = NULL;
+ Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
+ }
+ return pkgFiles;
+}
+
+void
+TclPkgFileSeen(
+ Tcl_Interp *interp,
+ const char *fileName)
+{
+ PkgFiles *pkgFiles = (PkgFiles *)
+ Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+
+ if (pkgFiles && pkgFiles->names) {
+ const char *name = pkgFiles->names->name;
+ Tcl_HashTable *table = &pkgFiles->table;
+ int isNew;
+ Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew);
+ Tcl_Obj *list;
+
+ if (isNew) {
+ TclNewObj(list);
+ Tcl_SetHashValue(entry, list);
+ Tcl_IncrRefCount(list);
+ } else {
+ list = (Tcl_Obj *)Tcl_GetHashValue(entry);
+ }
+ Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
+ }
+}
+
#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
@@ -274,12 +364,12 @@ Tcl_PkgRequireEx(
*
* Second, how does this work? If we reach this point, then the global
* variable tclEmptyStringRep has the value NULL. Compare that with
- * the definition of tclEmptyStringRep near the top of the file
- * generic/tclObj.c. It clearly should not have the value NULL; it
- * should point to the char tclEmptyString. If we see it having the
- * value NULL, then somehow we are seeing a Tcl library that isn't
- * completely initialized, and that's an indicator for the error
- * condition described above. (Further explanation is welcome.)
+ * the definition of tclEmptyStringRep near the top of this file. It
+ * clearly should not have the value NULL; it should point to the char
+ * tclEmptyString. If we see it having the value NULL, then somehow we
+ * are seeing a Tcl library that isn't completely initialized, and
+ * that's an indicator for the error condition described above.
+ * (Further explanation is welcome.)
*
* Third, so what do we do about it? This situation indicates the
* package we just loaded wasn't properly compiled to be stub-enabled,
@@ -291,22 +381,15 @@ Tcl_PkgRequireEx(
* After all, two Tcl libraries can't be a good thing!)
*
* Trouble is that's going to be tricky. We're now using a Tcl library
- * that's not fully initialized. In particular, it doesn't have a
- * proper value for tclEmptyStringRep. The Tcl_Obj system heavily
- * depends on the value of tclEmptyStringRep and all of Tcl depends
- * (increasingly) on the Tcl_Obj system, we need to correct that flaw
- * before making the calls to set the interpreter result to the error
- * message. That's the only flaw corrected; other problems with
- * initialization of the Tcl library are not remedied, so be very
- * careful about adding any other calls here without checking how they
- * behave when initialization is incomplete.
+ * that's not fully initialized. Functions in it may not work
+ * reliably, so be very careful about adding any other calls here
+ * without checking how they behave when initialization is incomplete.
*/
- tclEmptyStringRep = &tclEmptyString;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Cannot load package \"%s\" in standalone executable:"
" This package is not compiled with stub support", name));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (void *)NULL);
return NULL;
}
@@ -326,7 +409,7 @@ Tcl_PkgRequireEx(
}
ov = Tcl_NewStringObj(version, -1);
if (exact) {
- Tcl_AppendStringsToObj(ov, "-", version, NULL);
+ Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL);
}
Tcl_IncrRefCount(ov);
if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
@@ -350,9 +433,11 @@ Tcl_PkgRequireProc(
void *clientDataPtr)
{
RequireProcArgs args;
+
args.name = name;
args.clientDataPtr = clientDataPtr;
- return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv);
+ return Tcl_NRCallObjProc(interp,
+ TclNRPkgRequireProc, (void *) &args, reqc, reqv);
}
static int
@@ -360,83 +445,121 @@ TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
- Tcl_Obj *const reqv[]) {
- RequireProcArgs *args = clientData;
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr);
+ Tcl_Obj *const reqv[])
+{
+ RequireProcArgs *args = (RequireProcArgs *)clientData;
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
+ args->clientDataPtr);
return TCL_OK;
}
static int
-PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result)
+PkgRequireCore(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
{
- const char *name = data[0];
+ const char *name = (const char *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj *const *reqv = data[2];
+ Tcl_Obj **reqv = (Tcl_Obj **)data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
+
if (code != TCL_OK) {
return code;
}
- reqPtr = ckalloc(sizeof(Require));
+ reqPtr = (Require *)ckalloc(sizeof(Require));
Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
reqPtr->clientDataPtr = data[3];
reqPtr->name = name;
reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
- Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1);
+ Tcl_NRAddCallback(interp,
+ SelectPackage, reqPtr, INT2PTR(reqc), reqv,
+ (void *)PkgRequireCoreStep1);
} else {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL);
}
return TCL_OK;
}
static int
-PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) {
+PkgRequireCoreStep1(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
Tcl_DString command;
char *script;
- Require *reqPtr = data[0];
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name /* Name of desired package. */;
- if (reqPtr->pkgPtr->version == NULL) {
- /*
- * The package is not in the database. If there is a "package unknown"
- * command, invoke it.
- */
- script = ((Interp *) interp)->packageUnknown;
- if (script == NULL) {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
- } else {
- Tcl_DStringInit(&command);
- Tcl_DStringAppend(&command, script, -1);
- Tcl_DStringAppendElement(&command, name);
- AddRequirementsToDString(&command, reqc, reqv);
-
- Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
- Tcl_NREvalObj(interp,
- Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)),
- TCL_EVAL_GLOBAL
- );
- Tcl_DStringFree(&command);
- }
- return TCL_OK;
- } else {
- Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ /*
+ * If we've got the package in the DB already, go on to actually loading
+ * it.
+ */
+
+ if (reqPtr->pkgPtr->version != NULL) {
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ return TCL_OK;
}
+
+ /*
+ * The package is not in the database. If there is a "package unknown"
+ * command, invoke it.
+ */
+
+ script = ((Interp *) interp)->packageUnknown;
+ if (script == NULL) {
+ /*
+ * No package unknown script. Move on to finalizing.
+ */
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ return TCL_OK;
+ }
+
+ /*
+ * Invoke the "package unknown" script synchronously.
+ */
+
+ Tcl_DStringInit(&command);
+ Tcl_DStringAppend(&command, script, -1);
+ Tcl_DStringAppendElement(&command, name);
+ AddRequirementsToDString(&command, reqc, reqv);
+
+ Tcl_NRAddCallback(interp,
+ PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
+ Tcl_NREvalObj(interp,
+ Tcl_NewStringObj(Tcl_DStringValue(&command),
+ Tcl_DStringLength(&command)),
+ TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&command);
return TCL_OK;
}
static int
-PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+PkgRequireCoreStep2(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
- const char *name = reqPtr->name /* Name of desired package. */;
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
+ const char *name = reqPtr->name; /* Name of desired package. */
+
if ((result != TCL_OK) && (result != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", result));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
@@ -445,24 +568,35 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
return result;
}
Tcl_ResetResult(interp);
- /* pkgPtr may now be invalid, so refresh it. */
+
+ /*
+ * pkgPtr may now be invalid, so refresh it.
+ */
+
reqPtr->pkgPtr = FindPackage(interp, name);
- Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal);
+ Tcl_NRAddCallback(interp,
+ SelectPackage, reqPtr, INT2PTR(reqc), reqv,
+ (void *)PkgRequireCoreFinal);
return TCL_OK;
}
static int
-PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+PkgRequireCoreFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]), satisfies;
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
- const char *name = reqPtr->name /* Name of desired package. */;
+ const char *name = reqPtr->name; /* Name of desired package. */
+
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (void *)NULL);
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
}
@@ -483,7 +617,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
"version conflict for package \"%s\": have %s, need",
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
- NULL);
+ (void *)NULL);
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
}
@@ -499,21 +633,28 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
}
static int
-PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+PkgRequireCoreCleanup(
+ ClientData data[],
+ TCL_UNUSED(Tcl_Interp *),
+ int result)
+{
ckfree(data[0]);
return result;
}
-
static int
-SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
+SelectPackage(
+ ClientData data[],
+ Tcl_Interp *interp,
+ TCL_UNUSED(int))
+{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
- Require *reqPtr = data[0];
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
@@ -529,15 +670,15 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
" attempt to provide %s %s requires %s",
name, (char *) pkgPtr->clientData, name));
AddRequirementsToResult(interp, reqc, reqv);
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (void *)NULL);
return TCL_ERROR;
}
/*
- * The package isn't yet present. Search the list of available
- * versions and invoke the script for the best available version. We
- * are actually locating the best, and the best stable version. One of
- * them is then chosen based on the selection mode.
+ * The package isn't yet present. Search the list of available versions
+ * and invoke the script for the best available version. We are actually
+ * locating the best, and the best stable version. One of them is then
+ * chosen based on the selection mode.
*/
bestPtr = NULL;
@@ -550,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
if (CheckVersionAndConvert(interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/*
- * The provided version number has invalid syntax. This
- * should not happen. This should have been caught by the
- * 'package ifneeded' registering the package.
+ * The provided version number has invalid syntax. This should not
+ * happen. This should have been caught by the 'package ifneeded'
+ * registering the package.
*/
continue;
}
- /* Check satisfaction of requirements before considering the current version further. */
+ /*
+ * Check satisfaction of requirements before considering the current
+ * version further.
+ */
+
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
@@ -580,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
* The version of the package sought is better than the
* currently selected version.
*/
+
ckfree(bestVersion);
bestVersion = NULL;
goto newbest;
}
} else {
newbest:
- /* We have found a version which is better than our max. */
+ /*
+ * We have found a version which is better than our max.
+ */
bestPtr = availPtr;
CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
@@ -607,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
if (res > 0) {
/*
- * This stable version of the package sought is better
- * than the currently selected stable version.
+ * This stable version of the package sought is better than
+ * the currently selected stable version.
*/
+
ckfree(bestStableVersion);
bestStableVersion = NULL;
goto newstable;
}
} else {
newstable:
- /* We have found a stable version which is better than our max stable. */
+ /*
+ * We have found a stable version which is better than our max
+ * stable.
+ */
+
bestStablePtr = availPtr;
- CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
+ CheckVersionAndConvert(interp, bestStablePtr->version,
+ &bestStableVersion, NULL);
}
ckfree(availVersion);
@@ -640,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
/*
- * Now choose a version among the two best. For 'latest' we simply
- * take (actually keep) the best. For 'stable' we take the best
- * stable, if there is any, or the best if there is nothing stable.
+ * Now choose a version among the two best. For 'latest' we simply take
+ * (actually keep) the best. For 'stable' we take the best stable, if
+ * there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
@@ -651,34 +805,67 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
}
if (bestPtr == NULL) {
- Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
} else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
- * script itself from deletion and (b) don't assume that bestPtr
- * will still exist when the script completes.
+ * script itself from deletion and (b) don't assume that bestPtr will
+ * still exist when the script completes.
*/
char *versionToProvide = bestPtr->version;
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
- pkgPtr->clientData = versionToProvide;
Tcl_Preserve(versionToProvide);
+ pkgPtr->clientData = versionToProvide;
+
+ pkgFiles = (PkgFiles *)TclInitPkgFiles(interp);
+
+ /*
+ * Push "ifneeded" package name in "tclPkgFiles" assocdata.
+ */
+
+ pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name));
+ pkgName->nextPtr = pkgFiles->names;
+ strcpy(pkgName->name, name);
+ pkgFiles->names = pkgName;
+ if (bestPtr->pkgIndex) {
+ TclPkgFileSeen(interp, bestPtr->pkgIndex);
+ }
reqPtr->versionToProvide = versionToProvide;
- Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]);
- Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL);
+ Tcl_NRAddCallback(interp,
+ SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv,
+ data[3]);
+ Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1),
+ TCL_EVAL_GLOBAL);
}
return TCL_OK;
}
static int
-SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
- Require *reqPtr = data[0];
+SelectPackageFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
- Tcl_Obj **const reqv = data[2];
+ Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
+ /*
+ * Pop the "ifneeded" package name from "tclPkgFiles" assocdata
+ */
+
+ PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ PkgName *pkgName = pkgFiles->names;
+ pkgFiles->names = pkgName->nextPtr;
+ ckfree(pkgName);
+
reqPtr->pkgPtr = FindPackage(interp, name);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
@@ -689,7 +876,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
" no version of package %s provided",
name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
- NULL);
+ (void *)NULL);
} else {
char *pvi, *vi;
@@ -713,7 +900,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
name, versionToProvide,
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
- "WRONGPROVIDE", NULL);
+ "WRONGPROVIDE", (void *)NULL);
}
}
}
@@ -725,7 +912,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
"attempt to provide package %s %s failed:"
" bad return code: %s",
name, versionToProvide, TclGetString(codePtr)));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL);
TclDecrRefCount(codePtr);
result = TCL_ERROR;
}
@@ -739,14 +926,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
if (result != TCL_OK) {
/*
- * Take a non-TCL_OK code from the script as an indication the
- * package wasn't loaded properly, so the package system
- * should not remember an improper load.
+ * Take a non-TCL_OK code from the script as an indication the package
+ * wasn't loaded properly, so the package system should not remember
+ * an improper load.
*
- * This is consistent with our returning NULL. If we're not
- * willing to tell our caller we got a particular version, we
- * shouldn't store that version for telling future callers
- * either.
+ * This is consistent with our returning NULL. If we're not willing to
+ * tell our caller we got a particular version, we shouldn't store
+ * that version for telling future callers either.
*/
if (reqPtr->pkgPtr->version != NULL) {
@@ -757,7 +943,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
return result;
}
- Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NRAddCallback(interp,
+ (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
@@ -818,7 +1005,7 @@ Tcl_PkgPresentEx(
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
/*
* At this point we know that the package is present. Make sure
@@ -831,7 +1018,7 @@ Tcl_PkgPresentEx(
if (foundVersion == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
- NULL);
+ (void *)NULL);
}
return foundVersion;
}
@@ -844,7 +1031,7 @@ Tcl_PkgPresentEx(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"package %s is not present", name));
}
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (void *)NULL);
return NULL;
}
@@ -866,31 +1053,30 @@ Tcl_PkgPresentEx(
*/
int
Tcl_PackageObjCmd(
- ClientData dummy, /* Not used. */
+ ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv);
+ return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
- /* ARGSUSED */
int
TclNRPackageObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
- "forget", "ifneeded", "names", "prefer", "present",
- "provide", "require", "unknown", "vcompare", "versions",
- "vsatisfies", NULL
+ "files", "forget", "ifneeded", "names", "prefer",
+ "present", "provide", "require", "unknown", "vcompare",
+ "versions", "vsatisfies", NULL
};
- enum pkgOptions {
- PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT,
- PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
- PKG_VSATISFIES
+ 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
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, newobjc, satisfies;
@@ -913,17 +1099,45 @@ TclNRPackageObjCmd(
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum pkgOptions) optionIndex) {
+ switch ((enum pkgOptionsEnum) optionIndex) {
+ case PKG_FILES: {
+ PkgFiles *pkgFiles;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package");
+ return TCL_ERROR;
+ }
+ pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ if (pkgFiles) {
+ Tcl_HashEntry *entry =
+ Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
+ if (entry) {
+ Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
+ }
+ }
+ break;
+ }
case PKG_FORGET: {
const char *keyString;
+ PkgFiles *pkgFiles = (PkgFiles *)
+ Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < 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);
+ }
+ }
+
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
@@ -933,6 +1147,10 @@ TclNRPackageObjCmd(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -958,11 +1176,11 @@ TclNRPackageObjCmd(
ckfree(argv3i);
return TCL_OK;
}
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
- argv3 = Tcl_GetStringFromObj(objv[3], &length);
+ argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
@@ -975,7 +1193,7 @@ TclNRPackageObjCmd(
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
- if (res == 0){
+ if (res == 0) {
if (objc == 4) {
ckfree(argv3i);
Tcl_SetObjResult(interp,
@@ -983,6 +1201,10 @@ TclNRPackageObjCmd(
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
break;
}
}
@@ -992,8 +1214,9 @@ TclNRPackageObjCmd(
return TCL_OK;
}
if (availPtr == NULL) {
- availPtr = ckalloc(sizeof(PkgAvail));
- DupBlock(availPtr->version, argv3, (unsigned) length + 1);
+ availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail));
+ availPtr->pkgIndex = NULL;
+ DupBlock(availPtr->version, argv3, length + 1);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
@@ -1003,8 +1226,12 @@ TclNRPackageObjCmd(
prevPtr->nextPtr = availPtr;
}
}
- argv4 = Tcl_GetStringFromObj(objv[4], &length);
- DupBlock(availPtr->script, argv4, (unsigned) length + 1);
+ if (iPtr->scriptFile) {
+ argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
+ DupBlock(availPtr->pkgIndex, argv4, length + 1);
+ }
+ argv4 = TclGetStringFromObj(objv[4], &length);
+ DupBlock(availPtr->script, argv4, length + 1);
break;
}
case PKG_NAMES:
@@ -1018,10 +1245,10 @@ TclNRPackageObjCmd(
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
- Tcl_GetHashKey(tablePtr, hPtr), -1));
+ (char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, resultObj);
@@ -1047,7 +1274,7 @@ TclNRPackageObjCmd(
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
goto require;
}
@@ -1082,7 +1309,7 @@ TclNRPackageObjCmd(
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp, pkgPtr->version);
}
@@ -1124,7 +1351,7 @@ TclNRPackageObjCmd(
*/
ov = Tcl_NewStringObj(version, -1);
- Tcl_AppendStringsToObj(ov, "-", version, NULL);
+ Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL);
version = NULL;
argv3 = TclGetString(objv[3]);
Tcl_IncrRefCount(objv[3]);
@@ -1132,33 +1359,39 @@ TclNRPackageObjCmd(
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_ListObjAppendElement(interp, objvListPtr, ov);
- TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
+ TclListObjGetElementsM(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL);
+ Tcl_NRAddCallback(interp,
+ TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL);
+ Tcl_NRAddCallback(interp,
+ PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
+ newObjvPtr, NULL);
return TCL_OK;
} else {
Tcl_Obj *const *newobjv = objv + 3;
- newobjc = objc - 3;
- if (CheckAllRequirements(interp, objc - 3, objv + 3) != TCL_OK) {
+ newobjc = objc - 3;
+ if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_IncrRefCount(objv[2]);
for (i = 0; i < newobjc; i++) {
-
/*
* Tcl_Obj structures may have come from another interpreter,
* so duplicate them.
*/
- Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i]));
+ Tcl_ListObjAppendElement(interp, objvListPtr,
+ Tcl_DuplicateObj(newobjv[i]));
}
- TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
- Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
+ 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;
}
break;
@@ -1174,11 +1407,11 @@ TclNRPackageObjCmd(
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
- argv2 = Tcl_GetStringFromObj(objv[2], &length);
+ argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
- DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1);
+ DupBlock(iPtr->packageUnknown, argv2, length+1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
@@ -1248,7 +1481,7 @@ TclNRPackageObjCmd(
*/
Tcl_SetObjResult(interp,
- Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
+ Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL)));
ckfree(iva);
ckfree(ivb);
break;
@@ -1263,7 +1496,7 @@ TclNRPackageObjCmd(
argv2 = TclGetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
@@ -1302,9 +1535,13 @@ TclNRPackageObjCmd(
}
static int
-TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) {
- TclDecrRefCount((Tcl_Obj *)data[0]);
- TclDecrRefCount((Tcl_Obj *)data[1]);
+TclNRPackageObjCmdCleanup(
+ ClientData data[],
+ TCL_UNUSED(Tcl_Interp *),
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
@@ -1338,13 +1575,13 @@ FindPackage(
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
- pkgPtr = ckalloc(sizeof(Package));
+ pkgPtr = (Package *)ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
}
return pkgPtr;
}
@@ -1368,7 +1605,7 @@ FindPackage(
void
TclFreePackageInfo(
- Interp *iPtr) /* Interpereter that is being deleted. */
+ Interp *iPtr) /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
@@ -1377,7 +1614,7 @@ TclFreePackageInfo(
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- pkgPtr = Tcl_GetHashValue(hPtr);
+ pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
@@ -1386,6 +1623,10 @@ TclFreePackageInfo(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -1432,7 +1673,7 @@ CheckVersionAndConvert(
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
- char *ibuf = ckalloc(4 + 4*strlen(string));
+ char *ibuf = (char *)ckalloc(4 + 4*strlen(string));
char *ip = ibuf;
/*
@@ -1455,7 +1696,7 @@ CheckVersionAndConvert(
*ip++ = *p;
- for (prevChar = *p, p++; *p != 0; p++) {
+ for (prevChar = *p, p++; (*p != 0) && (*p != '+'); p++) {
if (!isdigit(UCHAR(*p)) && /* INTL: digit */
((*p!='.' && *p!='a' && *p!='b') ||
((hasunstable && (*p=='a' || *p=='b')) ||
@@ -1512,7 +1753,7 @@ CheckVersionAndConvert(
ckfree(ibuf);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected version number but got \"%s\"", string));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (void *)NULL);
return TCL_ERROR;
}
@@ -1759,10 +2000,10 @@ CheckRequirement(
char *dash = NULL, *buf;
- dash = strchr(string, '-');
+ dash = strchr(string, '+') ? NULL : (char *)strchr(string, '-');
if (dash == NULL) {
/*
- * No dash found, has to be a simple version.
+ * '+' found or no dash found: has to be a simple version.
*/
return CheckVersionAndConvert(interp, string, NULL, NULL);
@@ -1775,7 +2016,7 @@ CheckRequirement(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected versionMin-versionMax but got \"%s\"", string));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (void *)NULL);
return TCL_ERROR;
}
@@ -1830,7 +2071,7 @@ AddRequirementsToResult(
int i, length;
for (i = 0; i < reqc; i++) {
- const char *v = Tcl_GetStringFromObj(reqv[i], &length);
+ const char *v = TclGetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
@@ -1947,7 +2188,7 @@ RequirementSatisfied(
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
- dash = strchr(req, '-');
+ dash = (char *)strchr(req, '-');
if (dash == NULL) {
/*
* No dash found, is a simple version, fallback to regular check. The
@@ -2043,7 +2284,7 @@ Tcl_PkgInitStubsCheck(
{
const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
- if (exact && actualVersion) {
+ if ((exact&1) && actualVersion) {
const char *p = version;
int count = 0;
diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c
index 727e872..a0dae51 100644
--- a/generic/tclPkgConfig.c
+++ b/generic/tclPkgConfig.c
@@ -2,9 +2,9 @@
* tclPkgConfig.c --
*
* This file contains the configuration information to embed into the tcl
- * binary library.
+ * library.
*
- * Copyright (c) 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+ * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -36,11 +36,7 @@
#include "tclInt.h"
#ifndef TCL_CFGVAL_ENCODING
-# ifdef _WIN32
-# define TCL_CFGVAL_ENCODING "cp1252"
-# else
-# define TCL_CFGVAL_ENCODING "iso8859-1"
-# endif
+# define TCL_CFGVAL_ENCODING "utf-8"
#endif
/*
@@ -48,7 +44,7 @@
* configuration information.
*/
-#ifdef TCL_THREADS
+#if TCL_THREADS
# define CFG_THREADED "1"
#else
# define CFG_THREADED "0"
@@ -97,6 +93,7 @@
#endif
static Tcl_Config const cfg[] = {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"debug", CFG_DEBUG},
{"threaded", CFG_THREADED},
{"profiled", CFG_PROFILED},
@@ -105,6 +102,7 @@ static Tcl_Config const cfg[] = {
{"mem_debug", CFG_MEMDEBUG},
{"compile_debug", CFG_COMPILE_DEBUG},
{"compile_stats", CFG_COMPILE_STATS},
+#endif
/* Runtime paths to various stuff */
@@ -113,6 +111,9 @@ static Tcl_Config const cfg[] = {
{"scriptdir,runtime", CFG_RUNTIME_SCRDIR},
{"includedir,runtime", CFG_RUNTIME_INCDIR},
{"docdir,runtime", CFG_RUNTIME_DOCDIR},
+#if !defined(STATIC_BUILD)
+ {"dllfile,runtime", CFG_RUNTIME_DLLFILE},
+#endif
/* Installation paths to various stuff */
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 46181a1..8d1eee1 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -40,6 +40,14 @@
# define _TCHAR_DEFINED
#endif
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
@@ -59,21 +67,21 @@ EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
Tcl_DString *dsPtr);
/* Slot 2 is reserved */
/* 3 */
-EXTERN void TclWinConvertError_(unsigned errCode);
+EXTERN void Tcl_WinConvertError(unsigned errCode);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
- int maxPathLen, char *libraryPath);
+ Tcl_Size maxPathLen, char *libraryPath);
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
- int hasResourceFile, int maxPathLen,
+ int hasResourceFile, Tcl_Size maxPathLen,
char *libraryPath);
/* 2 */
-EXTERN void TclMacOSXNotifierAddRunLoopMode_(
+EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
#endif /* MACOSX */
@@ -85,12 +93,12 @@ typedef struct TclPlatStubs {
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
void (*reserved2)(void);
- void (*tclWinConvertError_) (unsigned errCode); /* 3 */
+ void (*tcl_WinConvertError) (unsigned errCode); /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
- int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
- void (*tclMacOSXNotifierAddRunLoopMode_) (const void *runLoopMode); /* 2 */
+ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 0 */
+ int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */
+ void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */
#endif /* MACOSX */
} TclPlatStubs;
@@ -112,25 +120,22 @@ extern const TclPlatStubs *tclPlatStubsPtr;
#define Tcl_WinTCharToUtf \
(tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
/* Slot 2 is reserved */
-#define TclWinConvertError_ \
- (tclPlatStubsPtr->tclWinConvertError_) /* 3 */
+#define Tcl_WinConvertError \
+ (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
#define Tcl_MacOSXOpenBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#define Tcl_MacOSXOpenVersionedBundleResources \
(tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#define TclMacOSXNotifierAddRunLoopMode_ \
- (tclPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode_) /* 2 */
+#define Tcl_MacOSXNotifierAddRunLoopMode \
+ (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */
#endif /* MACOSX */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
-#undef TclUnusedStubEntry
-#undef TclMacOSXNotifierAddRunLoopMode_
-#undef TclWinConvertError_
#ifdef MAC_OSX_TCL /* MACOSX */
#undef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e)
@@ -139,6 +144,16 @@ extern const TclPlatStubs *tclPlatStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-#endif /* _TCLPLATDECLS */
-
+#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\
+ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)
+#undef Tcl_WinUtfToTChar
+#undef Tcl_WinTCharToUtf
+#ifdef _WIN32
+#define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
+#define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+#endif
+#endif
+#endif /* _TCLPLATDECLS */
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 9485567..d3f6233 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -24,21 +24,6 @@
#endif
#include "tcl.h"
-#if !defined(LLONG_MIN)
-# ifdef TCL_WIDE_INT_IS_LONG
-# define LLONG_MIN LONG_MIN
-# else
-# ifdef LLONG_BIT
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1)))
-# else
-/* Assume we're on a system with a 64-bit 'long long' type */
-# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63))
-# endif
-# endif
-/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */
-# define LLONG_MAX (~LLONG_MIN)
-#endif
-
#define UWIDE_MAX ((Tcl_WideUInt)-1)
#define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1))
#define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1))
diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index 6a30e0e..52d5f09 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -4,8 +4,8 @@
* This file contains procedures that generate strings corresponding to
* various POSIX-related codes, such as errno and signals.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 1994-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -62,6 +62,9 @@ Tcl_ErrnoId(void)
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY))
case EALREADY: return "EALREADY";
#endif
+#ifdef EBADCAT
+ case EBADCAT: return "EBADCAT";
+#endif
#ifdef EBADE
case EBADE: return "EBADE";
#endif
@@ -143,6 +146,9 @@ Tcl_ErrnoId(void)
#ifdef EEXIST
case EEXIST: return "EEXIST";
#endif
+#ifdef EFAIL
+ case EFAIL: return "EFAIL";
+#endif
#ifdef EFAULT
case EFAULT: return "EFAULT";
#endif
@@ -167,6 +173,9 @@ Tcl_ErrnoId(void)
#ifdef EILSEQ
case EILSEQ: return "EILSEQ";
#endif
+#ifdef EINPROG
+ case EINPROG: return "EINPROG";
+#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "EINPROGRESS";
#endif
@@ -245,9 +254,6 @@ Tcl_ErrnoId(void)
#ifdef ENAVAIL
case ENAVAIL: return "ENAVAIL";
#endif
-#ifdef ENET
- case ENET: return "ENET";
-#endif
#ifdef ENETDOWN
case ENETDOWN: return "ENETDOWN";
#endif
@@ -356,6 +362,9 @@ Tcl_ErrnoId(void)
#ifdef ENOTUNIQ
case ENOTUNIQ: return "ENOTUNIQ";
#endif
+#ifdef ENWAIT
+ case ENWAIT: return "ENWAIT";
+#endif
#ifdef ENXIO
case ENXIO: return "ENXIO";
#endif
@@ -540,31 +549,34 @@ Tcl_ErrnoMsg(
case EAGAIN: return "resource temporarily unavailable";
#endif
#ifdef EALIGN
- case EALIGN: return "EALIGN";
+ case EALIGN: return "alignment error";
#endif
#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY))
case EALREADY: return "operation already in progress";
#endif
+#ifdef EBADCAT
+ case EBADCAT: return "bad message catalogue format";
+#endif
#ifdef EBADE
- case EBADE: return "bad exchange descriptor";
+ case EBADE: return "invalid exchange";
#endif
#ifdef EBADF
- case EBADF: return "bad file number";
+ case EBADF: return "bad file descriptor";
#endif
#ifdef EBADFD
case EBADFD: return "file descriptor in bad state";
#endif
#ifdef EBADMSG
- case EBADMSG: return "not a data message";
+ case EBADMSG: return "bad message";
#endif
#ifdef EBADR
- case EBADR: return "bad request descriptor";
+ case EBADR: return "invalid request descriptor";
#endif
#ifdef EBADRPC
case EBADRPC: return "RPC structure is bad";
#endif
#ifdef EBADRQC
- case EBADRQC: return "bad request code";
+ case EBADRQC: return "invalid request code";
#endif
#ifdef EBADSLT
case EBADSLT: return "invalid slot";
@@ -573,7 +585,7 @@ Tcl_ErrnoMsg(
case EBFONT: return "bad font file format";
#endif
#ifdef EBUSY
- case EBUSY: return "file busy";
+ case EBUSY: return "device or resource busy";
#endif
#ifdef ECANCELED
case ECANCELED: return "operation canceled";
@@ -582,7 +594,7 @@ Tcl_ErrnoMsg(
case ECASECLASH: return "filename exists with different case";
#endif
#ifdef ECHILD
- case ECHILD: return "no children";
+ case ECHILD: return "no child processes";
#endif
#ifdef ECHRNG
case ECHRNG: return "channel number out of range";
@@ -612,7 +624,7 @@ Tcl_ErrnoMsg(
case EDIRTY: return "mounting a dirty fs w/o force";
#endif
#ifdef EDOM
- case EDOM: return "math argument out of range";
+ case EDOM: return "numerical argument out of domain";
#endif
#ifdef EDOTDOT
case EDOTDOT: return "cross mount point";
@@ -624,10 +636,13 @@ Tcl_ErrnoMsg(
case EDUPPKG: return "duplicate package name";
#endif
#ifdef EEXIST
- case EEXIST: return "file already exists";
+ case EEXIST: return "file exists";
+#endif
+#ifdef EFAIL
+ case EFAIL: return "cannot start operation";
#endif
#ifdef EFAULT
- case EFAULT: return "bad address in system call argument";
+ case EFAULT: return "bad address";
#endif
#ifdef EFBIG
case EFBIG: return "file too large";
@@ -639,7 +654,7 @@ Tcl_ErrnoMsg(
case EHOSTDOWN: return "host is down";
#endif
#ifdef EHOSTUNREACH
- case EHOSTUNREACH: return "host is unreachable";
+ case EHOSTUNREACH: return "no route to host";
#endif
#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS))
case EIDRM: return "identifier removed";
@@ -648,7 +663,10 @@ Tcl_ErrnoMsg(
case EINIT: return "initialization error";
#endif
#ifdef EILSEQ
- case EILSEQ: return "illegal byte sequence";
+ case EILSEQ: return "invalid or incomplete multibyte or wide character";
+#endif
+#ifdef EINPROG
+ case EINPROG: return "asynchronous operation in progress";
#endif
#ifdef EINPROGRESS
case EINPROGRESS: return "operation now in progress";
@@ -660,16 +678,16 @@ Tcl_ErrnoMsg(
case EINVAL: return "invalid argument";
#endif
#ifdef EIO
- case EIO: return "I/O error";
+ case EIO: return "input/output error";
#endif
#ifdef EISCONN
- case EISCONN: return "socket is already connected";
+ case EISCONN: return "transport endpoint is already connected";
#endif
#ifdef EISDIR
- case EISDIR: return "illegal operation on a directory";
+ case EISDIR: return "is a directory";
#endif
#ifdef EISNAM
- case EISNAM: return "is a name file";
+ case EISNAM: return "is a named type file";
#endif
#ifdef EL2HLT
case EL2HLT: return "level 2 halted";
@@ -687,7 +705,7 @@ Tcl_ErrnoMsg(
case ELBIN: return "inode is remote";
#endif
#ifdef ELIBACC
- case ELIBACC: return "cannot access a needed shared library";
+ case ELIBACC: return "can not access a needed shared library";
#endif
#ifdef ELIBBAD
case ELIBBAD: return "accessing a corrupted shared library";
@@ -697,7 +715,7 @@ Tcl_ErrnoMsg(
#endif
#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED))
case ELIBMAX: return
- "attempting to link in more shared libraries than system limit";
+ "attempting to link in too many shared libraries";
#endif
#ifdef ELIBSCN
case ELIBSCN: return ".lib section in a.out corrupted";
@@ -729,9 +747,6 @@ Tcl_ErrnoMsg(
#ifdef ENAVAIL
case ENAVAIL: return "not available";
#endif
-#ifdef ENET
- case ENET: return "ENET";
-#endif
#ifdef ENETDOWN
case ENETDOWN: return "network is down";
#endif
@@ -742,13 +757,13 @@ Tcl_ErrnoMsg(
case ENETUNREACH: return "network is unreachable";
#endif
#ifdef ENFILE
- case ENFILE: return "file table overflow";
+ case ENFILE: return "too many open files in system";
#endif
#ifdef ENMFILE
case ENMFILE: return "no more files";
#endif
#ifdef ENOANO
- case ENOANO: return "anode table overflow";
+ case ENOANO: return "no anode";
#endif
#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
case ENOBUFS: return "no buffer space available";
@@ -775,7 +790,7 @@ Tcl_ErrnoMsg(
case ENOLINK: return "link has been severed";
#endif
#ifdef ENOMEM
- case ENOMEM: return "not enough memory";
+ case ENOMEM: return "cannot allocate memory";
#endif
#ifdef ENOMEDIUM
case ENOMEDIUM: return "no medium found";
@@ -790,7 +805,7 @@ Tcl_ErrnoMsg(
case ENOPKG: return "package not installed";
#endif
#ifdef ENOPROTOOPT
- case ENOPROTOOPT: return "bad protocol option";
+ case ENOPROTOOPT: return "protocol not available";
#endif
#ifdef ENOSHARE
case ENOSHARE: return "no such host or network path";
@@ -799,10 +814,10 @@ Tcl_ErrnoMsg(
case ENOSPC: return "no space left on device";
#endif
#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR))
- case ENOSR: return "out of stream resources";
+ case ENOSR: return "out of streams resources";
#endif
#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR))
- case ENOSTR: return "not a stream device";
+ case ENOSTR: return "device not a stream";
#endif
#ifdef ENOSYM
case ENOSYM: return "unresolved symbol name";
@@ -814,7 +829,7 @@ Tcl_ErrnoMsg(
case ENOTBLK: return "block device required";
#endif
#ifdef ENOTCONN
- case ENOTCONN: return "socket is not connected";
+ case ENOTCONN: return "transport endpoint is not connected";
#endif
#ifdef ENOTDIR
case ENOTDIR: return "not a directory";
@@ -835,11 +850,14 @@ Tcl_ErrnoMsg(
case ENOTSUP: return "operation not supported";
#endif
#ifdef ENOTTY
- case ENOTTY: return "inappropriate device for ioctl";
+ case ENOTTY: return "inappropriate ioctl for device";
#endif
#ifdef ENOTUNIQ
case ENOTUNIQ: return "name not unique on network";
#endif
+#ifdef ENWAIT
+ case ENWAIT: return "No waiting processes";
+#endif
#ifdef ENXIO
case ENXIO: return "no such device or address";
#endif
@@ -850,13 +868,13 @@ Tcl_ErrnoMsg(
case EOTHER: return "other error";
#endif
#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL))
- case EOVERFLOW: return "file too big";
+ case EOVERFLOW: return "value too large for defined data type";
#endif
#ifdef EOWNERDEAD
case EOWNERDEAD: return "owner died";
#endif
#ifdef EPERM
- case EPERM: return "not owner";
+ case EPERM: return "operation not permitted";
#endif
#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT))
case EPFNOSUPPORT: return "protocol family not supported";
@@ -886,7 +904,7 @@ Tcl_ErrnoMsg(
case EPROTOTYPE: return "protocol wrong type for socket";
#endif
#ifdef ERANGE
- case ERANGE: return "math result unrepresentable";
+ case ERANGE: return "numerical result out of range";
#endif
#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
case EREFUSED: return "connection refused";
@@ -898,10 +916,10 @@ Tcl_ErrnoMsg(
case EREMDEV: return "remote device";
#endif
#ifdef EREMOTE
- case EREMOTE: return "pathname hit remote file system";
+ case EREMOTE: return "object is remote";
#endif
#ifdef EREMOTEIO
- case EREMOTEIO: return "remote i/o error";
+ case EREMOTEIO: return "remote I/O error";
#endif
#ifdef EREMOTERELEASE
case EREMOTERELEASE: return "remote peer released connection";
@@ -919,13 +937,13 @@ Tcl_ErrnoMsg(
case ERREMOTE: return "object is remote";
#endif
#ifdef ESHUTDOWN
- case ESHUTDOWN: return "cannot send after socket shutdown";
+ case ESHUTDOWN: return "cannot send after transport endpoint shutdown";
#endif
#ifdef ESOCKTNOSUPPORT
case ESOCKTNOSUPPORT: return "socket type not supported";
#endif
#ifdef ESPIPE
- case ESPIPE: return "invalid seek";
+ case ESPIPE: return "illegal seek";
#endif
#ifdef ESRCH
case ESRCH: return "no such process";
@@ -934,13 +952,13 @@ Tcl_ErrnoMsg(
case ESRMNT: return "srmount error";
#endif
#ifdef ESTALE
- case ESTALE: return "stale remote file handle";
+ case ESTALE: return "stale file handle";
#endif
#ifdef ESTRPIPE
case ESTRPIPE: return "streams pipe error";
#endif
#ifdef ESUCCESS
- case ESUCCESS: return "Error 0";
+ case ESUCCESS: return "success";
#endif
#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP))
case ETIME: return "timer expired";
@@ -952,7 +970,7 @@ Tcl_ErrnoMsg(
case ETOOMANYREFS: return "too many references: cannot splice";
#endif
#ifdef ETXTBSY
- case ETXTBSY: return "text file or pseudo-device busy";
+ case ETXTBSY: return "text file busy";
#endif
#ifdef EUCLEAN
case EUCLEAN: return "structure needs cleaning";
@@ -970,10 +988,10 @@ Tcl_ErrnoMsg(
case EWOULDBLOCK: return "operation would block";
#endif
#ifdef EXDEV
- case EXDEV: return "cross-domain link";
+ case EXDEV: return "invalid cross-device link";
#endif
#ifdef EXFULL
- case EXFULL: return "message tables full";
+ case EXFULL: return "exchange full";
#endif
default:
#ifdef NO_STRERROR
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index cca13e8..b32dd63 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -5,8 +5,8 @@
* sure that widget records and other data structures aren't reallocated
* when there are nested functions that depend on their existence.
*
- * Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 1991-1994 The Regents of the University of California.
+ * Copyright © 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.
@@ -22,7 +22,7 @@
typedef struct {
ClientData clientData; /* Address of preserved block. */
- int refCount; /* Number of Tcl_Preserve calls in effect for
+ size_t refCount; /* Number of Tcl_Preserve calls in effect for
* block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
@@ -63,7 +63,7 @@ typedef struct HandleStruct {
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
- int refCount; /* Number of TclHandlePreserve() calls in
+ size_t refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
@@ -83,7 +83,6 @@ typedef struct HandleStruct {
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
void
TclFinalizePreserve(void)
{
@@ -144,7 +143,7 @@ Tcl_Preserve(
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
- refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference));
+ refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference));
}
/*
@@ -155,7 +154,7 @@ Tcl_Preserve(
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
- refPtr->freeProc = TCL_STATIC;
+ refPtr->freeProc = 0;
inUse += 1;
Tcl_MutexUnlock(&preserveMutex);
}
@@ -195,7 +194,7 @@ Tcl_Release(
continue;
}
- if (--refPtr->refCount != 0) {
+ if (refPtr->refCount-- > 1) {
Tcl_MutexUnlock(&preserveMutex);
return;
}
@@ -226,7 +225,7 @@ Tcl_Release(
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
- freeProc(clientData);
+ freeProc((char *)clientData);
}
}
return;
@@ -293,7 +292,7 @@ Tcl_EventuallyFree(
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
- freeProc(clientData);
+ freeProc((char *)clientData);
}
}
@@ -327,7 +326,7 @@ TclHandleCreate(
* be tracked for deletion. Must not be
* NULL. */
{
- HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct));
+ HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
@@ -459,7 +458,7 @@ TclHandleRelease(
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
- if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
+ if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
ckfree(handlePtr);
}
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index bf24c83..adb69ba 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -4,10 +4,10 @@
* This file contains routines that implement Tcl procedures, including
* the "proc" and "uplevel" commands.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2004-2006 Miguel Sofer
- * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2004-2006 Miguel Sofer
+ * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Variables that are part of the [apply] command implementation and which
@@ -33,15 +34,14 @@ typedef struct {
static void DupLambdaInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static void FreeLambdaInternalRep(Tcl_Obj *objPtr);
-static int InitArgsAndLocals(Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int skip);
+static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Size skip);
static void InitResolvedLocals(Tcl_Interp *interp,
ByteCode *codePtr, Var *defPtr,
Namespace *nsPtr);
static void InitLocalCache(Proc *procPtr);
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
-static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
+static int ProcWrongNumArgs(Tcl_Interp *interp, Tcl_Size skip);
static void MakeProcError(Tcl_Interp *interp,
Tcl_Obj *procNameObj);
static void MakeLambdaError(Tcl_Interp *interp,
@@ -67,8 +67,24 @@ const Tcl_ObjType tclProcBodyType = {
* should panic instead. */
};
+#define ProcSetInternalRep(objPtr, procPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (procPtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \
+ } while (0)
+
+#define ProcGetInternalRep(objPtr, procPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
- * The [upvar]/[uplevel] level reference type. Uses the longValue field
+ * The [upvar]/[uplevel] level reference type. Uses the wideValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
@@ -89,13 +105,31 @@ static const Tcl_ObjType levelReferenceType = {
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
-const Tcl_ObjType tclLambdaType = {
+static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny /* setFromAnyProc */
};
+
+#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ ir.twoPtrValue.ptr1 = (procPtr); \
+ ir.twoPtrValue.ptr2 = (nsObjPtr); \
+ Tcl_IncrRefCount((nsObjPtr)); \
+ Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \
+ } while (0)
+
+#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &lambdaType); \
+ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -117,9 +151,9 @@ const Tcl_ObjType tclLambdaType = {
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
@@ -148,14 +182,14 @@ Tcl_ProcObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
procName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL);
return TCL_ERROR;
}
if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
procName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL);
return TCL_ERROR;
}
@@ -163,7 +197,7 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, simpleName, objv[2],
+ if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
objv[3], &procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
Tcl_AddErrorInfo(interp, simpleName);
@@ -232,7 +266,7 @@ Tcl_ProcObjCmd(
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *)ckalloc(sizeof(int));
+ cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -245,7 +279,7 @@ Tcl_ProcObjCmd(
cfPtr->len = 0;
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- (char *)procPtr, &isNew);
+ procPtr, &isNew);
if (!isNew) {
/*
* Get the old command frame and release it. See also
@@ -294,7 +328,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (objv[3]->typePtr == &tclProcBodyType) {
+ if (TclHasInternalRep(objv[3], &tclProcBodyType)) {
goto done;
}
@@ -305,7 +339,7 @@ Tcl_ProcObjCmd(
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
- int numBytes;
+ Tcl_Size numBytes;
procArgs +=4;
while (*procArgs != '\0') {
@@ -319,7 +353,7 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
- procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
+ procBody = TclGetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
@@ -362,7 +396,7 @@ Tcl_ProcObjCmd(
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
- Namespace *nsPtr, /* Namespace containing this proc. */
+ TCL_UNUSED(Namespace *) /*nsPtr*/,
const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
@@ -370,13 +404,14 @@ TclCreateProc(
{
Interp *iPtr = (Interp *) interp;
- Proc *procPtr;
- int i, result, numArgs;
+ Proc *procPtr = NULL;
+ Tcl_Size i, numArgs;
CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
- int precompiled = 0;
+ int precompiled = 0, result;
- if (bodyPtr->typePtr == &tclProcBodyType) {
+ ProcGetInternalRep(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
@@ -389,7 +424,6 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -411,7 +445,7 @@ TclCreateProc(
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
- int length;
+ Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
@@ -451,7 +485,7 @@ TclCreateProc(
* in the Proc.
*/
- result = TclListObjGetElements(interp, argsPtr, &numArgs, &argArray);
+ result = TclListObjGetElementsM(interp, argsPtr, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -459,11 +493,11 @@ TclCreateProc(
if (precompiled) {
if (numArgs > procPtr->numArgs) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": arg list contains %d entries, "
- "precompiled header expects %d", procName, numArgs,
+ "procedure \"%s\": arg list contains %" TCL_SIZE_MODIFIER "u entries, "
+ "precompiled header expects %" TCL_SIZE_MODIFIER "u", procName, numArgs,
procPtr->numArgs));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "BYTECODELIES", NULL);
+ "BYTECODELIES", (void *)NULL);
goto procError;
}
localPtr = procPtr->firstLocalPtr;
@@ -473,15 +507,15 @@ TclCreateProc(
}
for (i = 0; i < numArgs; i++) {
- const char *argname, *p, *last;
- int fieldCount, nameLength;
+ const char *argname, *argnamei, *argnamelast;
+ Tcl_Size fieldCount, nameLength;
Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = TclListObjGetElements(interp, argArray[i], &fieldCount,
+ result = TclListObjGetElementsM(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
@@ -493,44 +527,46 @@ TclCreateProc(
Tcl_AppendToObj(errorObj, "\"", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "FORMALARGUMENTFORMAT", NULL);
+ "FORMALARGUMENTFORMAT", (void *)NULL);
goto procError;
}
- if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
+ if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "FORMALARGUMENTFORMAT", NULL);
+ "FORMALARGUMENTFORMAT", (void *)NULL);
goto procError;
}
+ argname = TclGetStringFromObj(fieldValues[0], &nameLength);
+
/*
* Check that the formal parameter name is a scalar.
*/
- p = argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
- last = argname + nameLength;
- while (p < last) {
- if (*p == '(') {
- if (last[-1] == ')') { /* We have an array element. */
+ argnamei = argname;
+ argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
+ while (argnamei < argnamelast) {
+ if (*argnamei == '(') {
+ if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "FORMALARGUMENTFORMAT", NULL);
+ "FORMALARGUMENTFORMAT", (void *)NULL);
goto procError;
}
- } else if (p[0] == ':' && p[1] == ':') {
+ } else if (*argnamei == ':' && *(argnamei+1) == ':') {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "FORMALARGUMENTFORMAT", NULL);
+ "FORMALARGUMENTFORMAT", (void *)NULL);
goto procError;
}
- p++;
+ argnamei++;
}
if (precompiled) {
@@ -552,10 +588,10 @@ TclCreateProc(
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
|| (localPtr->defValuePtr != NULL && fieldCount != 2)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter %d is "
+ "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "u is "
"inconsistent with precompiled body", procName, i));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "BYTECODELIES", NULL);
+ "BYTECODELIES", (void *)NULL);
goto procError;
}
@@ -564,11 +600,9 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- int tmpLength, valueLength;
- const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
- &tmpLength);
- const char *value = TclGetStringFromObj(fieldValues[1],
- &valueLength);
+ Tcl_Size tmpLength, valueLength;
+ const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength);
+ const char *value = TclGetStringFromObj(fieldValues[1], &valueLength);
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0
@@ -580,7 +614,7 @@ TclCreateProc(
"default value inconsistent with precompiled body", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "BYTECODELIES", NULL);
+ "BYTECODELIES", (void *)NULL);
goto procError;
}
}
@@ -599,7 +633,7 @@ TclCreateProc(
*/
localPtr = (CompiledLocal *)ckalloc(
- TclOffset(CompiledLocal, name) + 1U + fieldValues[0]->length);
+ offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -683,56 +717,15 @@ TclGetFrame(
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
- Interp *iPtr = (Interp *) interp;
- int curLevel, level, result;
- CallFrame *framePtr;
-
- /*
- * Parse string to figure out which level number to go to.
- */
-
- result = 1;
- curLevel = iPtr->varFramePtr->level;
- if (*name== '#') {
- if (Tcl_GetInt(NULL, name+1, &level) != TCL_OK || level < 0) {
- goto levelError;
- }
- } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
- if (Tcl_GetInt(NULL, name, &level) != TCL_OK) {
- goto levelError;
- }
- level = curLevel - level;
- } else {
- /*
- * (historical, TODO) If name does not contain a level (#0 or 1),
- * TclGetFrame and Tcl_UpVar2 uses current level - 1
- */
- level = curLevel - 1;
- result = 0;
- name = "1"; /* be more consistent with TclObjGetFrame (error at top - 1) */
- }
-
- /*
- * Figure out which frame to use, and return it to the caller.
- */
-
- for (framePtr = iPtr->varFramePtr; framePtr != NULL;
- framePtr = framePtr->callerVarPtr) {
- if (framePtr->level == level) {
- break;
- }
- }
- if (framePtr == NULL) {
- goto levelError;
- }
-
- *framePtrPtr = framePtr;
- return result;
-
- levelError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
- return -1;
+ int result;
+ Tcl_Obj obj;
+
+ obj.bytes = (char *) name;
+ obj.length = strlen(name);
+ obj.typePtr = NULL;
+ result = TclObjGetFrame(interp, &obj, framePtrPtr);
+ TclFreeInternalRep(&obj);
+ return result;
}
/*
@@ -769,7 +762,9 @@ TclObjGetFrame(
{
Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
+ const Tcl_ObjInternalRep *irPtr;
const char *name = NULL;
+ Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
@@ -785,25 +780,34 @@ TclObjGetFrame(
if (objPtr == NULL) {
/* Do nothing */
- } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)
- && (level >= 0)) {
- level = curLevel - level;
- result = 1;
- } else if (objPtr->typePtr == &levelReferenceType) {
- level = (int) objPtr->internalRep.longValue;
+ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) {
+ Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
+ result = -1;
+ } else {
+ level = curLevel - level;
+ result = 1;
+ }
+ } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) {
+ level = irPtr->wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
if (name[0] == '#') {
- if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.longValue = level;
- result = 1;
+ if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
+ if (level < 0 || (level > 0 && name[1] == '-')) {
+ result = -1;
+ } else {
+ Tcl_ObjInternalRep ir;
+
+ ir.wideValue = level;
+ Tcl_StoreInternalRep(objPtr, &levelReferenceType, &ir);
+ result = 1;
+ }
} else {
result = -1;
}
- } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */
+ } else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
/*
* If this were an integer, we'd have succeeded already.
* Docs say we have to treat this as a 'bad level' error.
@@ -812,11 +816,16 @@ TclObjGetFrame(
}
}
- if (result == 0) {
- level = curLevel - 1;
- name = "1";
- }
if (result != -1) {
+ /* if relative current level */
+ if (result == 0) {
+ if (!curLevel) {
+ /* we are in top-level, so simply generate bad level */
+ name = "1";
+ goto badLevel;
+ }
+ level = curLevel - 1;
+ }
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
@@ -827,13 +836,13 @@ TclObjGetFrame(
}
}
}
- if (name == NULL) {
- name = TclGetString(objPtr);
- }
}
-
+badLevel:
+ if (name == NULL) {
+ name = objPtr ? TclGetString(objPtr) : "1" ;
+ }
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (void *)NULL);
return -1;
}
@@ -856,7 +865,7 @@ TclObjGetFrame(
static int
Uplevel_Callback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -877,7 +886,7 @@ Uplevel_Callback(
int
Tcl_UplevelObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -887,7 +896,7 @@ Tcl_UplevelObjCmd(
int
TclNRUplevelObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -910,8 +919,9 @@ TclNRUplevelObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
- int status ,llength;
- status = TclListObjLength(interp, objv[1], &llength);
+ int status;
+ Tcl_Size 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. */
@@ -1051,11 +1061,11 @@ TclIsProc(
static int
ProcWrongNumArgs(
Tcl_Interp *interp,
- int skip)
+ Tcl_Size skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
- int localCt = procPtr->numCompiledLocals, numArgs, i;
+ Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
const char *final = NULL;
@@ -1087,7 +1097,7 @@ ProcWrongNumArgs(
if (defPtr->value.objPtr != NULL) {
TclNewObj(argObj);
- Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
+ Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (void *)NULL);
} else if (defPtr->flags & VAR_IS_ARGS) {
numArgs--;
final = "?arg ...?";
@@ -1131,6 +1141,7 @@ ProcWrongNumArgs(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
void
TclInitCompiledLocals(
Tcl_Interp *interp, /* Current interpreter. */
@@ -1142,10 +1153,10 @@ TclInitCompiledLocals(
ByteCode *codePtr;
bodyPtr = framePtr->procPtr->bodyPtr;
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr == NULL) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1157,6 +1168,7 @@ TclInitCompiledLocals(
InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1289,7 +1301,7 @@ TclFreeLocalCache(
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
- int i;
+ Tcl_Size i;
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
@@ -1308,9 +1320,9 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
- int localCt = procPtr->numCompiledLocals;
- int numArgs = procPtr->numArgs, i = 0;
+ ByteCode *codePtr;
+ Tcl_Size localCt = procPtr->numCompiledLocals;
+ Tcl_Size numArgs = procPtr->numArgs, i = 0;
Tcl_Obj **namePtr;
Var *varPtr;
@@ -1318,13 +1330,15 @@ InitLocalCache(
CompiledLocal *localPtr;
int isNew;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Cache the names and initial values of local variables; store the
* cache in both the framePtr for this execution and in the codePtr
* for future calls.
*/
- localCachePtr = (LocalCache *)ckalloc(TclOffset(LocalCache, varName0)
+ localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0)
+ localCt * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
@@ -1379,17 +1393,18 @@ static int
InitArgsAndLocals(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
- Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip) /* Number of initial arguments to be skipped,
+ Tcl_Size skip) /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
Var *varPtr, *defPtr;
- int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
+ Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+
/*
* Make sure that the local cache of variable names and initial values has
* been initialised properly .
@@ -1470,7 +1485,7 @@ InitArgsAndLocals(
varPtr->flags = 0;
if (defPtr && defPtr->flags & VAR_IS_ARGS) {
- Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
+ Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i);
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
@@ -1540,11 +1555,11 @@ InitArgsAndLocals(
int
TclPushProcCallFrame(
- ClientData clientData, /* Record describing procedure to be
+ void *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
+ Tcl_Size objc, /* 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
@@ -1564,7 +1579,8 @@ TclPushProcCallFrame(
* local variables are found while compiling.
*/
- if (procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL) {
Interp *iPtr = (Interp *) interp;
/*
@@ -1577,7 +1593,6 @@ TclPushProcCallFrame(
* Ensure the ByteCode's procPtr is the same (or it's precompiled).
*/
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1635,7 +1650,7 @@ TclPushProcCallFrame(
int
TclObjInterpProc(
- ClientData clientData, /* Record describing procedure to be
+ void *clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
@@ -1652,11 +1667,11 @@ TclObjInterpProc(
int
TclNRInterpProc(
- ClientData clientData, /* Record describing procedure to be
+ void *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
+ Tcl_Size objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
@@ -1692,7 +1707,7 @@ TclNRInterpProcCore(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip, /* Number of initial arguments to be skipped,
+ Tcl_Size skip, /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
ProcErrorProc *errorProc) /* How to convert results from the script into
* results of the overall procedure. */
@@ -1703,7 +1718,7 @@ TclNRInterpProcCore(
CallFrame *freePtr;
ByteCode *codePtr;
- result = InitArgsAndLocals(interp, procNameObj, skip);
+ result = InitArgsAndLocals(interp, skip);
if (result != TCL_OK) {
freePtr = iPtr->framePtr;
Tcl_PopCallFrame(interp); /* Pop but do not free. */
@@ -1716,7 +1731,7 @@ TclNRInterpProcCore(
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
CallFrame *framePtr = iPtr->varFramePtr;
- int i;
+ Tcl_Size i;
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
fprintf(stdout, "Calling lambda ");
@@ -1734,9 +1749,9 @@ TclNRInterpProcCore(
#ifdef USE_DTRACE
if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
const char *a[10];
- int i;
+ Tcl_Size i;
for (i = 0 ; i < 10 ; i++) {
a[i] = (l < iPtr->varFramePtr->objc ?
@@ -1755,7 +1770,7 @@ TclNRInterpProcCore(
TclDecrRefCount(info);
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
@@ -1763,7 +1778,7 @@ TclNRInterpProcCore(
(Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
@@ -1777,7 +1792,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1786,7 +1801,7 @@ TclNRInterpProcCore(
static int
InterpProcNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -1797,7 +1812,7 @@ InterpProcNR2(
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
@@ -1820,7 +1835,7 @@ InterpProcNR2(
done:
if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
- int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
+ Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
Tcl_Obj *r = Tcl_GetObjResult(interp);
TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
@@ -1859,7 +1874,7 @@ InterpProcNR2(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invoked \"%s\" outside of a loop",
((result == TCL_BREAK) ? "break" : "continue")));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (void *)NULL);
result = TCL_ERROR;
/* FALLTHRU */
@@ -1909,7 +1924,9 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr;
+
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1926,7 +1943,7 @@ TclProcCompileProc(
* are not recompiled, even if things have changed.
*/
- if (bodyPtr->typePtr == &tclByteCodeType) {
+ if (codePtr != NULL) {
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
@@ -1941,17 +1958,18 @@ TclProcCompileProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a precompiled script jumped interps", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
- "CROSSINTERPBYTECODE", NULL);
+ "CROSSINTERPBYTECODE", (void *)NULL);
return TCL_ERROR;
}
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- TclFreeIntRep(bodyPtr);
+ Tcl_StoreInternalRep(bodyPtr, &tclByteCodeType, NULL);
+ codePtr = NULL;
}
}
- if (bodyPtr->typePtr != &tclByteCodeType) {
+ if (codePtr == NULL) {
Tcl_HashEntry *hePtr;
#ifdef TCL_COMPILE_DEBUG
@@ -1965,11 +1983,14 @@ TclProcCompileProc(
TclNewLiteralStringObj(message, "Compiling ");
Tcl_IncrRefCount(message);
- Tcl_AppendStringsToObj(message, description, " \"", NULL);
- Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
+ Tcl_AppendStringsToObj(message, description, " \"", (void *)NULL);
+ Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL);
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
+#else
+ (void)description;
+ (void)procName;
#endif
/*
@@ -2072,13 +2093,14 @@ MakeProcError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ int overflow, limit = 60;
+ Tcl_Size nameLen;
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
@@ -2104,7 +2126,7 @@ MakeProcError(
void
TclProcDeleteProc(
- ClientData clientData) /* Procedure to be deleted. */
+ void *clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
@@ -2144,11 +2166,11 @@ TclProcCleanupProc(
if (bodyPtr != NULL) {
/* procPtr is stored in body's ByteCode, so ensure to reset it. */
- if (bodyPtr->typePtr == &tclByteCodeType) {
- ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
- if (codePtr->procPtr == procPtr) {
- codePtr->procPtr = NULL;
- }
+ ByteCode *codePtr;
+
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL && codePtr->procPtr == procPtr) {
+ codePtr->procPtr = NULL;
}
Tcl_DecrRefCount(bodyPtr);
}
@@ -2255,13 +2277,14 @@ TclUpdateReturnInfo(
*
* TclGetObjInterpProc --
*
- * Returns a pointer to the TclObjInterpProc function; this is different
- * from the value obtained from the TclObjInterpProc reference on systems
- * like Windows where import and export versions of a function exported
- * by a DLL exist.
+ * Returns a pointer to the TclObjInterpProc functions;
+ * this is different from the value obtained from the TclObjInterpProc
+ * reference on systems like Windows where import and export versions
+ * of a function exported by a DLL exist.
*
* Results:
- * Returns the internal address of the TclObjInterpProc function.
+ * Returns the internal address of the TclObjInterpProc
+ * functions.
*
* Side effects:
* None.
@@ -2307,10 +2330,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
-
- procPtr->refCount++;
+ ProcSetInternalRep(objPtr, procPtr);
}
return objPtr;
@@ -2338,11 +2358,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+ ProcGetInternalRep(srcPtr, procPtr);
- dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- procPtr->refCount++;
+ ProcSetInternalRep(dupPtr, procPtr);
}
/*
@@ -2368,7 +2387,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Proc *procPtr;
+
+ ProcGetInternalRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2394,15 +2415,15 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
procPtr->refCount++;
- Tcl_IncrRefCount(nsObjPtr);
- copyPtr->typePtr = &tclLambdaType;
+
+ LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr);
}
static void
@@ -2410,14 +2431,16 @@ FreeLambdaInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ assert(procPtr != NULL);
- if (procPtr->refCount-- == 1) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
- objPtr->typePtr = NULL;
}
static int
@@ -2428,7 +2451,8 @@ SetLambdaFromAny(
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
- int isNew, objc, result;
+ int isNew, result;
+ Tcl_Size objc;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
@@ -2438,15 +2462,23 @@ SetLambdaFromAny(
/*
* Convert objPtr to list type first; if it cannot be converted, or if its
- * length is not 2, then it cannot be converted to tclLambdaType.
+ * length is not 2, then it cannot be converted to lambdaType.
*/
- result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ result = TclListObjLengthM(NULL, objPtr, &objc);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
Tcl_GetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL);
+ return TCL_ERROR;
+ }
+ 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",
+ Tcl_GetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL);
return TCL_ERROR;
}
@@ -2524,7 +2556,7 @@ SetLambdaFromAny(
if (contextPtr->line
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
- int buf[2];
+ Tcl_Size buf[2];
/*
* Move from approximation (line of list cmd word) to actual
@@ -2536,7 +2568,7 @@ SetLambdaFromAny(
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *)ckalloc(sizeof(int));
+ cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size));
cfPtr->line[0] = buf[1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -2579,21 +2611,42 @@ SetLambdaFromAny(
}
}
- Tcl_IncrRefCount(nsObjPtr);
-
/*
* Free the list internalrep of objPtr - this will free argsPtr, but
* bodyPtr retains a reference from the Proc structure. Then finish the
- * conversion to tclLambdaType.
+ * conversion to lambdaType.
*/
- TclFreeIntRep(objPtr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
- objPtr->typePtr = &tclLambdaType;
+ LambdaSetInternalRep(objPtr, procPtr, nsObjPtr);
return TCL_OK;
}
+
+Proc *
+TclGetLambdaFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Obj **nsObjPtrPtr)
+{
+ Proc *procPtr;
+ Tcl_Obj *nsObjPtr;
+
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+
+ if (procPtr == NULL) {
+ if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
+ return NULL;
+ }
+ LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ }
+
+ assert(procPtr != NULL);
+ if (procPtr->iPtr != (Interp *)interp) {
+ return NULL;
+ }
+
+ *nsObjPtrPtr = nsObjPtr;
+ return procPtr;
+}
/*
*----------------------------------------------------------------------
@@ -2614,7 +2667,7 @@ SetLambdaFromAny(
int
Tcl_ApplyObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2624,12 +2677,11 @@ Tcl_ApplyObjCmd(
int
TclNRApplyObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result;
@@ -2647,24 +2699,17 @@ TclNRApplyObjCmd(
*/
lambdaPtr = objv[1];
- if (lambdaPtr->typePtr == &tclLambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
- }
+ procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr);
- if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) {
- result = SetLambdaFromAny(interp, lambdaPtr);
- if (result != TCL_OK) {
- return result;
- }
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ if (procPtr == NULL) {
+ return TCL_ERROR;
}
/*
- * Find the namespace where this lambda should run, and push a call frame
- * for that namespace. Note that TclObjInterpProc() will pop it.
+ * Push a call frame for the lambda namespace.
+ * Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
@@ -2701,7 +2746,7 @@ TclNRApplyObjCmd(
static int
ApplyNR2(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -2736,13 +2781,14 @@ MakeLambdaError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
+ int overflow, limit = 60;
+ Tcl_Size nameLen;
+ const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
new file mode 100644
index 0000000..d55a1fd
--- /dev/null
+++ b/generic/tclProcess.c
@@ -0,0 +1,951 @@
+/*
+ * tclProcess.c --
+ *
+ * This file implements the "tcl::process" ensemble for subprocess
+ * management as defined by TIP #462.
+ *
+ * Copyright © 2017 Frederic Bonnet.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+
+/*
+ * Autopurge flag. Process-global because of the way Tcl manages child
+ * processes (see tclPipe.c).
+ */
+
+static int autopurge = 1; /* Autopurge flag. */
+
+/*
+ * Hash tables that keeps track of all child process statuses. Keys are the
+ * child process ids and resolved pids, values are (ProcessInfo *).
+ */
+
+typedef struct ProcessInfo {
+ Tcl_Pid pid; /* Process id. */
+ Tcl_Size resolvedPid; /* Resolved process id. */
+ int purge; /* Purge eventualy. */
+ TclProcessWaitStatus status;/* Process status. */
+ int code; /* Error code, exit status or signal
+ number. */
+ Tcl_Obj *msg; /* Error message. */
+ Tcl_Obj *error; /* Error code. */
+} ProcessInfo;
+static Tcl_HashTable infoTablePerPid;
+static Tcl_HashTable infoTablePerResolvedPid;
+static int infoTablesInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(infoTablesMutex)
+
+ /*
+ * Prototypes for functions defined later in this file:
+ */
+
+static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
+ Tcl_Size resolvedPid);
+static void FreeProcessInfo(ProcessInfo *info);
+static int RefreshProcessInfo(ProcessInfo *info, int options);
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, Tcl_Size resolvedPid,
+ int options, int *codePtr, Tcl_Obj **msgPtr,
+ Tcl_Obj **errorObjPtr);
+static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
+static Tcl_ObjCmdProc ProcessListObjCmd;
+static Tcl_ObjCmdProc ProcessStatusObjCmd;
+static Tcl_ObjCmdProc ProcessPurgeObjCmd;
+static Tcl_ObjCmdProc ProcessAutopurgeObjCmd;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitProcessInfo --
+ *
+ * Initializes the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory written.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+InitProcessInfo(
+ ProcessInfo *info, /* Structure to initialize. */
+ Tcl_Pid pid, /* Process id. */
+ Tcl_Size resolvedPid) /* Resolved process id. */
+{
+ info->pid = pid;
+ info->resolvedPid = resolvedPid;
+ info->purge = 0;
+ info->status = TCL_PROCESS_UNCHANGED;
+ info->code = 0;
+ info->msg = NULL;
+ info->error = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeProcessInfo --
+ *
+ * Free the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory deallocated, Tcl_Obj refcount decreased.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+FreeProcessInfo(
+ ProcessInfo *info) /* Structure to free. */
+{
+ /*
+ * Free stored Tcl_Objs.
+ */
+
+ if (info->msg) {
+ Tcl_DecrRefCount(info->msg);
+ }
+ if (info->error) {
+ Tcl_DecrRefCount(info->error);
+ }
+
+ /*
+ * Free allocated structure.
+ */
+
+ ckfree(info);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RefreshProcessInfo --
+ *
+ * Refresh process info.
+ *
+ * Results:
+ * Nonzero if state changed, else zero.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+RefreshProcessInfo(
+ ProcessInfo *info, /* Structure to refresh. */
+ int options /* Options passed to WaitProcessStatus. */
+)
+{
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Refresh & store status.
+ */
+
+ info->status = WaitProcessStatus(info->pid, info->resolvedPid,
+ options, &info->code, &info->msg, &info->error);
+ if (info->msg) Tcl_IncrRefCount(info->msg);
+ if (info->error) Tcl_IncrRefCount(info->error);
+ return (info->status != TCL_PROCESS_UNCHANGED);
+ } else {
+ /*
+ * No change.
+ */
+
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitProcessStatus --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+WaitProcessStatus(
+ Tcl_Pid pid, /* Process id. */
+ Tcl_Size resolvedPid, /* Resolved process id. */
+ int options, /* Options passed to Tcl_WaitPid. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ int waitStatus;
+ Tcl_Obj *errorStrings[5];
+ const char *msg;
+
+ pid = Tcl_WaitPid(pid, &waitStatus, options);
+ if (pid == 0) {
+ /*
+ * No change.
+ */
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Get process status.
+ */
+
+ if (pid == (Tcl_Pid)-1) {
+ /*
+ * POSIX errName msg
+ */
+
+ msg = Tcl_ErrnoMsg(errno);
+ if (errno == ECHILD) {
+ /*
+ * This changeup in message suggested by Mark Diekhans to
+ * remind people that ECHILD errors can occur on some
+ * systems if SIGCHLD isn't in its default state.
+ */
+
+ msg = "child process lost (is SIGCHLD ignored or trapped?)";
+ }
+ if (codePtr) *codePtr = errno;
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "error waiting for process to exit: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
+ errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
+ errorStrings[2] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ return TCL_PROCESS_ERROR;
+ } else if (WIFEXITED(waitStatus)) {
+ if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
+ if (!WEXITSTATUS(waitStatus)) {
+ /*
+ * Normal exit.
+ */
+
+ if (msgObjPtr) *msgObjPtr = NULL;
+ if (errorObjPtr) *errorObjPtr = NULL;
+ } else {
+ /*
+ * CHILDSTATUS pid code
+ *
+ * Child exited with a non-zero exit status.
+ */
+
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child process exited abnormally", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ TclNewIntObj(errorStrings[2], WEXITSTATUS(waitStatus));
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ }
+ return TCL_PROCESS_EXITED;
+ } else if (WIFSIGNALED(waitStatus)) {
+ /*
+ * CHILDKILLED pid sigName msg
+ *
+ * Child killed because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
+ if (codePtr) *codePtr = WTERMSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child killed: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_SIGNALED;
+ } else if (WIFSTOPPED(waitStatus)) {
+ /*
+ * CHILDSUSP pid sigName msg
+ *
+ * Child suspended because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
+ if (codePtr) *codePtr = WSTOPSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child suspended: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
+ TclNewIntObj(errorStrings[1], resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_STOPPED;
+ } else {
+ /*
+ * TCL OPERATION EXEC ODDWAITRESULT
+ *
+ * Child wait status didn't make sense.
+ */
+
+ if (codePtr) *codePtr = waitStatus;
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child wait status didn't make sense\n", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("TCL", -1);
+ errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
+ errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
+ errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
+ TclNewIntObj(errorStrings[4], resolvedPid);
+ *errorObjPtr = Tcl_NewListObj(5, errorStrings);
+ }
+ return TCL_PROCESS_UNKNOWN_STATUS;
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildProcessStatusObj --
+ *
+ * Build a list object with process status. The first element is always
+ * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
+ * In the latter case, the second element is the error message and the
+ * third element is a Tcl error code (see tclvars).
+ *
+ * Results:
+ * A list object.
+ *
+ * Side effects:
+ * Tcl_Objs are created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+BuildProcessStatusObj(
+ ProcessInfo *info)
+{
+ Tcl_Obj *resultObjs[3];
+
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Process still running, return empty obj.
+ */
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+ if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
+ /*
+ * Normal exit, return TCL_OK.
+ */
+
+ return Tcl_NewWideIntObj(TCL_OK);
+ }
+
+ /*
+ * Abnormal exit, return {TCL_ERROR msg error}
+ */
+
+ TclNewIntObj(resultObjs[0], TCL_ERROR);
+ resultObjs[1] = info->msg;
+ resultObjs[2] = info->error;
+ return Tcl_NewListObj(3, resultObjs);
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessListObjCmd --
+ *
+ * This function implements the 'tcl::process list' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * 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, *elemPtr;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the list of all chid process ids.
+ */
+
+ list = Tcl_NewListObj(0, NULL);
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ TclNewIntObj(elemPtr, info->resolvedPid);
+ Tcl_ListObjAppendElement(interp, list, elemPtr);
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_SetObjResult(interp, list);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessStatusObjCmd --
+ *
+ * This function implements the 'tcl::process status' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Access to the internal structures is protected by infoTablesMutex.
+ * 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, *elemPtr;
+ int index, options = WNOHANG;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int 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
+ };
+
+ while (objc > 1) {
+ if (TclGetString(objv[1])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ++objv; --objc;
+ if (STATUS_WAIT == (enum switchesEnum) index) {
+ options = 0;
+ } else {
+ break;
+ }
+ }
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 1) {
+ /*
+ * Return a dict with all child process statuses.
+ */
+
+ dict = Tcl_NewDictObj();
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ TclNewIntObj(elemPtr, info->resolvedPid);
+ Tcl_DictObjPut(interp, dict, elemPtr,
+ BuildProcessStatusObj(info));
+ }
+ }
+ 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);
+ if (result != TCL_OK) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_DecrRefCount(dict);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ TclNewIntObj(elemPtr, info->resolvedPid);
+ Tcl_DictObjPut(interp, dict, elemPtr,
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+ Tcl_SetObjResult(interp, dict);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessPurgeObjCmd --
+ *
+ * This function implements the 'tcl::process purge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * 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;
+ Tcl_Size i, numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int pid;
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First reap detached procs so that their purge flag is up-to-date.
+ */
+
+ Tcl_ReapDetachedProcs();
+
+ if (objc == 1) {
+ /*
+ * Purge all terminated processes.
+ */
+
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ 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) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessAutopurgeObjCmd --
+ *
+ * This function implements the 'tcl::process autopurge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * 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?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ /*
+ * Set given value.
+ */
+
+ int flag;
+ int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ autopurge = !!flag;
+ }
+
+ /*
+ * Return current value.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitProcessCmd --
+ *
+ * This procedure creates the "tcl::process" Tcl command. See the user
+ * documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclInitProcessCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+ static const EnsembleImplMap processImplMap[] = {
+ {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
+ {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ Tcl_Command processCmd;
+
+ if (infoTablesInitialized == 0) {
+ Tcl_MutexLock(&infoTablesMutex);
+ if (infoTablesInitialized == 0) {
+ Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
+ infoTablesInitialized = 1;
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
+ Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
+ "process", 0);
+ return processCmd;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessCreated --
+ *
+ * Called when a child process has been created by Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Internal structures are updated with a new ProcessInfo.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclProcessCreated(
+ Tcl_Pid pid) /* Process id. */
+{
+ Tcl_Size resolvedPid;
+ Tcl_HashEntry *entry, *entry2;
+ int isNew;
+ ProcessInfo *info;
+
+ /*
+ * Get resolved pid first.
+ */
+
+ resolvedPid = TclpGetPid(pid);
+
+ Tcl_MutexLock(&infoTablesMutex);
+
+ /*
+ * Create entry in pid table.
+ */
+
+ entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
+ if (!isNew) {
+ /*
+ * Pid was reused, free old info and reuse structure.
+ */
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(resolvedPid));
+ if (entry2) Tcl_DeleteHashEntry(entry2);
+ FreeProcessInfo(info);
+ }
+
+ /*
+ * Allocate and initialize info structure.
+ */
+
+ info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo));
+ InitProcessInfo(info, pid, resolvedPid);
+
+ /*
+ * Add entry to tables.
+ */
+
+ Tcl_SetHashValue(entry, info);
+ entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
+ &isNew);
+ Tcl_SetHashValue(entry, info);
+
+ Tcl_MutexUnlock(&infoTablesMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessWait --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * Completed process info structures are purged immediately (autopurge on)
+ * or eventually (autopurge off).
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+TclProcessWait(
+ Tcl_Pid pid, /* Process id. */
+ int options, /* Options passed to WaitProcessStatus. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ Tcl_HashEntry *entry;
+ ProcessInfo *info;
+ TclProcessWaitStatus result;
+
+ /*
+ * First search for pid in table.
+ */
+
+ Tcl_MutexLock(&infoTablesMutex);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
+ if (!entry) {
+ /*
+ * Unknown process, just call WaitProcessStatus and return.
+ */
+
+ result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
+ msgObjPtr, errorObjPtr);
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ /*
+ * Process has completed but TclProcessWait has already been called,
+ * so report no change.
+ */
+ Tcl_MutexUnlock(&infoTablesMutex);
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ RefreshProcessInfo(info, options);
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * No change, stop there.
+ */
+ Tcl_MutexUnlock(&infoTablesMutex);
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Set return values.
+ */
+
+ result = info->status;
+ if (codePtr) *codePtr = info->code;
+ if (msgObjPtr) *msgObjPtr = info->msg;
+ if (errorObjPtr) *errorObjPtr = info->error;
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+
+ if (autopurge) {
+ /*
+ * Purge now.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(info->resolvedPid));
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Eventually purge. Subsequent calls will return
+ * TCL_PROCESS_UNCHANGED.
+ */
+
+ info->purge = 1;
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+}
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 3259b48..a823af5 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -4,8 +4,8 @@
* This file contains the public interfaces to the Tcl regular expression
* mechanism.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -13,6 +13,7 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include <assert.h>
/*
*----------------------------------------------------------------------
@@ -25,7 +26,7 @@
* regex.h regexec.c regfree.c
* regfronts.c regguts.h
*
- * Copyright (c) 1998 Henry Spencer. All rights reserved.
+ * Copyright © 1998 Henry Spencer. All rights reserved.
*
* Development of this software was funded, in part, by Cray Research Inc.,
* UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
@@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = {
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
+
+#define RegexpSetInternalRep(objPtr, rePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ (rePtr)->refCount++; \
+ ir.twoPtrValue.ptr1 = (rePtr); \
+ ir.twoPtrValue.ptr2 = NULL; \
+ Tcl_StoreInternalRep((objPtr), &tclRegexpType, &ir); \
+ } while (0)
+
+#define RegexpGetInternalRep(objPtr, rePtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclRegexpType); \
+ (rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
/*
*----------------------------------------------------------------------
@@ -245,7 +263,7 @@ Tcl_RegExpRange(
if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = *endPtr = NULL;
- } else if (regexpPtr->matches[index].rm_so == -1) {
+ } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
@@ -253,8 +271,8 @@ Tcl_RegExpRange(
} else {
string = regexpPtr->string;
}
- *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
- *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
+ *startPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_so);
+ *endPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_eo);
}
}
@@ -346,7 +364,7 @@ TclRegExpRangeUniChar(
* passed to Tcl_RegExpExec. */
int index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
- * subrange, -1 means the range of the
+ * subrange, TCL_INDEX_NONE means the range of the
* rm_extend field. */
int *startPtr, /* Store address of first character in
* (sub-)range here. */
@@ -355,12 +373,12 @@ TclRegExpRangeUniChar(
{
TclRegexp *regexpPtr = (TclRegexp *) re;
- if ((regexpPtr->flags&REG_EXPECT) && (index == -1)) {
+ if ((regexpPtr->flags&REG_EXPECT) && (index == TCL_INDEX_NONE)) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
} else if ((size_t) index > regexpPtr->re.re_nsub) {
- *startPtr = -1;
- *endPtr = -1;
+ *startPtr = TCL_INDEX_NONE;
+ *endPtr = TCL_INDEX_NONE;
} else {
*startPtr = regexpPtr->matches[index].rm_so;
*endPtr = regexpPtr->matches[index].rm_eo;
@@ -464,7 +482,7 @@ Tcl_RegExpExecObj(
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
- udata = Tcl_GetUnicodeFromObj(textObj, &length);
+ udata = TclGetUnicodeFromObj(textObj, &length);
if (offset > length) {
offset = length;
@@ -580,14 +598,9 @@ Tcl_GetRegExpFromObj(
TclRegexp *regexpPtr;
const char *pattern;
- /*
- * This is OK because we only actually interpret this value properly as a
- * TclRegexp* when the type is tclRegexpType.
- */
-
- regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ RegexpGetInternalRep(objPtr, regexpPtr);
- if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
+ if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
@@ -595,21 +608,7 @@ Tcl_GetRegExpFromObj(
return NULL;
}
- /*
- * Add a reference to the regexp so it will persist even if it is
- * pushed out of the current thread's regexp cache. This reference
- * will be removed when the object's internal rep is freed.
- */
-
- regexpPtr->refCount++;
-
- /*
- * Free the old representation and set our type.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
- objPtr->typePtr = &tclRegexpType;
+ RegexpSetInternalRep(objPtr, regexpPtr);
}
return (Tcl_RegExp) regexpPtr;
}
@@ -678,8 +677,8 @@ TclRegAbout(
*/
TclNewObj(resultObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewIntObj((int) regexpPtr->re.re_nsub));
+ TclNewIndexObj(infoObj, regexpPtr->re.re_nsub);
+ Tcl_ListObjAppendElement(NULL, resultObj, infoObj);
/*
* Now append a list of all the bit-flags set for the RE.
@@ -732,7 +731,7 @@ TclRegError(
snprintf(cbuf, sizeof(cbuf), "%d", status);
(void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
- Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
+ Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, (void *)NULL);
}
/*
@@ -756,7 +755,11 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpRepPtr;
+
+ RegexpGetInternalRep(objPtr, regexpRepPtr);
+
+ assert(regexpRepPtr != NULL);
/*
* If this is the last reference to the regexp, free it.
@@ -765,7 +768,6 @@ FreeRegexpInternalRep(
if (regexpRepPtr->refCount-- <= 1) {
FreeRegexp(regexpRepPtr);
}
- objPtr->typePtr = NULL;
}
/*
@@ -790,11 +792,13 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ TclRegexp *regexpPtr;
+
+ RegexpGetInternalRep(srcPtr, regexpPtr);
+
+ assert(regexpPtr != NULL);
- regexpPtr->refCount++;
- copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->typePtr = &tclRegexpType;
+ RegexpSetInternalRep(copyPtr, regexpPtr);
}
/*
@@ -955,7 +959,7 @@ CompileRegexp(
if (TclReToGlob(NULL, string, length, &stringBuf, &exact,
NULL) == TCL_OK) {
- regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
+ regexpPtr->globObjPtr = Tcl_DStringToObj(&stringBuf);
Tcl_IncrRefCount(regexpPtr->globObjPtr);
} else {
regexpPtr->globObjPtr = NULL;
@@ -1049,7 +1053,7 @@ FreeRegexp(
static void
FinalizeRegexp(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
int i;
TclRegexp *regexpPtr;
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 3b2433e..a263dfd 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -37,7 +37,7 @@ typedef struct TclRegexp {
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
- int refCount; /* Count of number of references to this
+ size_t refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index 974737e..ff88ffd 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -6,7 +6,7 @@
* name resolution rules to the Tcl language. Rules can be applied to a
* particular namespace, to the interpreter as a whole, or both.
*
- * Copyright (c) 1998 Lucent Technologies, Inc.
+ * Copyright © 1998 Lucent Technologies, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -101,9 +101,9 @@ Tcl_AddInterpResolvers(
* list, so that it overrides existing schemes.
*/
- resPtr = ckalloc(sizeof(ResolverScheme));
+ resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme));
len = strlen(name) + 1;
- resPtr->name = ckalloc(len);
+ resPtr->name = (char *)ckalloc(len);
memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
@@ -265,7 +265,7 @@ BumpCmdRefEpochs(
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
- Namespace *childNsPtr = Tcl_GetHashValue(entry);
+ Namespace *childNsPtr = (Namespace *)Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index f82e6a4..91ddc6e 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -3,7 +3,7 @@
*
* This file contains code to manage the interpreter result.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -27,7 +27,9 @@ enum returnKeys {
static Tcl_Obj ** GetKeys(void);
static void ReleaseKeys(ClientData clientData);
static void ResetObjResult(Interp *iPtr);
+#ifndef TCL_NO_DEPRECATED
static void SetupAppendBuffer(Interp *iPtr, int newSpace);
+#endif /* !TCL_NO_DEPRECATED */
/*
* This structure is used to take a snapshot of the interpreter state in
@@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace);
* then back up to the result or the error that was previously in progress.
*/
-typedef struct InterpState {
+typedef struct {
int status; /* return code status */
int flags; /* Each remaining field saves the */
int returnLevel; /* corresponding field of the Interp */
@@ -75,7 +77,7 @@ Tcl_SaveInterpState(
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
- InterpState *statePtr = ckalloc(sizeof(InterpState));
+ InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
@@ -230,6 +232,7 @@ Tcl_DiscardInterpState(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SaveResult
void
Tcl_SaveResult(
@@ -429,7 +432,7 @@ Tcl_SetResult(
int length = strlen(result);
if (length > TCL_RESULT_SIZE) {
- iPtr->result = ckalloc(length + 1);
+ iPtr->result = (char *)ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
@@ -461,6 +464,7 @@ Tcl_SetResult(
ResetObjResult(iPtr);
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -479,22 +483,26 @@ Tcl_SetResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetStringResult
const char *
Tcl_GetStringResult(
Tcl_Interp *interp)/* Interpreter whose result to return. */
{
+#ifndef TCL_NO_DEPRECATED
+ Interp *iPtr = (Interp *) interp;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
- Interp *iPtr = (Interp *) interp;
-
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return iPtr->result;
+#else
+ return TclGetString(Tcl_GetObjResult(interp));
+#endif
}
/*
@@ -536,6 +544,7 @@ Tcl_SetObjResult(
TclDecrRefCount(oldObjResult);
+#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
@@ -550,6 +559,7 @@ Tcl_SetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif
}
/*
@@ -578,6 +588,7 @@ Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
Interp *iPtr = (Interp *) interp;
+#ifndef TCL_NO_DEPRECATED
Tcl_Obj *objResultPtr;
int length;
@@ -604,6 +615,7 @@ Tcl_GetObjResult(
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
+#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
@@ -640,23 +652,6 @@ Tcl_AppendResultVA(
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
-
- /*
- * Strictly we should call Tcl_GetStringResult(interp) here to make sure
- * that interp->result is correct according to the old contract, but that
- * makes the performance of much code (e.g. in Tk) absolutely awful. So we
- * leave it out; code that really wants interp->result can just insert the
- * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
- */
-
-#ifdef USE_INTERP_RESULT
- /*
- * Ensure that the interp->result is legal so old Tcl 7.* code still
- * works. There's still embarrasingly much of it about...
- */
-
- (void) Tcl_GetStringResult(interp);
-#endif /* USE_INTERP_RESULT */
}
/*
@@ -722,6 +717,21 @@ Tcl_AppendElement(
* to result. */
{
Interp *iPtr = (Interp *) interp;
+#ifdef TCL_NO_DEPRECATED
+ Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
+ Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
+ const char *bytes;
+
+ if (Tcl_IsShared(iPtr->objResultPtr)) {
+ Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
+ }
+ bytes = TclGetString(iPtr->objResultPtr);
+ if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) {
+ Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
+ }
+ Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
+ Tcl_DecrRefCount(listPtr);
+#else
char *dst;
int size;
int flags;
@@ -774,6 +784,7 @@ Tcl_AppendElement(
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -795,6 +806,7 @@ Tcl_AppendElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
@@ -834,19 +846,19 @@ SetupAppendBuffer(
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
- char *new;
+ char *newSpacePtr;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
- new = ckalloc(totalSpace);
- strcpy(new, iPtr->result);
+ newSpacePtr = (char *)ckalloc(totalSpace);
+ strcpy(newSpacePtr, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
- iPtr->appendResult = new;
+ iPtr->appendResult = newSpacePtr;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
@@ -895,7 +907,8 @@ Tcl_FreeResult(
ResetObjResult(iPtr);
}
-
+#endif /* !TCL_NO_DEPRECATED */
+
/*
*----------------------------------------------------------------------
*
@@ -922,6 +935,7 @@ Tcl_ResetResult(
Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
+#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -932,6 +946,7 @@ Tcl_ResetResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
@@ -991,14 +1006,14 @@ ResetObjResult(
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if (objResultPtr->bytes != tclEmptyStringRep) {
+ if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
ckfree(objResultPtr->bytes);
}
- objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
- TclFreeIntRep(objResultPtr);
+ TclFreeInternalRep(objResultPtr);
}
}
@@ -1174,8 +1189,8 @@ static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
- Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
- (int) (KEY_LAST * sizeof(Tcl_Obj *)));
+ Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey,
+ KEY_LAST * sizeof(Tcl_Obj *));
if (keys[0] == NULL) {
/*
@@ -1226,7 +1241,7 @@ static void
ReleaseKeys(
ClientData clientData)
{
- Tcl_Obj **keys = clientData;
+ Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
@@ -1286,10 +1301,8 @@ TclProcessReturn(
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
- int infoLen;
-
- (void) TclGetStringFromObj(valuePtr, &infoLen);
- if (infoLen) {
+ (void) TclGetString(valuePtr);
+ if (valuePtr->length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
@@ -1315,12 +1328,12 @@ TclProcessReturn(
* if someone does [return -errorstack [info errorstack]]
*/
- if (TclListObjGetElements(interp, valuePtr, &valueObjc,
+ if (TclListObjGetElementsM(interp, valuePtr, &valueObjc,
&valueObjv) == TCL_ERROR) {
return TCL_ERROR;
}
iPtr->resetErrorStack = 0;
- TclListObjLength(interp, iPtr->errorStack, &len);
+ TclListObjLengthM(interp, iPtr->errorStack, &len);
/*
* Reset while keeping the list internalrep as much as possible.
@@ -1334,7 +1347,7 @@ TclProcessReturn(
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
- Tcl_SetErrorCode(interp, "NONE", NULL);
+ Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE],
@@ -1375,7 +1388,7 @@ TclProcessReturn(
int
TclMergeReturnOptions(
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj
* *) where the pointer to the merged return
@@ -1393,13 +1406,11 @@ TclMergeReturnOptions(
TclNewObj(returnOpts);
for (; objc > 1; objv += 2, objc -= 2) {
- int optLen;
- const char *opt = TclGetStringFromObj(objv[0], &optLen);
- int compareLen;
- const char *compare =
- TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
+ const char *opt = TclGetString(objv[0]);
+ const char *compare = TclGetString(keys[KEY_OPTIONS]);
- if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) {
+ if ((objv[0]->length == keys[KEY_OPTIONS]->length)
+ && (memcmp(opt, compare, objv[0]->length) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
@@ -1416,7 +1427,7 @@ TclMergeReturnOptions(
"bad %s value: expected dictionary but got \"%s\"",
compare, TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS",
- NULL);
+ (void *)NULL);
goto error;
}
@@ -1465,7 +1476,7 @@ TclMergeReturnOptions(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad -level value: expected non-negative integer but got"
" \"%s\"", TclGetString(valuePtr)));
- Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
@@ -1479,7 +1490,7 @@ TclMergeReturnOptions(
if (valuePtr != NULL) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorcode.
*/
@@ -1488,7 +1499,7 @@ TclMergeReturnOptions(
"bad -errorcode value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE",
- NULL);
+ (void *)NULL);
goto error;
}
}
@@ -1501,7 +1512,7 @@ TclMergeReturnOptions(
if (valuePtr != NULL) {
int length;
- if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) {
+ if (TCL_ERROR == TclListObjLengthM(NULL, valuePtr, &length )) {
/*
* Value is not a list, which is illegal for -errorstack.
*/
@@ -1510,7 +1521,7 @@ TclMergeReturnOptions(
"bad -errorstack value: expected a list but got \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
- NULL);
+ (void *)NULL);
goto error;
}
if (length % 2) {
@@ -1522,7 +1533,7 @@ TclMergeReturnOptions(
"forbidden odd-sized list for -errorstack: \"%s\"",
TclGetString(valuePtr)));
Tcl_SetErrorCode(interp, "TCL", "RESULT",
- "ODDSIZEDLIST_ERRORSTACK", NULL);
+ "ODDSIZEDLIST_ERRORSTACK", (void *)NULL);
goto error;
}
}
@@ -1592,14 +1603,14 @@ Tcl_GetReturnOptions(
if (result == TCL_RETURN) {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewIntObj(iPtr->returnCode));
+ Tcl_NewWideIntObj(iPtr->returnCode));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewIntObj(iPtr->returnLevel));
+ Tcl_NewWideIntObj(iPtr->returnLevel));
} else {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
- Tcl_NewIntObj(result));
+ Tcl_NewWideIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
- Tcl_NewIntObj(0));
+ Tcl_NewWideIntObj(0));
}
if (result == TCL_ERROR) {
@@ -1612,7 +1623,7 @@ Tcl_GetReturnOptions(
if (iPtr->errorInfo) {
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
- Tcl_NewIntObj(iPtr->errorLine));
+ Tcl_NewWideIntObj(iPtr->errorLine));
}
return options;
}
@@ -1671,11 +1682,11 @@ Tcl_SetReturnOptions(
Tcl_Obj **objv, *mergedOpts;
Tcl_IncrRefCount(options);
- if (TCL_ERROR == TclListObjGetElements(interp, options, &objc, &objv)
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
diff --git a/generic/tclScan.c b/generic/tclScan.c
index ba3d90f..4c141ab 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -3,13 +3,14 @@
*
* This file contains the implementation of the "scan" command.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* 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 "tclTomMath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
@@ -266,7 +267,7 @@ ValidateFormat(
* these are messy operations because we do
* not want to use the formatting engine;
* we're inside there! */
- char buf[TCL_UTF_MAX+1] = "";
+ char buf[5] = "";
/*
* Initialize an array that records the number of times a variable is
@@ -340,7 +341,7 @@ ValidateFormat(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot mix \"%\" and \"%n$\" conversion specifiers",
-1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", (void *)NULL);
goto error;
}
@@ -389,7 +390,7 @@ ValidateFormat(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (void *)NULL);
goto error;
}
/* FALLTHRU */
@@ -403,7 +404,7 @@ ValidateFormat(
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, " conversion", -1);
Tcl_SetObjResult(interp, errorMsg);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (void *)NULL);
goto error;
}
/*
@@ -420,14 +421,7 @@ ValidateFormat(
case 'x':
case 'X':
case 'b':
- break;
case 'u':
- if (flags & SCAN_BIG) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unsigned bignum scans are invalid", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
- goto error;
- }
break;
/*
* Bracket terms need special checking
@@ -462,7 +456,7 @@ ValidateFormat(
badSet:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unmatched [ in format string", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", (void *)NULL);
goto error;
default:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
@@ -471,7 +465,7 @@ ValidateFormat(
Tcl_AppendToObj(errorMsg, buf, -1);
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (void *)NULL);
goto error;
}
if (!(flags & SCAN_SUPPRESS)) {
@@ -518,7 +512,7 @@ ValidateFormat(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is assigned by multiple \"%n$\" conversion specifiers",
-1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", (void *)NULL);
goto error;
} else if (!xpgSize && (nassign[i] == 0)) {
/*
@@ -529,7 +523,7 @@ ValidateFormat(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"variable is not assigned by any conversion specifiers",
-1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", (void *)NULL);
goto error;
}
}
@@ -541,12 +535,12 @@ ValidateFormat(
if (gotXpg) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"%n$\" argument index out of range", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", (void *)NULL);
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"different numbers of variable names and field specifiers",
-1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", (void *)NULL);
}
error:
@@ -573,7 +567,7 @@ ValidateFormat(
int
Tcl_ScanObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -589,7 +583,6 @@ Tcl_ScanObjCmd(
Tcl_UniChar ch = 0, sch = 0;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
- (void)dummy;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -886,7 +879,7 @@ Tcl_ScanObjCmd(
* Scan a single Unicode character.
*/
- offset = TclUtfToUCS4(string, &i);
+ offset = Tcl_UtfToUniChar(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
TclNewIntObj(objPtr, i);
@@ -906,7 +899,7 @@ Tcl_ScanObjCmd(
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
- &end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
+ &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
@@ -934,12 +927,42 @@ Tcl_ScanObjCmd(
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
mp_int big;
- TclBNInitBignumFromWideUInt(&big, (Tcl_WideUInt)wideValue);
- Tcl_SetBignumObj(objPtr, &big);
+ if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create bignum", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ return TCL_ERROR;
+ } else {
+ Tcl_SetBignumObj(objPtr, &big);
+ }
} else {
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
+ }
+ } else if (flags & SCAN_BIG) {
+ if (flags & SCAN_UNSIGNED) {
+ mp_int big;
+ int res = Tcl_GetBignumFromObj(interp, objPtr, &big);
+
+ if (res == TCL_OK) {
+ if (mp_isneg(&big)) {
+ res = TCL_ERROR;
+ }
+ mp_clear(&big);
+ }
+
+ if (res == TCL_ERROR) {
+ if (objs != NULL) {
+ ckfree(objs);
+ }
+ Tcl_DecrRefCount(objPtr);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT",
+ "BADUNSIGNED", (void *)NULL);
+ return TCL_ERROR;
+ }
}
- } else if (!(flags & SCAN_BIG)) {
+ } else {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
@@ -950,13 +973,19 @@ Tcl_ScanObjCmd(
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
mp_int big;
- TclBNInitBignumFromWideUInt(&big, (unsigned long)value);
- Tcl_SetBignumObj(objPtr, &big);
+ if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "insufficient memory to create bignum", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ return TCL_ERROR;
+ } else {
+ Tcl_SetBignumObj(objPtr, &big);
+ }
#else
Tcl_SetWideIntObj(objPtr, (unsigned long)value);
#endif
} else {
- TclSetLongObj(objPtr, value);
+ TclSetIntObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
@@ -967,13 +996,13 @@ Tcl_ScanObjCmd(
* Scan a floating point number
*/
- objPtr = Tcl_NewDoubleObj(0.0);
+ TclNewDoubleObj(objPtr, 0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
- &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
+ &end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
@@ -992,8 +1021,10 @@ Tcl_ScanObjCmd(
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (objPtr->typePtr == &tclDoubleType) {
- dvalue = objPtr->internalRep.doubleValue;
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(objPtr, &tclDoubleType);
+ if (irPtr) {
+ dvalue = irPtr->doubleValue;
} else
#endif
{
@@ -1047,12 +1078,14 @@ Tcl_ScanObjCmd(
Tcl_ListObjAppendElement(NULL, objPtr, objs[i]);
Tcl_DecrRefCount(objs[i]);
} else {
+ Tcl_Obj *obj;
/*
* More %-specifiers than matching chars, so we just spit out
* empty strings for these.
*/
- Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
+ TclNewObj(obj);
+ Tcl_ListObjAppendElement(NULL, objPtr, obj);
}
}
}
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 75125f0..f23b23b 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -7,14 +7,14 @@
* into strings of digits, and procedures for interconversion among
* 'double' and 'mp_int' types.
*
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 Kevin B. Kenny. 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 "tommath.h"
+#include "tclTomMath.h"
#include <float.h>
#include <math.h>
@@ -22,12 +22,10 @@
#define copysign _copysign
#endif
-/*
- * Define KILL_OCTAL to suppress interpretation of numbers with leading zero
- * as octal. (Ceterum censeo: numeros octonarios delendos esse.)
- */
+#ifndef PRIx64
+# define PRIx64 TCL_LL_MODIFIER "x"
+#endif
-#undef KILL_OCTAL
/*
* This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754
@@ -310,7 +308,7 @@ static double MakeNaN(int signum, Tcl_WideUInt tag);
#endif
static double RefineApproximation(double approx,
mp_int *exactSignificand, int exponent);
-static void MulPow5(mp_int *, unsigned, mp_int *);
+static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR;
static int NormalizeRightward(Tcl_WideUInt *);
static int RequiredPrecision(Tcl_WideUInt);
static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *,
@@ -332,36 +330,36 @@ static char * StrictQuickFormat(double, int, int, double,
static char * QuickConversion(double, int, int, int, int, int, int,
int *, char **);
static void CastOutPowersOf2(int *, int *, int *);
-static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt,
+static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt,
int, int, int, int, int, int, int, int, int,
int, int, int *, char **);
-static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt,
+static char * StrictInt64Conversion(Tcl_WideUInt,
int, int, int, int, int, int,
int, int, int *, char **);
static int ShouldBankerRoundUpPowD(mp_int *, int, int);
static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *,
- int, int, int, mp_int *);
+ int, int, mp_int *);
static char * ShorteningBignumConversionPowD(Double *dPtr,
- int convType, Tcl_WideUInt bw, int b2, int b5,
+ Tcl_WideUInt bw, int b2, int b5,
int m2plus, int m2minus, int m5,
int sd, int k, int len,
int ilim, int ilim1, int *decpt,
char **endPtr);
-static char * StrictBignumConversionPowD(Double *dPtr, int convType,
+static char * StrictBignumConversionPowD(
Tcl_WideUInt bw, int b2, int b5,
int sd, int k, int len,
int ilim, int ilim1, int *decpt,
char **endPtr);
static int ShouldBankerRoundUp(mp_int *, mp_int *, int);
static int ShouldBankerRoundUpToNext(mp_int *, mp_int *,
- mp_int *, int, int, mp_int *);
-static char * ShorteningBignumConversion(Double *dPtr, int convType,
+ mp_int *, int);
+static char * ShorteningBignumConversion(Double *dPtr,
Tcl_WideUInt bw, int b2,
int m2plus, int m2minus,
int s2, int s5, int k, int len,
int ilim, int ilim1, int *decpt,
char **endPtr);
-static char * StrictBignumConversion(Double *dPtr, int convType,
+static char * StrictBignumConversion(
Tcl_WideUInt bw, int b2,
int s2, int s5, int k, int len,
int ilim, int ilim1, int *decpt,
@@ -494,7 +492,7 @@ TclParseNumber(
{
enum State {
INITIAL, SIGNUM, ZERO, ZERO_X,
- ZERO_O, ZERO_B, BINARY,
+ ZERO_O, ZERO_B, ZERO_D, BINARY,
HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
LEADING_RADIX_POINT, FRACTION,
EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
@@ -541,6 +539,7 @@ TclParseNumber(
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
+ mp_err err = MP_OKAY;
#define MOST_BITS (UWIDE_MAX >> 1)
@@ -550,6 +549,20 @@ TclParseNumber(
*/
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)) {
+ int 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);
}
@@ -559,6 +572,87 @@ TclParseNumber(
acceptLen = len;
while (1) {
char c = len ? *p : '\0';
+
+ /*
+ * Filter out Numeric Whitespace. Expects:
+ *
+ * ::digit:: '_' ::digit::
+ *
+ * Verify current '_' is ok, then move on to next character,
+ * otherwise follow through on to error.
+ */
+ if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
+ const char *before, *after;
+
+ if (p==bytes) {
+ /* Not allowed at beginning */
+ goto endgame;
+ }
+ /*
+ * span multiple numeric whitespace
+ * V
+ * example: 5___6
+ */
+ for (before=(p-1);
+ (before && *before=='_');
+ before=(before>p ? (before-1):NULL));
+ for (after=(p+1);
+ (after && *after && *after=='_');
+ after=(*after&&*after=='_')?(after+1):NULL);
+
+ switch (state) {
+ case ZERO_B:
+ case BINARY:
+ if ((before && (*before != '0' && *before != '1')) ||
+ (after && (*after != '0' && *after != '1'))) {
+ /* Not a valid digit */
+ goto endgame;
+ }
+ break;
+ case ZERO_O:
+ case OCTAL:
+ if (((before && (*before < '0' || '7' < *before))) ||
+ ((after && (*after < '0' || '7' < *after)))) {
+ goto endgame;
+ }
+ break;
+ case FRACTION:
+ case ZERO:
+ case ZERO_D:
+ case DECIMAL:
+ case LEADING_RADIX_POINT:
+ case EXPONENT_START:
+ case EXPONENT_SIGNUM:
+ case EXPONENT:
+ if ((!before || isdigit(UCHAR(*before))) &&
+ (!after || isdigit(UCHAR(*after)))) {
+ break;
+ }
+ if (after && *after=='(') {
+ /* could be function */
+ goto continue_num;
+ }
+ goto endgame;
+ case ZERO_X:
+ case HEXADECIMAL:
+ if ( (!before || isxdigit(UCHAR(*before))) &&
+ (!after || isxdigit(UCHAR(*after)))) {
+ break;
+ }
+ goto endgame;
+ default:
+ /*
+ * Not whitespace, but could be legal for other reasons.
+ * Continue number processing for current character.
+ */
+ goto continue_num;
+ }
+
+ /* Valid whitespace found, move on to the next character */
+ goto next;
+ }
+
+ continue_num:
switch (state) {
case INITIAL:
@@ -647,7 +741,7 @@ TclParseNumber(
goto zeroo;
}
if (c == 'b' || c == 'B') {
- if (flags & TCL_PARSE_OCTAL_ONLY) {
+ if ((flags & TCL_PARSE_OCTAL_ONLY)) {
goto endgame;
}
state = ZERO_B;
@@ -661,7 +755,11 @@ TclParseNumber(
state = ZERO_O;
break;
}
-#ifdef KILL_OCTAL
+ if (c == 'd' || c == 'D') {
+ state = ZERO_D;
+ break;
+ }
+#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
@@ -704,7 +802,7 @@ TclParseNumber(
|| (octalSignificandWide >
(UWIDE_MAX >> shift)))) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
}
@@ -721,10 +819,17 @@ TclParseNumber(
}
octalSignificandWide += c - '0';
} else {
- mp_mul_2d(&octalSignificandBig, shift,
- &octalSignificandBig);
- mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
- &octalSignificandBig);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&octalSignificandBig, shift,
+ &octalSignificandBig);
+ }
+ if (err == MP_OKAY) {
+ err = mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
+ &octalSignificandBig);
+ }
+ }
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
}
}
if (numSigDigs != 0) {
@@ -753,7 +858,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -830,7 +935,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (UWIDE_MAX >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
@@ -846,11 +951,16 @@ TclParseNumber(
significandWide <<= shift;
}
significandWide += d;
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
- mp_add_d(&significandBig, (mp_digit) d, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
+ if (err == MP_OKAY) {
+ err = mp_add_d(&significandBig, (mp_digit) d, &significandBig);
+ }
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
numTrailZeros = 0;
state = HEXADECIMAL;
break;
@@ -882,7 +992,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (UWIDE_MAX >> shift))) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig,
+ err = mp_init_u64(&significandBig,
significandWide);
}
}
@@ -898,22 +1008,37 @@ TclParseNumber(
significandWide <<= shift;
}
significandWide += 1;
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
- mp_add_d(&significandBig, (mp_digit) 1, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
+ if (err == MP_OKAY) {
+ err = mp_add_d(&significandBig, (mp_digit) 1, &significandBig);
+ }
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
numTrailZeros = 0;
state = BINARY;
break;
+ case ZERO_D:
+ if (c == '0') {
+ numTrailZeros++;
+ } else if ( ! isdigit(UCHAR(c))) {
+ goto endgame;
+ }
+ state = DECIMAL;
+ flags |= TCL_PARSE_INTEGER_ONLY;
+ /* FALLTHROUGH */
+
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
@@ -1151,6 +1276,7 @@ TclParseNumber(
acceptLen = len;
goto endgame;
}
+ next:
p++;
len--;
}
@@ -1168,10 +1294,13 @@ TclParseNumber(
} else {
/*
* Back up to the last accepting state in the lexer.
+ * If the last char seen is the numeric whitespace character '_',
+ * backup to that.
*/
p = acceptPoint;
len = acceptLen;
+
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
@@ -1196,13 +1325,14 @@ TclParseNumber(
*/
if (status == TCL_OK && objPtr != NULL) {
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
switch (acceptState) {
case SIGNUM:
case BAD_OCTAL:
case ZERO_X:
case ZERO_O:
case ZERO_B:
+ case ZERO_D:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
@@ -1226,7 +1356,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
@@ -1239,10 +1369,13 @@ TclParseNumber(
if (significandWide != 0) {
significandWide <<= shift;
}
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto returnInteger;
case HEXADECIMAL:
@@ -1255,7 +1388,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
@@ -1268,10 +1401,13 @@ TclParseNumber(
if (significandWide != 0) {
significandWide <<= shift;
}
- } else {
- mp_mul_2d(&significandBig, shift, &significandBig);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
goto returnInteger;
case OCTAL:
@@ -1284,7 +1420,7 @@ TclParseNumber(
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
octalSignificandWide > (MOST_BITS + signum) >> shift)) {
octalSignificandOverflow = 1;
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
if (shift) {
@@ -1298,94 +1434,72 @@ TclParseNumber(
if (octalSignificandWide != 0) {
octalSignificandWide <<= shift;
}
- } else {
- mp_mul_2d(&octalSignificandBig, shift,
+ } else if (err == MP_OKAY) {
+ err = mp_mul_2d(&octalSignificandBig, shift,
&octalSignificandBig);
}
}
if (!octalSignificandOverflow) {
- if (octalSignificandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (octalSignificandWide <= (MOST_BITS + signum)) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) (-octalSignificandWide);
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) octalSignificandWide;
- }
- break;
- }
-#endif
- TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
+ err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- (long) (-octalSignificandWide);
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)(-octalSignificandWide);
} else {
- objPtr->internalRep.longValue =
- (long) octalSignificandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)octalSignificandWide;
}
}
}
- if (octalSignificandOverflow) {
+ if ((err == MP_OKAY) && octalSignificandOverflow) {
if (signum) {
- (void)mp_neg(&octalSignificandBig, &octalSignificandBig);
+ err = mp_neg(&octalSignificandBig, &octalSignificandBig);
}
TclSetBignumInternalRep(objPtr, &octalSignificandBig);
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
break;
case ZERO:
case DECIMAL:
significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
&significandWide, &significandBig, significandOverflow);
- if (!significandOverflow && (significandWide > MOST_BITS+signum)) {
+ if ((err == MP_OKAY) && !significandOverflow && (significandWide > MOST_BITS+signum)) {
significandOverflow = 1;
- TclBNInitBignumFromWideUInt(&significandBig, significandWide);
+ err = mp_init_u64(&significandBig, significandWide);
}
returnInteger:
if (!significandOverflow) {
- if (significandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (significandWide <= MOST_BITS+signum) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) (-significandWide);
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) significandWide;
- }
- break;
- }
-#endif
- TclBNInitBignumFromWideUInt(&significandBig,
+ if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
+ err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- (long) (-significandWide);
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)(-significandWide);
} else {
- objPtr->internalRep.longValue =
- (long) significandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt)significandWide;
}
}
}
- if (significandOverflow) {
+ if ((err == MP_OKAY) && significandOverflow) {
if (signum) {
- (void)mp_neg(&significandBig, &significandBig);
+ err = mp_neg(&significandBig, &significandBig);
}
TclSetBignumInternalRep(objPtr, &significandBig);
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
break;
case FRACTION:
@@ -1481,7 +1595,7 @@ TclParseNumber(
Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1);
}
Tcl_SetObjResult(interp, msg);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL);
}
}
@@ -1550,7 +1664,9 @@ AccumulateDecimalDigit(
* bignum and fall through into the bignum case.
*/
- TclBNInitBignumFromWideUInt(bignumRepPtr, w);
+ if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
+ return 0;
+ }
} else {
/*
* Wide multiplication.
@@ -1570,10 +1686,12 @@ AccumulateDecimalDigit(
* Up to about 8 zeros - single digit multiplication.
*/
- mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
- bignumRepPtr);
- mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr);
+ if ((mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
+ bignumRepPtr) != MP_OKAY)
+ || (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY))
+ return 0;
} else {
+ mp_err err;
/*
* More than single digit multiplication. Multiply by the appropriate
* small powers of 5, and then shift. Large strings of zeroes are
@@ -1584,18 +1702,21 @@ AccumulateDecimalDigit(
*/
n = numZeros + 1;
- mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
- for (i=3; i<=7; ++i) {
+ err = mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
+ for (i = 3; (err == MP_OKAY) && (i <= 7); ++i) {
if (n & (1 << i)) {
- mp_mul(bignumRepPtr, pow5+i, bignumRepPtr);
+ err = mp_mul(bignumRepPtr, pow5+i, bignumRepPtr);
}
}
- while (n >= 256) {
- mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
+ while ((err == MP_OKAY) && (n >= 256)) {
+ err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
n -= 256;
}
- mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr);
- mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr);
+ if ((err != MP_OKAY)
+ || (mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr) != MP_OKAY)
+ || (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
+ return 0;
+ }
}
return 1;
@@ -1704,7 +1825,9 @@ MakeLowPrecisionDouble(
* call MakeHighPrecisionDouble to do it the hard way.
*/
- TclBNInitBignumFromWideUInt(&significandBig, significand);
+ if (mp_init_u64(&significandBig, significand) != MP_OKAY) {
+ return 0.0;
+ }
retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
exponent);
mp_clear(&significandBig);
@@ -1754,7 +1877,7 @@ MakeHighPrecisionDouble(
{
TCL_IEEE_DOUBLE_ROUNDING_DECL
- int machexp; /* Machine exponent of a power of 10. */
+ int machexp = 0; /* Machine exponent of a power of 10. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
@@ -1930,6 +2053,7 @@ RefineApproximation(
Tcl_WideInt rteSigWide; /* Wide integer version of the significand
* for testing evenness */
int i;
+ mp_err err = MP_OKAY;
/*
* The first approximation is always low. If we find that it's HUGE_VAL,
@@ -1978,7 +2102,9 @@ RefineApproximation(
msb = binExponent + M2; /* 1008 */
nDigits = msb / MP_DIGIT_BIT + 1;
- mp_init_size(&twoMv, nDigits);
+ if (mp_init_size(&twoMv, nDigits) != MP_OKAY) {
+ return approxResult;
+ }
i = (msb % MP_DIGIT_BIT + 1);
twoMv.used = nDigits;
significand *= SafeLdExp(1.0, i);
@@ -1988,8 +2114,9 @@ RefineApproximation(
significand = SafeLdExp(significand, MP_DIGIT_BIT);
}
for (i = 0; i <= 8; ++i) {
- if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ if (M5 & (1 << i) && (mp_mul(&twoMv, pow5+i, &twoMv) != MP_OKAY)) {
+ mp_clear(&twoMv);
+ return approxResult;
}
}
@@ -1999,20 +2126,27 @@ RefineApproximation(
* by 2**(M5+exponent+1), which is, of course, a left shift.
*/
- mp_init_copy(&twoMd, exactSignificand);
- for (i=0; i<=8; ++i) {
+ if (mp_init_copy(&twoMd, exactSignificand) != MP_OKAY) {
+ mp_clear(&twoMv);
+ return approxResult;
+ }
+ for (i = 0; (i <= 8); ++i) {
if ((M5 + exponent) & (1 << i)) {
- mp_mul(&twoMd, pow5+i, &twoMd);
+ err = mp_mul(&twoMd, pow5+i, &twoMd);
}
}
- mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
+ }
/*
* Now let twoMd = twoMd - twoMv, the difference between the exact and
* approximate values.
*/
- mp_sub(&twoMd, &twoMv, &twoMd);
+ if (err == MP_OKAY) {
+ err = mp_sub(&twoMd, &twoMv, &twoMd);
+ }
/*
* The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
@@ -2022,17 +2156,26 @@ RefineApproximation(
*/
scale = binExponent - mantBits - 1;
- mp_set(&twoMv, 1);
- for (i=0; i<=8; ++i) {
+ mp_set_u64(&twoMv, 1);
+ for (i = 0; (i <= 8) && (err == MP_OKAY); ++i) {
if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ err = mp_mul(&twoMv, pow5+i, &twoMv);
}
}
multiplier = M2 + scale + 1;
- if (multiplier > 0) {
- mp_mul_2d(&twoMv, multiplier, &twoMv);
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
+ } else if (multiplier > 0) {
+ err = mp_mul_2d(&twoMv, multiplier, &twoMv);
} else if (multiplier < 0) {
- mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
+ err = mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
+ }
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
}
/*
@@ -2067,7 +2210,7 @@ RefineApproximation(
*/
if (roundToEven) {
rteSignificand = frexp(approxResult, &rteExponent);
- rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION);
+ rteSigWide = (Tcl_WideInt)ldexp(rteSignificand, FP_PRECISION);
if ((rteSigWide & 1) == 0) {
mp_clear(&twoMd);
mp_clear(&twoMv);
@@ -2081,8 +2224,15 @@ RefineApproximation(
*/
shift = mp_count_bits(&twoMv) - FP_PRECISION - 1;
if (shift > 0) {
- mp_div_2d(&twoMv, shift, &twoMv, NULL);
- mp_div_2d(&twoMd, shift, &twoMd, NULL);
+ err = mp_div_2d(&twoMv, shift, &twoMv, NULL);
+ if (err == MP_OKAY) {
+ err = mp_div_2d(&twoMd, shift, &twoMd, NULL);
+ }
+ }
+ if (err != MP_OKAY) {
+ mp_clear(&twoMd);
+ mp_clear(&twoMv);
+ return approxResult;
}
/*
@@ -2121,7 +2271,7 @@ RefineApproximation(
*----------------------------------------------------------------------
*/
-static inline void
+static inline mp_err
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
@@ -2130,23 +2280,25 @@ MulPow5(
mp_int *p = base;
int n13 = n / 13;
int r = n % 13;
+ mp_err err = MP_OKAY;
if (r != 0) {
- mp_mul_d(p, dpow5[r], result);
+ err = mp_mul_d(p, dpow5[r], result);
p = result;
}
r = 0;
- while (n13 != 0) {
+ while ((err == MP_OKAY) && (n13 != 0)) {
if (n13 & 1) {
- mp_mul(p, pow5_13+r, result);
+ err = mp_mul(p, pow5_13+r, result);
p = result;
}
n13 >>= 1;
++r;
}
- if (p != result) {
- mp_copy(p, result);
+ if ((err == MP_OKAY) && (p != result)) {
+ err = mp_copy(p, result);
}
+ return err;
}
/*
@@ -2346,13 +2498,13 @@ FormatInfAndNaN(
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
- retval = ckalloc(9);
+ retval = (char *)ckalloc(9);
strcpy(retval, "Infinity");
if (endPtr) {
*endPtr = retval + 8;
}
} else {
- retval = ckalloc(4);
+ retval = (char *)ckalloc(4);
strcpy(retval, "NaN");
if (endPtr) {
*endPtr = retval + 3;
@@ -2383,7 +2535,7 @@ FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
- char *retval = ckalloc(2);
+ char *retval = (char *)ckalloc(2);
strcpy(retval, "0");
if (endPtr) {
@@ -2564,9 +2716,8 @@ ComputeScale(
static inline void
SetPrecisionLimits(
- int convType, /* Type of conversion: TCL_DD_SHORTEST,
- * TCL_DD_STEELE0, TCL_DD_E_FMT,
- * TCL_DD_F_FMT. */
+ int flags, /* Type of conversion: TCL_DD_SHORTEST,
+ * TCL_DD_E_FMT, TCL_DD_F_FMT. */
int k, /* Floor(log10(number to convert)) */
int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be
* adjusted if needed). */
@@ -2576,13 +2727,7 @@ SetPrecisionLimits(
int *iLim1Ptr) /* OUT: Number of digits of significance if
* the quick method is used. */
{
- switch (convType) {
- case TCL_DD_SHORTEST0:
- case TCL_DD_STEELE0:
- *iLimPtr = *iLim1Ptr = -1;
- *iPtr = 18;
- *ndigitsPtr = 0;
- break;
+ switch (flags & TCL_DD_CONVERSION_TYPE_MASK) {
case TCL_DD_E_FORMAT:
if (*ndigitsPtr <= 0) {
*ndigitsPtr = 1;
@@ -2598,10 +2743,10 @@ SetPrecisionLimits(
}
break;
default:
- *iPtr = -1;
- *iLimPtr = -1;
- *iLim1Ptr = -1;
- Tcl_Panic("impossible conversion type in TclDoubleDigits");
+ *iLimPtr = *iLim1Ptr = -1;
+ *iPtr = 18;
+ *ndigitsPtr = 0;
+ break;
}
}
@@ -2885,7 +3030,7 @@ QuickConversion(
int k, /* floor(log10(d)), approximately. */
int k_check, /* 0 if k is exact, 1 if it may be too high */
int flags, /* Flags passed to dtoa:
- * TCL_DD_SHORTEN_FLAG */
+ * TCL_DD_SHORTEST */
int len, /* Length of the return value. */
int ilim, /* Number of digits to store. */
int ilim1, /* Number of digits to store if we misguessed
@@ -2936,7 +3081,7 @@ QuickConversion(
* Handle the peculiar case where the result has no significant digits.
*/
- retval = ckalloc(len + 1);
+ retval = (char *)ckalloc(len + 1);
if (ilim == 0) {
d = d - 5.;
if (d > eps.d) {
@@ -2956,7 +3101,7 @@ QuickConversion(
* Format the digit string.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt);
} else {
end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt);
@@ -3031,8 +3176,6 @@ CastOutPowersOf2(
static inline char *
ShorteningInt64Conversion(
Double *dPtr, /* Original number to convert. */
- int convType, /* Type of conversion (shortest, Steele,
- * E format, F format). */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
@@ -3049,7 +3192,7 @@ ShorteningInt64Conversion(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
@@ -3099,7 +3242,7 @@ ShorteningInt64Conversion(
*/
if (b < mplus || (b == mplus
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
+ && (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
@@ -3128,7 +3271,7 @@ ShorteningInt64Conversion(
*/
if (b > S - mminus || (b == S - mminus
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
+ && (dPtr->w.word1 & 1) == 0)) {
if (digit == 9) {
*s++ = '9';
s = BumpUp(s, retval, &k);
@@ -3199,9 +3342,6 @@ ShorteningInt64Conversion(
static inline char *
StrictInt64Conversion(
- Double *dPtr, /* Original number to convert. */
- int convType, /* Type of conversion (shortest, Steele,
- * E format, F format). */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
@@ -3215,7 +3355,7 @@ StrictInt64Conversion(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
@@ -3346,9 +3486,6 @@ ShouldBankerRoundUpToNextPowD(
mp_int *b, /* Numerator of the fraction. */
mp_int *m, /* Numerator of the rounding tolerance. */
int sd, /* Common denominator is 2**(sd*MP_DIGIT_BIT). */
- int convType, /* Conversion type: STEELE defeats
- * round-to-even (not sure why one wants to do
- * this; I copied it from Gay). FIXME */
int isodd, /* 1 if the integer significand is odd. */
mp_int *temp) /* Work area for the calculation. */
{
@@ -3360,8 +3497,7 @@ ShouldBankerRoundUpToNextPowD(
* 2**(MP_DIGIT_BIT*sd)
*/
- mp_add(b, m, temp);
- if (temp->used <= sd) { /* Too few digits to be > s */
+ if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) { /* Too few digits to be > s */
return 0;
}
if (temp->used > sd+1 || temp->dp[sd] > 1) {
@@ -3374,10 +3510,6 @@ ShouldBankerRoundUpToNextPowD(
return 1;
}
}
- if (convType == TCL_DD_STEELE0) {
- /* Biased rounding. */
- return 0;
- }
return isodd;
}
@@ -3407,8 +3539,6 @@ ShouldBankerRoundUpToNextPowD(
static inline char *
ShorteningBignumConversionPowD(
Double *dPtr, /* Original number to convert. */
- int convType, /* Type of conversion (shortest, Steele,
- * E format, F format). */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
@@ -3425,7 +3555,7 @@ ShorteningBignumConversionPowD(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
@@ -3435,23 +3565,31 @@ ShorteningBignumConversionPowD(
int i; /* Index in the output buffer. */
mp_int temp;
int r1;
+ mp_err err = MP_OKAY;
/*
* b = bw * 2**b2 * 5**b5
* mminus = 5**m5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_init_set(&mminus, 1);
- MulPow5(&b, b5, &b);
- mp_mul_2d(&b, b2, &b);
+ if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
+ return NULL;
+ }
+ if (mp_init_set(&mminus, 1) != MP_OKAY) {
+ mp_clear(&b);
+ return NULL;
+ }
+ err = MulPow5(&b, b5, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, b2, &b);
+ }
/*
* Adjust if the logarithm was guessed wrong.
*/
- if (b.used <= sd) {
- mp_mul_d(&b, 10, &b);
+ if ((err == MP_OKAY) && (b.used <= sd)) {
+ err = mp_mul_d(&b, 10, &b);
++m2plus; ++m2minus; ++m5;
ilim = ilim1;
--k;
@@ -3462,13 +3600,21 @@ ShorteningBignumConversionPowD(
* mplus = 5**m5 * 2**m2plus
*/
- mp_mul_2d(&mminus, m2minus, &mminus);
- MulPow5(&mminus, m5, &mminus);
- if (m2plus > m2minus) {
- mp_init_copy(&mplus, &mminus);
- mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, m2minus, &mminus);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&mminus, m5, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_init_copy(&mplus, &mminus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ }
+ }
+ if (err == MP_OKAY) {
+ err = mp_init(&temp);
}
- mp_init(&temp);
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
@@ -3494,7 +3640,7 @@ ShorteningBignumConversionPowD(
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
if (r1 == MP_LT || (r1 == MP_EQ
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
+ && (dPtr->w.word1 & 1) == 0)) {
/*
* Make sure we shouldn't be rounding *up* instead, in case the
* next number above is closer.
@@ -3522,7 +3668,7 @@ ShorteningBignumConversionPowD(
* number?
*/
- if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType,
+ if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd,
dPtr->w.word1 & 1, &temp)) {
if (digit == 9) {
*s++ = '9';
@@ -3550,10 +3696,14 @@ ShorteningBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
- mp_mul_d(&mminus, 10, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mminus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&b, 10, &b);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&mminus, 10, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mminus, m2plus-m2minus, &mplus);
}
++i;
}
@@ -3566,13 +3716,13 @@ ShorteningBignumConversionPowD(
if (m2plus > m2minus) {
mp_clear(&mplus);
}
- mp_clear_multi(&b, &mminus, &temp, NULL);
+ mp_clear_multi(&b, &mminus, &temp, (void *)NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
*endPtr = s;
}
- return retval;
+ return (err == MP_OKAY) ? retval : NULL;
}
/*
@@ -3599,9 +3749,6 @@ ShorteningBignumConversionPowD(
static inline char *
StrictBignumConversionPowD(
- Double *dPtr, /* Original number to convert. */
- int convType, /* Type of conversion (shortest, Steele,
- * E format, F format). */
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
@@ -3615,33 +3762,36 @@ StrictBignumConversionPowD(
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
- char *retval = ckalloc(len + 1);
+ char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
mp_digit digit; /* Current output digit. */
char *s = retval; /* Cursor in the output buffer. */
int i; /* Index in the output buffer. */
- mp_int temp;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- MulPow5(&b, b5, &b);
- mp_mul_2d(&b, b2, &b);
+ if (mp_init_u64(&b, bw) != MP_OKAY) {
+ return NULL;
+ }
+ err = MulPow5(&b, b5, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, b2, &b);
+ }
/*
* Adjust if the logarithm was guessed wrong.
*/
- if (b.used <= sd) {
- mp_mul_d(&b, 10, &b);
+ if ((err == MP_OKAY) && (b.used <= sd)) {
+ err = mp_mul_d(&b, 10, &b);
ilim = ilim1;
--k;
}
- mp_init(&temp);
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
@@ -3649,7 +3799,7 @@ StrictBignumConversionPowD(
*/
i = 1;
- for (;;) {
+ while (err == MP_OKAY) {
if (b.used <= sd) {
digit = 0;
} else {
@@ -3681,7 +3831,7 @@ StrictBignumConversionPowD(
* Advance to the next digit.
*/
- mp_mul_d(&b, 10, &b);
+ err = mp_mul_d(&b, 10, &b);
++i;
}
@@ -3690,7 +3840,7 @@ StrictBignumConversionPowD(
* string.
*/
- mp_clear_multi(&b, &temp, NULL);
+ mp_clear(&b);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -3723,15 +3873,13 @@ ShouldBankerRoundUp(
int r = mp_cmp_mag(twor, S);
switch (r) {
- case MP_LT:
- return 0;
case MP_EQ:
return isodd;
case MP_GT:
return 1;
+ default:
+ return 0;
}
- Tcl_Panic("in ShouldBankerRoundUp, trichotomy fails!");
- return 0;
}
/*
@@ -3754,34 +3902,28 @@ ShouldBankerRoundUpToNext(
* the last digit. */
mp_int *m, /* Numerator of the rounding tolerance. */
mp_int *S, /* Denominator. */
- int convType, /* Conversion type: STEELE0 defeats
- * round-to-even. (Not sure why one would want
- * this; I coped it from Gay). FIXME */
- int isodd, /* 1 if the integer significand is odd. */
- mp_int *temp) /* Work area needed for the calculation. */
+ int isodd) /* 1 if the integer significand is odd. */
{
int r;
+ mp_int temp;
/*
* Compare b and S-m: this is the same as comparing B+m and S.
*/
- mp_add(b, m, temp);
- r = mp_cmp_mag(temp, S);
- switch(r) {
- case MP_LT:
+ if ((mp_init(&temp) != MP_OKAY) || (mp_add(b, m, &temp) != MP_OKAY)) {
return 0;
+ }
+ r = mp_cmp_mag(&temp, S);
+ mp_clear(&temp);
+ switch(r) {
case MP_EQ:
- if (convType == TCL_DD_STEELE0) {
- return 0;
- } else {
- return isodd;
- }
+ return isodd;
case MP_GT:
return 1;
+ default:
+ return 0;
}
- Tcl_Panic("in ShouldBankerRoundUpToNext, trichotomy fails!");
- return 0;
}
/*
@@ -3805,7 +3947,6 @@ ShouldBankerRoundUpToNext(
static inline char *
ShorteningBignumConversion(
Double *dPtr, /* Original number being converted. */
- int convType, /* Conversion type. */
Tcl_WideUInt bw, /* Integer significand and exponent. */
int b2, /* Scale factor for the significand. */
int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */
@@ -3817,7 +3958,7 @@ ShorteningBignumConversion(
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char *retval = ckalloc(len+1);
+ char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
@@ -3826,27 +3967,36 @@ ShorteningBignumConversion(
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
- mp_int temp; /* Work area. */
int minit = 1; /* Fudge factor for when we misguess k. */
int i;
int r1;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_mul_2d(&b, b2, &b);
- mp_init_set(&S, 1);
- MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
+ if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
+ return NULL;
+ }
+ err = mp_mul_2d(&b, b2, &b);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&S, 1);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&S, s5, &S);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&S, s2, &S);
+ }
/*
* Handle the case where we guess the position of the decimal point wrong.
*/
- if (mp_cmp_mag(&b, &S) == MP_LT) {
- mp_mul_d(&b, 10, &b);
+ if ((err == MP_OKAY) && (mp_cmp_mag(&b, &S) == MP_LT)) {
+ err = mp_mul_d(&b, 10, &b);
minit = 10;
ilim =ilim1;
--k;
@@ -3856,22 +4006,29 @@ ShorteningBignumConversion(
* mminus = 2**m2minus * 5**m5
*/
- mp_init_set(&mminus, minit);
- mp_mul_2d(&mminus, m2minus, &mminus);
- if (m2plus > m2minus) {
- mp_init_copy(&mplus, &mminus);
- mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&mminus, minit);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, m2minus, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_init_copy(&mplus, &mminus);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
+ }
}
- mp_init(&temp);
/*
* Loop through the digits.
*/
- mp_init(&dig);
+ if (err == MP_OKAY) {
+ err = mp_init(&dig);
+ }
i = 1;
- for (;;) {
- mp_div(&b, &S, &dig, &b);
+ while (err == MP_OKAY) {
+ err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
@@ -3883,9 +4040,8 @@ ShorteningBignumConversion(
*/
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
- if (r1 == MP_LT || (r1 == MP_EQ
- && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) {
- mp_mul_2d(&b, 1, &b);
+ if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) {
+ err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
++digit;
if (digit == 10) {
@@ -3903,8 +4059,8 @@ ShorteningBignumConversion(
* commit to rounding up to the next higher digit?
*/
- if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType,
- dPtr->w.word1 & 1, &temp)) {
+ if (ShouldBankerRoundUpToNext(&b, &mminus, &S,
+ dPtr->w.word1 & 1)) {
++digit;
if (digit == 10) {
*s++ = '9';
@@ -3920,8 +4076,8 @@ ShorteningBignumConversion(
*/
*s++ = '0' + digit;
- if (i == ilim) {
- mp_mul_2d(&b, 1, &b);
+ if ((err == MP_OKAY) && (i == ilim)) {
+ err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
@@ -3932,17 +4088,21 @@ ShorteningBignumConversion(
* Advance to the next digit.
*/
- if (s5 > 0) {
+ if ((err == MP_OKAY) && (s5 > 0)) {
/*
* Can possibly shorten the denominator.
*/
- mp_mul_2d(&b, 1, &b);
- mp_mul_2d(&mminus, 1, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mplus, 1, &mplus);
+ err = mp_mul_2d(&b, 1, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&mminus, 1, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mplus, 1, &mplus);
+ }
+ if (err == MP_OKAY) {
+ err = mp_div_d(&S, 5, &S, NULL);
}
- mp_div_d(&S, 5, &S, NULL);
--s5;
/*
@@ -3972,11 +4132,13 @@ ShorteningBignumConversion(
* 10**42 16 trips
* thereafter no gain.
*/
- } else {
- mp_mul_d(&b, 10, &b);
- mp_mul_d(&mminus, 10, &mminus);
- if (m2plus > m2minus) {
- mp_mul_2d(&mplus, 10, &mplus);
+ } else if (err == MP_OKAY) {
+ err = mp_mul_d(&b, 10, &b);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&mminus, 10, &mminus);
+ }
+ if ((err == MP_OKAY) && (m2plus > m2minus)) {
+ err = mp_mul_2d(&mplus, 10, &mplus);
}
}
@@ -3991,7 +4153,7 @@ ShorteningBignumConversion(
if (m2plus > m2minus) {
mp_clear(&mplus);
}
- mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL);
+ mp_clear_multi(&b, &mminus, &dig, &S, (void *)NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4020,8 +4182,6 @@ ShorteningBignumConversion(
static inline char *
StrictBignumConversion(
- Double *dPtr, /* Original number being converted. */
- int convType, /* Conversion type. */
Tcl_WideUInt bw, /* Integer significand and exponent. */
int b2, /* Scale factor for the significand. */
int s2, int s5, /* Scale factors for denominator. */
@@ -4032,34 +4192,45 @@ StrictBignumConversion(
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
- char *retval = ckalloc(len+1);
+ char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
- mp_int temp; /* Work area. */
int g; /* Size of the current digit ground. */
int i, j;
+ mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
- mp_init_multi(&temp, &dig, NULL);
- TclBNInitBignumFromWideUInt(&b, bw);
- mp_mul_2d(&b, b2, &b);
- mp_init_set(&S, 1);
- MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S);
+ if (mp_init(&dig) != MP_OKAY) {
+ return NULL;
+ }
+ if (mp_init_u64(&b, bw) != MP_OKAY) {
+ mp_clear(&dig);
+ return NULL;
+ }
+ err = mp_mul_2d(&b, b2, &b);
+ if (err == MP_OKAY) {
+ err = mp_init_set(&S, 1);
+ }
+ if (err == MP_OKAY) {
+ err = MulPow5(&S, s5, &S);
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&S, s2, &S);
+ }
+ }
/*
* Handle the case where we guess the position of the decimal point wrong.
*/
- if (mp_cmp_mag(&b, &S) == MP_LT) {
- mp_mul_d(&b, 10, &b);
+ if ((mp_cmp_mag(&b, &S) == MP_LT) && (mp_mul_d(&b, 10, &b) == MP_OKAY)) {
ilim =ilim1;
--k;
}
@@ -4069,7 +4240,7 @@ StrictBignumConversion(
*/
i = 0;
- mp_div(&b, &S, &dig, &b);
+ err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
@@ -4081,12 +4252,11 @@ StrictBignumConversion(
*s++ = '0' + digit;
if (++i >= ilim) {
- mp_mul_2d(&b, 1, &b);
- if (ShouldBankerRoundUp(&b, &S, digit&1)) {
+ if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
} else {
- for (;;) {
+ while (err == MP_OKAY) {
/*
* Shift by a group of digits.
*/
@@ -4096,16 +4266,20 @@ StrictBignumConversion(
g = DIGIT_GROUP;
}
if (s5 >= g) {
- mp_div_d(&S, dpow5[g], &S, NULL);
+ err = mp_div_d(&S, dpow5[g], &S, NULL);
s5 -= g;
} else if (s5 > 0) {
- mp_div_d(&S, dpow5[s5], &S, NULL);
- mp_mul_d(&b, dpow5[g - s5], &b);
+ err = mp_div_d(&S, dpow5[s5], &S, NULL);
+ if (err == MP_OKAY) {
+ err = mp_mul_d(&b, dpow5[g - s5], &b);
+ }
s5 = 0;
} else {
- mp_mul_d(&b, dpow5[g], &b);
+ err = mp_mul_d(&b, dpow5[g], &b);
+ }
+ if (err == MP_OKAY) {
+ err = mp_mul_2d(&b, g, &b);
}
- mp_mul_2d(&b, g, &b);
/*
* As with the shortening bignum conversion, it's possible at this
@@ -4119,8 +4293,8 @@ StrictBignumConversion(
* Extract the next group of digits.
*/
- mp_div(&b, &S, &dig, &b);
- if (dig.used > 1) {
+
+ if ((err != MP_OKAY) || (mp_div(&b, &S, &dig, &b) != MP_OKAY) || (dig.used > 1)) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
@@ -4137,8 +4311,7 @@ StrictBignumConversion(
*/
if (i == ilim) {
- mp_mul_2d(&b, 1, &b);
- if (ShouldBankerRoundUp(&b, &S, digit&1)) {
+ if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
break;
@@ -4155,7 +4328,7 @@ StrictBignumConversion(
* string.
*/
- mp_clear_multi(&b, &S, &temp, &dig, NULL);
+ mp_clear_multi(&b, &S, &dig, (void *)NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
@@ -4191,22 +4364,13 @@ StrictBignumConversion(
* For floating point numbers that are exactly between two
* decimal numbers, it resolves using the 'round to even' rule.
* With this value, the 'ndigits' parameter is ignored.
- * TCL_DD_STEELE - This value is not recommended and may be removed in
- * the future. It follows the conversion algorithm outlined in
- * "How to Print Floating-Point Numbers Accurately" by Guy
- * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90,
- * pp. 112-126]. This rule has the effect of rendering 1e23 as
- * 9.9999999999999999e22 - which is a 'better' approximation in
- * the sense that it will reconvert correctly even if a
- * subsequent input conversion is 'round up' or 'round down'
- * rather than 'round to nearest', but is surprising otherwise.
* TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format
* conversion (or for default floating->string if tcl_precision
* is not 0). It constructs a string of at most 'ndigits' digits,
* choosing the one that is closest to the given number (and
* resolving ties with 'round to even'). It is allowed to return
* fewer than 'ndigits' if the number converts exactly; if the
- * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it
+ * TCL_DD_E_FORMAT|TCL_DD_SHORTEST is supplied instead, it
* also returns fewer digits if the shorter string will still
* reconvert without loss to the given input number. In any case,
* strings of trailing zeroes are suppressed.
@@ -4217,7 +4381,7 @@ StrictBignumConversion(
* string if the number is sufficiently small. Again, it is
* permissible for TCL_DD_F_FORMAT to return fewer digits for a
* number that converts exactly, and changing the argument to
- * TCL_DD_F_FORMAT|TCL_DD_SHORTEN_FLAG will allow the routine
+ * TCL_DD_F_FORMAT|TCL_DD_SHORTEST will allow the routine
* also to return fewer digits if the shorter string will still
* reconvert without loss to the given input number. Strings of
* trailing zeroes are suppressed.
@@ -4250,10 +4414,6 @@ TclDoubleDigits(
* one character beyond the end of the
* returned string. */
{
- int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK);
- /* Type of conversion being performed:
- * TCL_DD_SHORTEST0, TCL_DD_STEELE0,
- * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */
Double d; /* Union for deconstructing doubles. */
Tcl_WideUInt bw; /* Integer significand. */
int be; /* Power of 2 by which b must be multiplied */
@@ -4321,18 +4481,18 @@ TclDoubleDigits(
* Correct an incorrect caller-supplied 'ndigits'. Also determine:
* i = The maximum number of decimal digits that will be returned in the
* formatted string. This is k + 1 + ndigits for F format, 18 for
- * shortest and Steele, and ndigits for E format.
+ * shortest, and ndigits for E format.
* ilim = The number of significant digits to convert if k has been
- * guessed correctly. This is -1 for shortest and Steele (which
+ * guessed correctly. This is -1 for shortest (which
* stop when all significance has been lost), 'ndigits' for E
* format, and 'k + 1 + ndigits' for F format.
* ilim1 = The minimum number of significant digits to convert if k has
- * been guessed 1 too high. This, too, is -1 for shortest and
- * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F
+ * been guessed 1 too high. This, too, is -1 for shortest,
+ * and 'ndigits' for E format, but it's 'ndigits-1' for F
* format.
*/
- SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1);
+ SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1);
/*
* Try to do low-precision conversion in floating point rather than
@@ -4358,7 +4518,7 @@ TclDoubleDigits(
* denominator.
*/
- if (flags & TCL_DD_SHORTEN_FLAG) {
+ if (flags & TCL_DD_SHORTEST) {
int m2minus = b2;
int m2plus;
int m5 = b5;
@@ -4405,7 +4565,7 @@ TclDoubleDigits(
* [1.0e-3 .. 1.0e+24]).
*/
- return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus,
+ return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus,
m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
@@ -4424,7 +4584,7 @@ TclDoubleDigits(
m2minus += delta;
s2 += delta;
}
- return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5,
+ return ShorteningBignumConversionPowD(&d, bw, b2, b5,
m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1,
decpt, endPtr);
} else {
@@ -4433,7 +4593,7 @@ TclDoubleDigits(
* arithmetic for the conversion.
*/
- return ShorteningBignumConversion(&d, convType, bw, b2, m2plus,
+ return ShorteningBignumConversion(&d, bw, b2, m2plus,
m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
}
} else {
@@ -4461,7 +4621,7 @@ TclDoubleDigits(
* operations.
*/
- return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k,
+ return StrictInt64Conversion(bw, b2, b5, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
@@ -4478,7 +4638,7 @@ TclDoubleDigits(
b2 += delta;
s2 += delta;
}
- return StrictBignumConversionPowD(&d, convType, bw, b2, b5,
+ return StrictBignumConversionPowD(bw, b2, b5,
s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
@@ -4488,7 +4648,7 @@ TclDoubleDigits(
* fewer mp_int divisions.
*/
- return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k,
+ return StrictBignumConversion(bw, b2, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
}
}
@@ -4526,6 +4686,7 @@ TclInitDoubleConversion(void)
Tcl_WideUInt iv;
} bitwhack;
#endif
+ mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
@@ -4582,16 +4743,19 @@ TclInitDoubleConversion(void)
*/
for (i=0; i<9; ++i) {
- mp_init(pow5 + i);
+ err = err || mp_init(pow5 + i);
}
- mp_set(pow5, 5);
+ mp_set_u64(pow5, 5);
for (i=0; i<8; ++i) {
- mp_sqr(pow5+i, pow5+i+1);
+ err = err || mp_sqr(pow5+i, pow5+i+1);
}
- mp_init_set_int(pow5_13, 1220703125);
+ err = err || mp_init_u64(pow5_13, 1220703125);
for (i = 1; i < 5; ++i) {
- mp_init(pow5_13 + i);
- mp_sqr(pow5_13 + i - 1, pow5_13 + i);
+ err = err || mp_init(pow5_13 + i);
+ err = err || mp_sqr(pow5_13 + i - 1, pow5_13 + i);
+ }
+ if (err != MP_OKAY) {
+ Tcl_Panic("out of memory");
}
/*
@@ -4679,40 +4843,47 @@ int
Tcl_InitBignumFromDouble(
Tcl_Interp *interp, /* For error message. */
double d, /* Number to convert. */
- mp_int *b) /* Place to store the result. */
+ void *big) /* Place to store the result. */
{
double fract;
int expt;
+ mp_err err;
+ mp_int *b = (mp_int *)big;
/*
* Infinite values can't convert to bignum.
*/
- if (TclIsInfinite(d)) {
+ if (isinf(d)) {
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);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (void *)NULL);
}
return TCL_ERROR;
}
- fract = frexp(d,&expt);
+ fract = frexp(d, &expt);
if (expt <= 0) {
- mp_init(b);
+ err = mp_init(b);
mp_zero(b);
} else {
- Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
+ Tcl_WideInt w = (Tcl_WideInt)ldexp(fract, mantBits);
int shift = expt - mantBits;
- TclBNInitBignumFromWideInt(b, w);
- if (shift < 0) {
- mp_div_2d(b, -shift, b, NULL);
+ err = mp_init_i64(b, w);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift < 0) {
+ err = mp_div_2d(b, -shift, b, NULL);
} else if (shift > 0) {
- mp_mul_2d(b, shift, b);
+ err = mp_mul_2d(b, shift, b);
}
}
+ if (err != MP_OKAY) {
+ return TCL_ERROR;
+ }
return TCL_OK;
}
@@ -4733,11 +4904,13 @@ Tcl_InitBignumFromDouble(
double
TclBignumToDouble(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
mp_int b;
int bits, shift, i, lsb;
double r;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
/*
@@ -4766,11 +4939,13 @@ TclBignumToDouble(
* 'rounded to even'.
*/
- mp_init(&b);
- if (shift == 0) {
- mp_copy(a, &b);
+ err = mp_init(&b);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift == 0) {
+ err = mp_copy(a, &b);
} else if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
lsb = mp_cnt_lsb(a);
if (lsb == -1-shift) {
@@ -4779,12 +4954,12 @@ TclBignumToDouble(
* Round to even
*/
- mp_div_2d(a, -shift, &b, NULL);
- if (mp_isodd(&b)) {
+ err = mp_div_2d(a, -shift, &b, NULL);
+ if ((err == MP_OKAY) && mp_isodd(&b)) {
if (mp_isneg(&b)) {
- mp_sub_d(&b, 1, &b);
+ err = mp_sub_d(&b, 1, &b);
} else {
- mp_add_d(&b, 1, &b);
+ err = mp_add_d(&b, 1, &b);
}
}
} else {
@@ -4793,13 +4968,15 @@ TclBignumToDouble(
* Ordinary rounding
*/
- mp_div_2d(a, -1-shift, &b, NULL);
- if (mp_isneg(&b)) {
- mp_sub_d(&b, 1, &b);
+ err = mp_div_2d(a, -1-shift, &b, NULL);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (mp_isneg(&b)) {
+ err = mp_sub_d(&b, 1, &b);
} else {
- mp_add_d(&b, 1, &b);
+ err = mp_add_d(&b, 1, &b);
}
- mp_div_2d(&b, 1, &b, NULL);
+ err = mp_div_2d(&b, 1, &b, NULL);
}
}
@@ -4807,8 +4984,11 @@ TclBignumToDouble(
* Accumulate the result, one mp_digit at a time.
*/
+ if (err != MP_OKAY) {
+ return 0.0;
+ }
r = 0.0;
- for (i=b.used-1 ; i>=0 ; --i) {
+ for (i = b.used-1; i>=0; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
@@ -4846,14 +5026,16 @@ TclBignumToDouble(
double
TclCeil(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
- mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
- mp_neg(a, &b);
+ err = mp_init(&b);
+ if ((err == MP_OKAY) && mp_isneg(a)) {
+ err = mp_neg(a, &b);
r = -TclFloor(&b);
} else {
int bits = mp_count_bits(a);
@@ -4863,19 +5045,26 @@ TclCeil(
} else {
int i, exact = 1, shift = mantBits - bits;
- if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ if (err != MP_OKAY) {
+ /* just skip */
+ } else if (shift > 0) {
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
mp_int d;
- mp_init(&d);
- mp_div_2d(a, -shift, &b, &d);
+ err = mp_init(&d);
+ if (err == MP_OKAY) {
+ err = mp_div_2d(a, -shift, &b, &d);
+ }
exact = mp_iszero(&d);
mp_clear(&d);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
+ }
+ if ((err == MP_OKAY) && !exact) {
+ err = mp_add_d(&b, 1, &b);
}
- if (!exact) {
- mp_add_d(&b, 1, &b);
+ if (err != MP_OKAY) {
+ return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
@@ -4903,14 +5092,16 @@ TclCeil(
double
TclFloor(
- const mp_int *a) /* Integer to convert. */
+ const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
+ mp_err err;
+ const mp_int *a = (const mp_int *)big;
- mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
- mp_neg(a, &b);
+ err = mp_init(&b);
+ if ((err == MP_OKAY) && mp_isneg(a)) {
+ err = mp_neg(a, &b);
r = -TclCeil(&b);
} else {
int bits = mp_count_bits(a);
@@ -4921,11 +5112,14 @@ TclFloor(
int i, shift = mantBits - bits;
if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
- mp_div_2d(a, -shift, &b, NULL);
+ err = mp_div_2d(a, -shift, &b, NULL);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
+ }
+ if (err != MP_OKAY) {
+ return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
@@ -4967,6 +5161,7 @@ BignumToBiasedFrExp(
int shift;
int i;
double r;
+ mp_err err = MP_OKAY;
/*
* Determine how many bits we need, and extract that many from the input.
@@ -4975,13 +5170,15 @@ BignumToBiasedFrExp(
bits = mp_count_bits(a);
shift = mantBits - 2 - bits;
- mp_init(&b);
+ if (mp_init(&b)) {
+ return 0.0;
+ }
if (shift > 0) {
- mp_mul_2d(a, shift, &b);
+ err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
- mp_div_2d(a, -shift, &b, NULL);
+ err = mp_div_2d(a, -shift, &b, NULL);
} else {
- mp_copy(a, &b);
+ err = mp_copy(a, &b);
}
/*
@@ -4989,8 +5186,10 @@ BignumToBiasedFrExp(
*/
r = 0.0;
- for (i=b.used-1; i>=0; --i) {
- r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
+ if (err == MP_OKAY) {
+ for (i=b.used-1; i>=0; --i) {
+ r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
+ }
}
mp_clear(&b);
@@ -5038,7 +5237,7 @@ Pow10TimesFrExp(
* Multiply by 10**exponent.
*/
- retval = frexp(retval * pow10vals[exponent&0xF], &j);
+ retval = frexp(retval * pow10vals[exponent & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
@@ -5129,23 +5328,23 @@ TclFormatNaN(
#else
union {
double dv;
- Tcl_WideUInt iv;
+ uint64_t iv;
} bitwhack;
bitwhack.dv = value;
if (n770_fp) {
bitwhack.iv = Nokia770Twiddle(bitwhack.iv);
}
- if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
- bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63);
+ if (bitwhack.iv & (UINT64_C(1) << 63)) {
+ bitwhack.iv &= ~ (UINT64_C(1) << 63);
*buffer++ = '-';
}
*buffer++ = 'N';
*buffer++ = 'a';
*buffer++ = 'N';
- bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1;
+ bitwhack.iv &= ((UINT64_C(1)) << 51) - 1;
if (bitwhack.iv != 0) {
- snprintf(buffer, TCL_DOUBLE_SPACE, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv);
+ snprintf(buffer, TCL_DOUBLE_SPACE, "(%" PRIx64 ")", bitwhack.iv);
} else {
*buffer = '\0';
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 975b991..b307cd6 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1,52 +1,41 @@
/*
* tclStringObj.c --
*
- * This file contains functions that implement string operations on Tcl
- * objects. Some string operations work with UTF strings and others
- * require Unicode format. Functions that require knowledge of the width
- * of each character, such as indexing, operate on Unicode data.
- *
- * A Unicode string is an internationalized string. Conceptually, a
- * Unicode string is an array of 16-bit quantities organized as a
- * sequence of properly formed UTF-8 characters. There is a one-to-one
- * map between Unicode and UTF characters. Because Unicode characters
- * have a fixed width, operations such as indexing operate on Unicode
- * data. The String object is optimized for the case where each UTF char
+ * This file contains functions that implement string operations on Tcl
+ * objects. Some string operations work with UTF-8 encoding forms.
+ * Functions that require knowledge of the width of each character,
+ * such as indexing, operate on fixed width encoding forms such as UTF-32.
+ *
+ * Conceptually, a string is a sequence of Unicode code points. Internally
+ * it may be stored in an encoding form such as a modified version of
+ * UTF-8 or UTF-16 (when TCL_UTF_MAX=3) or UTF-32.
+ *
+ * The String object is optimized for the case where each UTF char
* in a string is only one byte. In this case, we store the value of
- * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode
- * is explicitly called).
+ * numChars, but we don't store the fixed form encoding (unless
+ * Tcl_GetUnicode is explicitly called).
*
- * The String object type stores one or both formats. The default
- * behavior is to store UTF. Once Unicode is calculated by a function, it
- * is stored in the internal rep for future access (without an additional
- * O(n) cost).
+ * The String object type stores one or both formats. The default
+ * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is
+ * stored in the internal rep for future access (without an additional
+ * O(n) cost).
*
* To allow many appends to be done to an object without constantly
- * reallocating the space for the string or Unicode representation, we
- * allocate double the space for the string or Unicode and use the
+ * reallocating space, we allocate double the space and use the
* internal representation to keep track of how much space is used vs.
* allocated.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 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 "tclInt.h"
-#include "tommath.h"
+#include "tclTomMath.h"
#include "tclStringRep.h"
-
-/*
- * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5.
- * This is an escape hatch in case the changes have some unexpected unwelcome
- * impact on performance. If things go well, this mechanism can go away when
- * post-8.6 development begins.
- */
-
-#define COMPAT 0
-
+#include "assert.h"
/*
* Prototypes for functions defined later in this file:
*/
@@ -54,42 +43,189 @@
static void AppendPrintfToObjVA(Tcl_Obj *objPtr,
const char *format, va_list argList);
static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int appendNumChars);
+ const Tcl_UniChar *unicode, Tcl_Size appendNumChars);
static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const Tcl_UniChar *unicode, Tcl_Size numChars);
static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr,
- const char *bytes, int numBytes);
+ const char *bytes, Tcl_Size numBytes);
static void AppendUtfToUtfRep(Tcl_Obj *objPtr,
- const char *bytes, int numBytes);
+ const char *bytes, Tcl_Size numBytes);
static void DupStringInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
-static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+static Tcl_Size ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, Tcl_Size numChars);
static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
- const char *bytes, int numBytes,
- int numAppendChars);
+ const char *bytes, Tcl_Size numBytes,
+ Tcl_Size numAppendChars);
static void FillUnicodeRep(Tcl_Obj *objPtr);
static void FreeStringInternalRep(Tcl_Obj *objPtr);
-static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag);
-static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed);
+static void GrowStringBuffer(Tcl_Obj *objPtr, Tcl_Size needed, int flag);
+static void GrowUnicodeBuffer(Tcl_Obj *objPtr, Tcl_Size needed);
static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
-static int UnicodeLength(const Tcl_UniChar *unicode);
+ const Tcl_UniChar *unicode, Tcl_Size numChars);
+static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode);
+#if !defined(TCL_NO_DEPRECATED)
+static int UTF16Length(const unsigned short *unicode);
+#endif
static void UpdateStringOfString(Tcl_Obj *objPtr);
+#if !defined(TCL_NO_DEPRECATED)
+static void DupUTF16StringInternalRep(Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr);
+static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfUTF16String(Tcl_Obj *objPtr);
+#endif
+
+#define ISCONTINUATION(bytes) (\
+ ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \
+ && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80))))
+
+#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800)
+#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800)
+#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00)
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
*/
+#ifndef TCL_NO_DEPRECATED
const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
+ DupUTF16StringInternalRep, /* dupIntRepProc */
+ UpdateStringOfUTF16String, /* updateStringProc */
+ SetUTF16StringFromAny /* setFromAnyProc */
+};
+#endif
+
+const Tcl_ObjType tclUniCharStringType = {
+ "utf32string", /* name */
+ FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
UpdateStringOfString, /* updateStringProc */
SetStringFromAny /* setFromAnyProc */
};
+
+typedef struct {
+ int numChars; /* The number of chars in the string. -1 means
+ * this value has not been calculated. >= 0
+ * means that there is a valid Unicode rep, or
+ * that the number of UTF bytes == the number
+ * of chars. */
+ int allocated; /* The amount of space actually allocated for
+ * the UTF string (minus 1 byte for the
+ * termination char). */
+ int maxChars; /* Max number of chars that can fit in the
+ * space allocated for the unicode array. */
+ int hasUnicode; /* Boolean determining whether the string has
+ * a Unicode representation. */
+ Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
+ * of this field depends on the 'maxChars'
+ * field above. */
+} UniCharString;
+
+#define UNICHAR_STRING_MAXCHARS \
+ (int)(((size_t)UINT_MAX - offsetof(UniCharString, unicode))/sizeof(Tcl_UniChar) - 1)
+#define UNICHAR_STRING_SIZE(numChars) \
+ (offsetof(UniCharString, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
+#define uniCharStringCheckLimits(numChars) \
+ do { \
+ if ((numChars) < 0 || (numChars) > UNICHAR_STRING_MAXCHARS) { \
+ Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
+ UNICHAR_STRING_MAXCHARS); \
+ } \
+ } while (0)
+#define uniCharStringAttemptAlloc(numChars) \
+ (UniCharString *) attemptckalloc(UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringAlloc(numChars) \
+ (UniCharString *) ckalloc(UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringRealloc(ptr, numChars) \
+ (UniCharString *) ckrealloc((ptr), UNICHAR_STRING_SIZE(numChars))
+#define uniCharStringAttemptRealloc(ptr, numChars) \
+ (UniCharString *) attemptckrealloc((ptr), UNICHAR_STRING_SIZE(numChars))
+#define GET_UNICHAR_STRING(objPtr) \
+ ((UniCharString *) (objPtr)->internalRep.twoPtrValue.ptr1)
+#define SET_UNICHAR_STRING(objPtr, stringPtr) \
+ ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
+
+
+#ifndef TCL_NO_DEPRECATED
+static void
+DupUTF16StringInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
+ * an internal rep of type "String". */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
+ * currently have an internal rep.*/
+{
+ String *srcStringPtr = GET_STRING(srcPtr);
+ size_t size = offsetof(String, unicode) + (((srcStringPtr->allocated) + 1U) * sizeof(unsigned short));
+ String *copyStringPtr = (String *)ckalloc(size);
+ memcpy(copyStringPtr, srcStringPtr, size);
+
+ SET_STRING(copyPtr, copyStringPtr);
+ copyPtr->typePtr = &tclStringType;
+}
+
+static int
+SetUTF16StringFromAny(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ if (!TclHasInternalRep(objPtr, &tclStringType)) {
+ Tcl_DString ds;
+
+ /*
+ * Convert whatever we have into an untyped value. Just A String.
+ */
+
+ (void) TclGetString(objPtr);
+ TclFreeInternalRep(objPtr);
+
+ /*
+ * Create a basic String internalrep that just points to the UTF-8 string
+ * already in place at objPtr->bytes.
+ */
+
+ Tcl_DStringInit(&ds);
+ unsigned short *utf16string = Tcl_UtfToChar16DString(objPtr->bytes, objPtr->length, &ds);
+ int size = Tcl_DStringLength(&ds);
+ String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + size);
+
+ memcpy(stringPtr->unicode, utf16string, size);
+ Tcl_DStringFree(&ds);
+ size /= sizeof(unsigned short);
+ stringPtr->unicode[size] = 0;
+
+ stringPtr->numChars = size;
+ stringPtr->allocated = size;
+ stringPtr->maxChars = size;
+ stringPtr->hasUnicode = 1;
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+ }
+ return TCL_OK;
+}
+
+static void
+UpdateStringOfUTF16String(
+ Tcl_Obj *objPtr) /* Object with string rep to update. */
+{
+ Tcl_DString ds;
+ String *stringPtr = GET_STRING(objPtr);
+
+ Tcl_DStringInit(&ds);
+ const char *string = Tcl_Char16ToUtfDString(stringPtr->unicode, stringPtr->numChars, &ds);
+
+ char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U);
+ memcpy(bytes, string, Tcl_DStringLength(&ds));
+ bytes[Tcl_DStringLength(&ds)] = 0;
+ objPtr->bytes = bytes;
+ objPtr->length = Tcl_DStringLength(&ds);
+ Tcl_DStringFree(&ds);
+}
+#endif
/*
* TCL STRING GROWTH ALGORITHM
@@ -131,8 +267,8 @@ const Tcl_ObjType tclStringType = {
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
- int needed,
- int flag)
+ Tcl_Size needed, /* Not including terminating nul */
+ int flag) /* If 0, try to overallocate */
{
/*
* Preconditions:
@@ -141,30 +277,30 @@ GrowStringBuffer(
* flag || objPtr->bytes != NULL
*/
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
char *ptr = NULL;
- int attempt;
+ Tcl_Size capacity;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
if (needed <= INT_MAX / 2) {
- attempt = 2 * needed;
- ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1U);
+ capacity = 2 * needed;
+ ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
- * overflow into invalid argument values for attempt.
+ * overflow into invalid argument values for capacity.
*/
unsigned int limit = INT_MAX - needed;
unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
- attempt = needed + growth;
- ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1U);
+ capacity = needed + growth;
+ ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U);
}
}
if (ptr == NULL) {
@@ -172,50 +308,51 @@ GrowStringBuffer(
* First allocation - just big enough; or last chance fallback.
*/
- attempt = needed;
- ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1U);
+ capacity = needed;
+ ptr = (char *)ckrealloc(objPtr->bytes, capacity + 1U);
}
objPtr->bytes = ptr;
- stringPtr->allocated = attempt;
+ stringPtr->allocated = capacity;
+ memset(ptr + objPtr->length, 0, capacity + 1U - objPtr->length);
}
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
- int needed)
+ Tcl_Size needed)
{
/*
* Preconditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->maxChars
- * needed < STRING_MAXCHARS
+ * needed < UNICHAR_STRING_MAXCHARS
*/
- String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
- int attempt;
+ UniCharString *ptr = NULL, *stringPtr = GET_UNICHAR_STRING(objPtr);
+ Tcl_Size capacity;
if (stringPtr->maxChars > 0) {
/*
* Subsequent appends - apply the growth algorithm.
*/
- if (needed <= STRING_MAXCHARS / 2) {
- attempt = 2 * needed;
- ptr = stringAttemptRealloc(stringPtr, attempt);
+ if (needed <= UNICHAR_STRING_MAXCHARS / 2) {
+ capacity = 2 * needed;
+ ptr = uniCharStringAttemptRealloc(stringPtr, capacity);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
- * overflow into invalid argument values for attempt.
+ * overflow into invalid argument values for capacity.
*/
- unsigned int limit = STRING_MAXCHARS - needed;
+ unsigned int limit = UNICHAR_STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
+ TCL_MIN_UNICHAR_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
- attempt = needed + growth;
- ptr = stringAttemptRealloc(stringPtr, attempt);
+ capacity = needed + growth;
+ ptr = uniCharStringAttemptRealloc(stringPtr, capacity);
}
}
if (ptr == NULL) {
@@ -223,12 +360,12 @@ GrowUnicodeBuffer(
* First allocation - just big enough; or last chance fallback.
*/
- attempt = needed;
- ptr = stringRealloc(stringPtr, attempt);
+ capacity = needed;
+ ptr = uniCharStringRealloc(stringPtr, capacity);
}
stringPtr = ptr;
- stringPtr->maxChars = attempt;
- SET_STRING(objPtr, stringPtr);
+ stringPtr->maxChars = capacity;
+ SET_UNICHAR_STRING(objPtr, stringPtr);
}
/*
@@ -262,7 +399,7 @@ Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length) /* The number of bytes to copy from "bytes"
+ Tcl_Size length) /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
@@ -274,10 +411,9 @@ Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length) /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first NUL
- * byte. */
+ Tcl_Size length) /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If negative,
+ * use bytes up to the first NUL byte. */
{
Tcl_Obj *objPtr;
@@ -323,10 +459,9 @@ Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length, /* The number of bytes to copy from "bytes"
- * when initializing the new object. If
- * negative, use bytes up to the first NUL
- * byte. */
+ Tcl_Size length, /* The number of bytes to copy from "bytes"
+ * when initializing the new object. If negative,
+ * use bytes up to the first NUL byte. */
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
@@ -346,14 +481,12 @@ Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
- int length, /* The number of bytes to copy from "bytes"
+ Tcl_Size length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
- 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_UNUSED(const char *) /*file*/,
+ TCL_UNUSED(int) /*line*/)
{
return Tcl_NewStringObj(bytes, length);
}
@@ -379,10 +512,10 @@ Tcl_DbNewStringObj(
*/
Tcl_Obj *
-Tcl_NewUnicodeObj(
+TclNewUnicodeObj(
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* new object. */
- int numChars) /* Number of characters in the unicode
+ Tcl_Size numChars) /* Number of characters in the unicode
* string. */
{
Tcl_Obj *objPtr;
@@ -392,6 +525,39 @@ Tcl_NewUnicodeObj(
return objPtr;
}
+#if !defined(TCL_NO_DEPRECATED)
+Tcl_Obj *
+Tcl_NewUnicodeObj(
+ const unsigned short *unicode, /* The unicode string used to initialize the
+ * new object. */
+ int numChars) /* Number of characters in the unicode
+ * string. */
+{
+ Tcl_Obj *objPtr;
+
+ TclNewObj(objPtr);
+ TclInvalidateStringRep(objPtr);
+
+ if (numChars < 0) {
+ numChars = UTF16Length(unicode);
+ }
+
+ String *stringPtr = (String *)ckalloc((offsetof(String, unicode)
+ + sizeof(unsigned short)) + numChars * sizeof(unsigned short));
+ memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short));
+ stringPtr->unicode[numChars] = 0;
+
+ stringPtr->numChars = numChars;
+ stringPtr->allocated = numChars;
+ stringPtr->maxChars = numChars;
+ stringPtr->hasUnicode = 1;
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+
+ return objPtr;
+}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -409,13 +575,13 @@ Tcl_NewUnicodeObj(
*----------------------------------------------------------------------
*/
-int
-Tcl_GetCharLength(
+Tcl_Size
+TclGetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
- String *stringPtr;
- int numChars;
+ UniCharString *stringPtr;
+ Tcl_Size numChars;
/*
* Quick, no-shimmer return for short string reps.
@@ -427,20 +593,19 @@ Tcl_GetCharLength(
}
/*
- * Optimize the case where we're really dealing with a ByteArray object;
+ * Optimize the case where we're really dealing with a bytearray object;
* we don't need to convert to a string to perform the get-length operation.
*
- * NOTE that we do not need the ByteArray to be "pure". A ByteArray value
- * with a string rep cannot be trusted to represent the same value as the
- * string rep, but it *can* be trusted to have the same character length
- * as the string rep, which is all this routine cares about.
+ * Starting in Tcl 8.7, we check for a "pure" bytearray, because the
+ * machinery behind that test is using a proper bytearray ObjType. We
+ * could also compute length of an improper bytearray without shimmering
+ * but there's no value in that. We *want* to shimmer an improper bytearray
+ * because improper bytearrays have worthless internal reps.
*/
- if (objPtr->typePtr == &tclByteArrayType) {
- int length;
-
- (void) Tcl_GetByteArrayFromObj(objPtr, &length);
- return length;
+ if (TclIsPureByteArray(objPtr)) {
+ (void) Tcl_GetByteArrayFromObj(objPtr, &numChars);
+ return numChars;
}
/*
@@ -448,32 +613,61 @@ Tcl_GetCharLength(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
numChars = stringPtr->numChars;
/*
* If numChars is unknown, compute it.
*/
- if (numChars == -1) {
- TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
+ if (numChars < 0) {
+ TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
+ }
+ return numChars;
+}
+
+#if !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetCharLength
+Tcl_Size
+Tcl_GetCharLength(
+ Tcl_Obj *objPtr) /* The String object to get the num chars
+ * of. */
+{
+ Tcl_Size numChars = 0;
-#if COMPAT
- if (numChars < objPtr->length) {
- /*
- * Since we've just computed the number of chars, and not all UTF
- * chars are 1-byte long, go ahead and populate the Unicode
- * string.
- */
+ /*
+ * Quick, no-shimmer return for short string reps.
+ */
- FillUnicodeRep(objPtr);
- }
-#endif
+ if ((objPtr->bytes) && (objPtr->length < 2)) {
+ /* 0 bytes -> 0 chars; 1 byte -> 1 char */
+ return objPtr->length;
+ }
+
+ /*
+ * Optimize the case where we're really dealing with a bytearray object;
+ * we don't need to convert to a string to perform the get-length operation.
+ *
+ * Starting in Tcl 8.7, we check for a "pure" bytearray, because the
+ * machinery behind that test is using a proper bytearray ObjType. We
+ * could also compute length of an improper bytearray without shimmering
+ * but there's no value in that. We *want* to shimmer an improper bytearray
+ * because improper bytearrays have worthless internal reps.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ (void) Tcl_GetByteArrayFromObj(objPtr, &numChars);
+ } else {
+ Tcl_GetString(objPtr);
+ numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);
}
+
return numChars;
}
-
+#endif
+
+
/*
*----------------------------------------------------------------------
*
@@ -491,17 +685,22 @@ Tcl_GetCharLength(
*----------------------------------------------------------------------
*/
int
-TclCheckEmptyString (
+TclCheckEmptyString(
Tcl_Obj *objPtr)
{
- int length = -1;
+ Tcl_Size length = TCL_INDEX_NONE;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
return TCL_EMPTYSTRING_YES;
}
- if (TclIsPureList(objPtr)) {
- TclListObjLength(NULL, objPtr, &length);
+ if (TclIsPureByteArray(objPtr)
+ && TclGetCharLength(objPtr) == 0) {
+ return TCL_EMPTYSTRING_YES;
+ }
+
+ if (TclListObjIsCanonical(objPtr)) {
+ TclListObjLengthM(NULL, objPtr, &length);
return length == 0;
}
@@ -519,10 +718,11 @@ TclCheckEmptyString (
/*
*----------------------------------------------------------------------
*
- * Tcl_GetUniChar/TclGetUCS4 --
+ * Tcl_GetUniChar --
*
* Get the index'th Unicode character from the String object. If index
- * is out of range, the result = 0xFFFD (Tcl_GetUniChar) resp. -1 (TclGetUCS4)
+ * is out of range or it references a low surrogate preceded by a high
+ * surrogate, the result = -1;
*
* Results:
* Returns the index'th Unicode character in the Object.
@@ -533,17 +733,19 @@ TclCheckEmptyString (
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+#if !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetUniChar
+int
Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
- int index) /* Get the index'th Unicode character. */
+ Tcl_Size index) /* Get the index'th Unicode character. */
{
String *stringPtr;
- int length;
+ int ch;
if (index < 0) {
- return 0xFFFD;
+ return -1;
}
/*
@@ -552,54 +754,52 @@ Tcl_GetUniChar(
*/
if (TclIsPureByteArray(objPtr)) {
+ Tcl_Size length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
- return 0xFFFD;
+ return -1;
}
- return (Tcl_UniChar) bytes[index];
+ return bytes[index];
}
/*
* OK, need to work with the object as a string.
*/
- SetStringFromAny(NULL, objPtr);
+ SetUTF16StringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- if (stringPtr->hasUnicode == 0) {
- /*
- * If numChars is unknown, compute it.
- */
-
- if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
- }
- if (index >= stringPtr->numChars) {
- return 0xFFFD;
- }
- if (stringPtr->numChars == objPtr->length) {
- return (unsigned char) objPtr->bytes[index];
- }
- FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
-
if (index >= stringPtr->numChars) {
- return 0xFFFD;
+ return -1;
}
- return stringPtr->unicode[index];
+ ch = stringPtr->unicode[index];
+ /* See: bug [11ae2be95dac9417] */
+ if (SURROGATE(ch)) {
+ if (ch & 0x400) {
+ if ((index > 0)
+ && HIGH_SURROGATE(stringPtr->unicode[index-1])) {
+ ch = -1; /* low surrogate preceded by high surrogate */
+ }
+ } else if ((++index < stringPtr->numChars)
+ && LOW_SURROGATE(stringPtr->unicode[index])) {
+ /* high surrogate followed by low surrogate */
+ ch = (((ch & 0x3FF) << 10) |
+ (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+ }
+ }
+ return ch;
}
+#endif
-#if TCL_UTF_MAX == 4
int
-TclGetUCS4(
+TclGetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode character
* from. */
- int index) /* Get the index'th Unicode character. */
+ Tcl_Size index) /* Get the index'th Unicode character. */
{
- String *stringPtr;
- int ch, length;
+ UniCharString *stringPtr;
+ int ch;
if (index < 0) {
return -1;
@@ -611,12 +811,13 @@ TclGetUCS4(
*/
if (TclIsPureByteArray(objPtr)) {
+ Tcl_Size length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
return -1;
}
- return (int) bytes[index];
+ return bytes[index];
}
/*
@@ -624,50 +825,32 @@ TclGetUCS4(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
- if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ if (stringPtr->numChars == TCL_INDEX_NONE) {
+ TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (index >= stringPtr->numChars) {
return -1;
}
if (stringPtr->numChars == objPtr->length) {
- /* Pure ascii, can directly index bytes */
return (unsigned char) objPtr->bytes[index];
}
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
if (index >= stringPtr->numChars) {
return -1;
}
ch = stringPtr->unicode[index];
-#if TCL_UTF_MAX <= 4
- /* See: bug [11ae2be95dac9417] */
- if ((ch & 0xF800) == 0xD800) {
- if (ch & 0x400) {
- if ((index > 0)
- && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
- ch = -1; /* low surrogate preceded by high surrogate */
- }
- } else if ((++index < stringPtr->numChars)
- && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
- /* high surrogate followed by low surrogate */
- ch = (((ch & 0x3FF) << 10) |
- (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
- }
- }
-#endif
return ch;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -688,18 +871,21 @@ TclGetUCS4(
*----------------------------------------------------------------------
*/
-Tcl_UniChar *
+#ifndef TCL_NO_DEPRECATED
+#undef Tcl_GetUnicode
+unsigned short *
Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the Unicode string
* for. */
{
return Tcl_GetUnicodeFromObj(objPtr, NULL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
- * Tcl_GetUnicodeFromObj --
+ * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj --
*
* Get the Unicode form of the String object with length. If the object
* is not already a String object, it will be converted to one. If the
@@ -716,21 +902,21 @@ Tcl_GetUnicode(
*/
Tcl_UniChar *
-Tcl_GetUnicodeFromObj(
+TclGetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the Unicode string
* for. */
int *lengthPtr) /* If non-NULL, the location where the string
* rep's Tcl_UniChar length should be stored. If
* NULL, no length is stored. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
if (lengthPtr != NULL) {
@@ -738,6 +924,27 @@ Tcl_GetUnicodeFromObj(
}
return stringPtr->unicode;
}
+
+#if !defined(TCL_NO_DEPRECATED)
+unsigned short *
+Tcl_GetUnicodeFromObj(
+ Tcl_Obj *objPtr, /* The object to find the Unicode string
+ * for. */
+ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string
+ * rep's Tcl_UniChar length should be stored. If
+ * NULL, no length is stored. */
+{
+ String *stringPtr;
+
+ SetUTF16StringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = stringPtr->numChars;
+ }
+ return stringPtr->unicode;
+}
+#endif
/*
*----------------------------------------------------------------------
@@ -746,9 +953,9 @@ Tcl_GetUnicodeFromObj(
*
* Create a Tcl Object that contains the chars between first and last of
* the object indicated by "objPtr". If the object is not already a
- * String object, convert it to one. If first is negative, the returned
- * string start at the beginning of objPtr. If last is negative, the
- * returned string ends at the end of objPtr.
+ * String object, convert it to one. If first is negative, the
+ * returned string start at the beginning of objPtr. If last is
+ * negative, the returned string ends at the end of objPtr.
*
* Results:
* Returns a new Tcl Object of the String type.
@@ -759,22 +966,70 @@ Tcl_GetUnicodeFromObj(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
+#undef Tcl_GetRange
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
- int first, /* First index of the range. */
- int last) /* Last index of the range. */
+ Tcl_Size first, /* First index of the range. */
+ Tcl_Size last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
- String *stringPtr;
- int length;
+ Tcl_Size length;
if (first < 0) {
first = 0;
}
/*
- * Optimize the case where we're really dealing with a ByteArray object
+ * Optimize the case where we're really dealing with a bytearray object
+ * we don't need to convert to a string to perform the substring operation.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+
+ if (last < 0 || last >= length) {
+ last = length - 1;
+ }
+ if (last < first) {
+ TclNewObj(newObjPtr);
+ return newObjPtr;
+ }
+ return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
+ }
+
+ Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length);
+
+ if (last < 0 || last >= numChars) {
+ last = numChars - 1;
+ }
+ if (last < first) {
+ TclNewObj(newObjPtr);
+ return newObjPtr;
+ }
+ const char *begin = Tcl_UtfAtIndex(objPtr->bytes, first);
+ const char *end = Tcl_UtfAtIndex(objPtr->bytes, last + 1);
+ return Tcl_NewStringObj(begin, end - begin);
+}
+#endif
+
+Tcl_Obj *
+TclGetRange(
+ Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
+ Tcl_Size first, /* First index of the range. */
+ Tcl_Size last) /* Last index of the range. */
+{
+ Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
+ UniCharString *stringPtr;
+ Tcl_Size length;
+
+ if (first < 0) {
+ first = 0;
+ }
+
+ /*
+ * Optimize the case where we're really dealing with a bytearray object
* we don't need to convert to a string to perform the substring operation.
*/
@@ -796,15 +1051,15 @@ Tcl_GetRange(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
- if (stringPtr->numChars == -1) {
- TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ if (stringPtr->numChars == TCL_INDEX_NONE) {
+ TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
if (last < 0 || last >= stringPtr->numChars) {
@@ -821,14 +1076,13 @@ Tcl_GetRange(
*/
SetStringFromAny(NULL, newObjPtr);
- stringPtr = GET_STRING(newObjPtr);
+ stringPtr = GET_UNICHAR_STRING(newObjPtr);
stringPtr->numChars = newObjPtr->length;
return newObjPtr;
}
FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
-
if (last < 0 || last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
@@ -836,19 +1090,7 @@ Tcl_GetRange(
TclNewObj(newObjPtr);
return newObjPtr;
}
-#if TCL_UTF_MAX == 4
- /* See: bug [11ae2be95dac9417] */
- if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
- && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
- ++first;
- }
- if ((last + 1 < stringPtr->numChars)
- && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
- && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
- ++last;
- }
-#endif
- return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
+ return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}
/*
@@ -877,7 +1119,7 @@ Tcl_SetStringObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
- int length) /* The number of bytes to copy from "bytes"
+ Tcl_Size length) /* The number of bytes to copy from "bytes"
* when initializing the object. If negative,
* use bytes up to the first NUL byte.*/
{
@@ -889,7 +1131,7 @@ Tcl_SetStringObj(
* Set the type to NULL and free any internal rep for the old type.
*/
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
/*
* Free any old string rep, then set the string rep to a copy of the
@@ -908,20 +1150,19 @@ Tcl_SetStringObj(
*
* Tcl_SetObjLength --
*
- * This function changes the length of the string representation of an
- * object.
+ * Changes the length of the string representation of objPtr.
*
* Results:
* None.
*
* Side effects:
- * If the size of objPtr's string representation is greater than length,
- * then it is reduced to length and a new terminating null byte is stored
- * in the strength. If the length of the string representation is greater
- * than length, the storage space is reallocated to the given length; a
- * null byte is stored at the end, but other bytes past the end of the
- * original string representation are undefined. The object's internal
- * representation is changed to "expendable string".
+ * If the size of objPtr's string representation is greater than length, a
+ * new terminating null byte is stored in objPtr->bytes at length, and
+ * bytes at positions past length have no meaning. If the length of the
+ * string representation is greater than length, the storage space is
+ * reallocated to length+1.
+ *
+ * The object's internal representation is changed to &tclStringType.
*
*----------------------------------------------------------------------
*/
@@ -930,20 +1171,15 @@ void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
- int length) /* Number of bytes desired for string
+ Tcl_Size length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (length < 0) {
- /*
- * Setting to a negative length is nonsense. This is probably the
- * result of overflowing the signed integer range.
- */
-
- Tcl_Panic("Tcl_SetObjLength: negative length requested: "
- "%d (integer overflow?)", length);
+ Tcl_Panic("Tcl_SetObjLength: length requested is negative: "
+ "%" TCL_SIZE_MODIFIER "d (integer overflow?)", length);
}
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
@@ -954,7 +1190,7 @@ Tcl_SetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -964,10 +1200,10 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
- objPtr->bytes = (char *)ckalloc((unsigned int)length + 1U);
+ if (objPtr->bytes == &tclEmptyString) {
+ objPtr->bytes = (char *)ckalloc(length + 1U);
} else {
- objPtr->bytes = (char *)ckrealloc(objPtr->bytes, (unsigned int)length + 1U);
+ objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1U);
}
stringPtr->allocated = length;
}
@@ -976,20 +1212,20 @@ Tcl_SetObjLength(
objPtr->bytes[length] = 0;
/*
- * Invalidate the unicode data.
+ * Invalidate the Unicode data.
*/
- stringPtr->numChars = -1;
+ stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure unicode string.
*/
- stringCheckLimits(length);
+ uniCharStringCheckLimits(length);
if (length > stringPtr->maxChars) {
- stringPtr = stringRealloc(stringPtr, length);
- SET_STRING(objPtr, stringPtr);
+ stringPtr = uniCharStringRealloc(stringPtr, length);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
@@ -1035,20 +1271,17 @@ int
Tcl_AttemptSetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
- int length) /* Number of bytes desired for string
+ Tcl_Size length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (length < 0) {
- /*
- * Setting to a negative length is nonsense. This is probably the
- * result of overflowing the signed integer range.
- */
-
+ /* Negative lengths => most likely integer overflow */
return 0;
}
+
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
}
@@ -1057,7 +1290,7 @@ Tcl_AttemptSetObjLength(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
@@ -1070,10 +1303,10 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
- newBytes = (char *)attemptckalloc((unsigned int)length + 1U);
+ if (objPtr->bytes == &tclEmptyString) {
+ newBytes = (char *)attemptckalloc(length + 1U);
} else {
- newBytes = (char *)attemptckrealloc(objPtr->bytes, (unsigned int)length + 1U);
+ newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1U);
}
if (newBytes == NULL) {
return 0;
@@ -1089,22 +1322,22 @@ Tcl_AttemptSetObjLength(
* Invalidate the Unicode data.
*/
- stringPtr->numChars = -1;
+ stringPtr->numChars = TCL_INDEX_NONE;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure Unicode string.
*/
- if (length > STRING_MAXCHARS) {
+ if (length > UNICHAR_STRING_MAXCHARS) {
return 0;
}
if (length > stringPtr->maxChars) {
- stringPtr = stringAttemptRealloc(stringPtr, length);
+ stringPtr = uniCharStringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
- SET_STRING(objPtr, stringPtr);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
@@ -1140,33 +1373,68 @@ Tcl_AttemptSetObjLength(
*---------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
- const Tcl_UniChar *unicode, /* The Unicode string used to initialize the
+ const unsigned short *unicode, /* The Unicode string used to initialize the
* object. */
- int numChars) /* Number of characters in the Unicode
+ Tcl_Size numChars) /* Number of characters in the Unicode
* string. */
{
- if (Tcl_IsShared(objPtr)) {
- Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
+ String *stringPtr;
+
+ if (numChars < 0) {
+ numChars = UTF16Length(unicode);
}
- TclFreeIntRep(objPtr);
- SetUnicodeObj(objPtr, unicode, numChars);
+
+ /*
+ * Allocate enough space for the String structure + Unicode string.
+ */
+
+ stringCheckLimits(numChars);
+ stringPtr = stringAlloc(numChars);
+ SET_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclStringType;
+
+ stringPtr->maxChars = numChars;
+ memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned char));
+ stringPtr->unicode[numChars] = 0;
+ stringPtr->numChars = numChars;
+ stringPtr->hasUnicode = 1;
+
+ TclInvalidateStringRep(objPtr);
+ stringPtr->allocated = numChars;
}
-static int
+static Tcl_Size
+UTF16Length(
+ const unsigned short *ucs2Ptr)
+{
+ Tcl_Size numChars = 0;
+
+ if (ucs2Ptr) {
+ while (numChars >= 0 && ucs2Ptr[numChars] != 0) {
+ numChars++;
+ }
+ }
+ stringCheckLimits(numChars);
+ return numChars;
+}
+#endif
+
+static Tcl_Size
UnicodeLength(
const Tcl_UniChar *unicode)
{
- int numChars = 0;
+ Tcl_Size numChars = 0;
if (unicode) {
- while (numChars >= 0 && unicode[numChars] != 0) {
+ while ((numChars >= 0) && (unicode[numChars] != 0)) {
numChars++;
}
}
- stringCheckLimits(numChars);
+ uniCharStringCheckLimits(numChars);
return numChars;
}
@@ -1175,10 +1443,10 @@ SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
const Tcl_UniChar *unicode, /* The Unicode string used to initialize the
* object. */
- int numChars) /* Number of characters in the Unicode
+ Tcl_Size numChars) /* Number of characters in the Unicode
* string. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
@@ -1188,10 +1456,10 @@ SetUnicodeObj(
* Allocate enough space for the String structure + Unicode string.
*/
- stringCheckLimits(numChars);
- stringPtr = stringAlloc(numChars);
- SET_STRING(objPtr, stringPtr);
- objPtr->typePtr = &tclStringType;
+ uniCharStringCheckLimits(numChars);
+ stringPtr = uniCharStringAlloc(numChars);
+ SET_UNICHAR_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclUniCharStringType;
stringPtr->maxChars = numChars;
memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
@@ -1226,18 +1494,18 @@ Tcl_AppendLimitedToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
- int length, /* The number of bytes available to be
- * appended from "bytes". If < 0, then all
- * bytes up to a NUL byte are available. */
- int limit, /* The maximum number of bytes to append to
+ Tcl_Size length, /* The number of bytes available to be
+ * appended from "bytes". If -1, then
+ * all bytes up to a NUL byte are available. */
+ Tcl_Size limit, /* The maximum number of bytes to append to
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
* at "bytes" were appended. */
{
- String *stringPtr;
- int toCopy = 0;
- int eLen = 0;
+ UniCharString *stringPtr;
+ Tcl_Size toCopy = 0;
+ Tcl_Size eLen = 0;
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
@@ -1257,10 +1525,10 @@ Tcl_AppendLimitedToObj(
}
eLen = strlen(ellipsis);
while (eLen > limit) {
- eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
+ eLen = Tcl_UtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
}
- toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes;
+ toCopy = Tcl_UtfPrev(bytes+limit+1-eLen, bytes) - bytes;
}
/*
@@ -1274,8 +1542,14 @@ Tcl_AppendLimitedToObj(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ /* If appended string starts with a continuation byte or a lower surrogate,
+ * force objPtr to unicode representation. See [7f1162a867] */
+ if (bytes && ISCONTINUATION(bytes)) {
+ TclGetUnicodeFromObj(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ }
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
@@ -1286,7 +1560,7 @@ Tcl_AppendLimitedToObj(
return;
}
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
@@ -1316,11 +1590,11 @@ Tcl_AppendToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
- int length) /* The number of bytes to append from "bytes".
- * If < 0, then append all bytes up to NUL
+ Tcl_Size length) /* The number of bytes to append from "bytes".
+ * If negative, then append all bytes up to NUL
* byte. */
{
- Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
+ Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_SIZE_MAX, NULL);
}
/*
@@ -1329,7 +1603,7 @@ Tcl_AppendToObj(
* Tcl_AppendUnicodeToObj --
*
* This function appends a Unicode string to an object in the most
- * efficient manner possible. Length must be >= 0.
+ * efficient manner possible.
*
* Results:
* None.
@@ -1341,13 +1615,14 @@ Tcl_AppendToObj(
*/
void
-Tcl_AppendUnicodeToObj(
+TclAppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The Unicode string to append to the
* object. */
- int length) /* Number of chars in unicode. */
+ Tcl_Size length) /* Number of chars in Unicode. Negative
+ * lengths means nul terminated */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
@@ -1358,25 +1633,50 @@ Tcl_AppendUnicodeToObj(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
- * If objPtr has a valid Unicode rep, then append unicode to the
- * objPtr's Unicode rep, otherwise the UTF conversion of unicode to
+ * If objPtr has a valid Unicode rep, then append the "unicode" to the
+ * objPtr's Unicode rep, otherwise the UTF conversion of "unicode" to
* objPtr's string rep.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
AppendUnicodeToUtfRep(objPtr, unicode, length);
}
}
+
+#if !defined(TCL_NO_DEPRECATED)
+void
+Tcl_AppendUnicodeToObj(
+ Tcl_Obj *objPtr, /* Points to the object to append to. */
+ const unsigned short *unicode, /* The unicode string to append to the
+ * object. */
+ Tcl_Size length) /* Number of chars in Unicode. Negative
+ * lengths means nul terminated */
+{
+ String *stringPtr;
+
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
+ }
+
+ if (length == 0) {
+ return;
+ }
+ SetUTF16StringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+ stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length);
+ memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length);
+ stringPtr->maxChars = stringPtr->allocated = stringPtr->numChars += length;
+ stringPtr->unicode[stringPtr->numChars] = 0;
+ SET_STRING(objPtr, stringPtr);
+}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -1402,8 +1702,9 @@ Tcl_AppendObjToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
- String *stringPtr;
- int length, numChars, appendNumChars = -1;
+ UniCharString *stringPtr;
+ Tcl_Size length, numChars;
+ Tcl_Size appendNumChars = TCL_INDEX_NONE;
const char *bytes;
/*
@@ -1411,21 +1712,21 @@ Tcl_AppendObjToObj(
* that appending nothing to anything leaves that starting anything...
*/
- if (appendObjPtr->bytes == tclEmptyStringRep) {
+ if (appendObjPtr->bytes == &tclEmptyString) {
return;
}
/*
* Handle append of one ByteArray object to another as a special case.
- * Note that we only do this when the objects don't have string reps; if
- * it did, then appending the byte arrays together could well lose
- * information; this is a special-case optimization only.
+ * Note that we only do this when the objects are pure so that the
+ * bytearray faithfully represent the true value; Otherwise appending the
+ * byte arrays together could lose information;
*/
- if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
+ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
- * You might expect the code here to be
+ * One might expect the code here to be
*
* bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length);
* TclAppendBytesToByteArray(objPtr, bytes, length);
@@ -1443,7 +1744,7 @@ Tcl_AppendObjToObj(
* First, get the lengths.
*/
- int lengthSrc;
+ Tcl_Size lengthSrc;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
@@ -1466,7 +1767,7 @@ Tcl_AppendObjToObj(
*/
TclAppendBytesToByteArray(objPtr,
- Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
+ Tcl_GetByteArrayFromObj(appendObjPtr, (Tcl_Size *) NULL), lengthSrc);
return;
}
@@ -1475,25 +1776,28 @@ Tcl_AppendObjToObj(
*/
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
-
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+
+ /* If appended string starts with a continuation byte or a lower surrogate,
+ * force objPtr to unicode representation. See [7f1162a867]
+ * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */
+ if (ISCONTINUATION(TclGetString(appendObjPtr))) {
+ TclGetUnicodeFromObj(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
+ }
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
*/
- if (stringPtr->hasUnicode
-#if COMPAT
- && stringPtr->numChars > 0
-#endif
- ) {
+ if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
- if (appendObjPtr->typePtr == &tclStringType) {
+ if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
Tcl_UniChar *unicode =
- Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
+ TclGetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
@@ -1512,19 +1816,15 @@ Tcl_AppendObjToObj(
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
- if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) {
- String *appendStringPtr = GET_STRING(appendObjPtr);
+ if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) {
+ UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
- if (numChars >= 0 && appendNumChars >= 0
-#if COMPAT
- && appendNumChars == length
-#endif
- ) {
+ if ((numChars >= 0) && (appendNumChars >= 0)) {
stringPtr->numChars = numChars + appendNumChars;
}
}
@@ -1550,10 +1850,10 @@ static void
AppendUnicodeToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to append. */
- int appendNumChars) /* Number of chars of "unicode" to append. */
+ Tcl_Size appendNumChars) /* Number of chars of "unicode" to append. */
{
- String *stringPtr;
- int numChars;
+ UniCharString *stringPtr;
+ Tcl_Size numChars;
if (appendNumChars < 0) {
appendNumChars = UnicodeLength(unicode);
@@ -1563,7 +1863,7 @@ AppendUnicodeToUnicodeRep(
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* If not enough space has been allocated for the Unicode rep, reallocate
@@ -1574,10 +1874,10 @@ AppendUnicodeToUnicodeRep(
*/
numChars = stringPtr->numChars + appendNumChars;
- stringCheckLimits(numChars);
+ uniCharStringCheckLimits(numChars);
if (numChars > stringPtr->maxChars) {
- int offset = -1;
+ Tcl_Size offset = TCL_INDEX_NONE;
/*
* Protect against case where Unicode points into the existing
@@ -1591,7 +1891,7 @@ AppendUnicodeToUnicodeRep(
}
GrowUnicodeBuffer(objPtr, numChars);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* Relocate Unicode if needed; see above.
@@ -1639,23 +1939,15 @@ static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
- int numChars) /* Number of chars of unicode to convert. */
+ Tcl_Size numChars) /* Number of chars of Unicode to convert. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
- if (stringPtr->numChars != -1) {
+ if (stringPtr->numChars != TCL_INDEX_NONE) {
stringPtr->numChars += numChars;
}
-
-#if COMPAT
- /*
- * Invalidate the Unicode rep.
- */
-
- stringPtr->hasUnicode = 0;
-#endif
}
/*
@@ -1680,9 +1972,9 @@ static void
AppendUtfToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to convert to Unicode. */
- int numBytes) /* Number of bytes of "bytes" to convert. */
+ Tcl_Size numBytes) /* Number of bytes of "bytes" to convert. */
{
- String *stringPtr;
+ UniCharString *stringPtr;
if (numBytes == 0) {
return;
@@ -1690,7 +1982,7 @@ AppendUtfToUnicodeRep(
ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1);
TclInvalidateStringRep(objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
stringPtr->allocated = 0;
}
@@ -1716,10 +2008,10 @@ static void
AppendUtfToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to append. */
- int numBytes) /* Number of bytes of "bytes" to append. */
+ Tcl_Size numBytes) /* Number of bytes of "bytes" to append. */
{
- String *stringPtr;
- int newLength, oldLength;
+ UniCharString *stringPtr;
+ Tcl_Size newLength, oldLength;
if (numBytes == 0) {
return;
@@ -1734,14 +2026,14 @@ AppendUtfToUtfRep(
objPtr->length = 0;
}
oldLength = objPtr->length;
- if (numBytes > INT_MAX - oldLength) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ if (numBytes > TCL_SIZE_MAX - oldLength) {
+ Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX);
}
newLength = numBytes + oldLength;
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (newLength > stringPtr->allocated) {
- int offset = -1;
+ Tcl_Size offset = TCL_INDEX_NONE;
/*
* Protect against case where unicode points into the existing
@@ -1876,12 +2168,12 @@ Tcl_AppendFormatToObj(
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
const char *span = format, *msg, *errCode;
- int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
- int originalLength, limit;
+ int gotXpg = 0, gotSequential = 0;
+ Tcl_Size objIndex = 0, originalLength, limit, numBytes = 0;
Tcl_UniChar ch = 0;
static const char *mixedXPG =
"cannot mix \"%\" and \"%n$\" conversion specifiers";
@@ -1895,7 +2187,7 @@ Tcl_AppendFormatToObj(
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
TclGetStringFromObj(appendObj, &originalLength);
- limit = INT_MAX - originalLength;
+ limit = TCL_SIZE_MAX - originalLength;
/*
* Format string is NUL-terminated.
@@ -1904,11 +2196,13 @@ Tcl_AppendFormatToObj(
while (*format != '\0') {
char *end;
int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
- int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;
+ int gotPrecision, sawFlag, useShort = 0, useBig = 0;
+ Tcl_WideInt width, precision;
#ifndef TCL_WIDE_INT_IS_LONG
int useWide = 0;
#endif
- int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
+ int newXpg, allocSegment = 0;
+ Tcl_Size numChars, segmentLimit, segmentNumBytes;
Tcl_Obj *segment;
int step = TclUtfToUniChar(format, &ch);
@@ -2015,12 +2309,16 @@ Tcl_AppendFormatToObj(
width = 0;
if (isdigit(UCHAR(ch))) {
- width = strtoul(format, &end, 10);
- if (width < 0) {
+ /* Note ull will be >= 0 because of isdigit check above */
+ unsigned long long ull;
+ ull = strtoull(format, &end, 10);
+ /* Comparison is >=, not >, to leave room for nul */
+ if (ull >= WIDE_MAX) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
+ width = (Tcl_WideInt)ull;
format = end;
step = TclUtfToUniChar(format, &ch);
} else if (ch == '*') {
@@ -2029,7 +2327,7 @@ Tcl_AppendFormatToObj(
errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
- if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
goto error;
}
if (width < 0) {
@@ -2057,7 +2355,16 @@ Tcl_AppendFormatToObj(
step = TclUtfToUniChar(format, &ch);
}
if (isdigit(UCHAR(ch))) {
- precision = strtoul(format, &end, 10);
+ /* Note ull will be >= 0 because of isdigit check above */
+ unsigned long long ull;
+ ull = strtoull(format, &end, 10);
+ /* Comparison is >=, not >, to leave room for nul */
+ if (ull >= WIDE_MAX) {
+ msg = overflow;
+ errCode = "OVERFLOW";
+ goto errorMsg;
+ }
+ precision = (Tcl_WideInt)ull;
format = end;
step = TclUtfToUniChar(format, &ch);
} else if (ch == '*') {
@@ -2066,7 +2373,7 @@ Tcl_AppendFormatToObj(
errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
goto errorMsg;
}
- if (TclGetIntFromObj(interp, objv[objIndex], &precision)
+ if (TclGetWideIntFromObj(interp, objv[objIndex], &precision)
!= TCL_OK) {
goto error;
}
@@ -2103,6 +2410,25 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if (ch == 'I') {
+ if ((format[1] == '6') && (format[2] == '4')) {
+ format += (step + 2);
+ step = TclUtfToUniChar(format, &ch);
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+#endif
+ } else if ((format[1] == '3') && (format[2] == '2')) {
+ format += (step + 2);
+ step = TclUtfToUniChar(format, &ch);
+ } else {
+ format += step;
+ step = TclUtfToUniChar(format, &ch);
+ }
+ } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j')
+ || (ch == 'L')) {
+ format += step;
+ step = TclUtfToUniChar(format, &ch);
+ useBig = 1;
}
format += step;
@@ -2124,12 +2450,12 @@ Tcl_AppendFormatToObj(
goto errorMsg;
case 's':
if (gotPrecision) {
- numChars = Tcl_GetCharLength(segment);
+ numChars = TclGetCharLength(segment);
if (precision < numChars) {
if (precision < 1) {
TclNewObj(segment);
} else {
- segment = Tcl_GetRange(segment, 0, precision - 1);
+ segment = TclGetRange(segment, 0, precision - 1);
}
numChars = precision;
Tcl_IncrRefCount(segment);
@@ -2144,13 +2470,14 @@ Tcl_AppendFormatToObj(
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
goto error;
}
+ if ((unsigned)code > 0x10FFFF) {
+ code = 0xFFFD;
+ }
length = Tcl_UniCharToUtf(code, buf);
-#if TCL_UTF_MAX > 3
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;
@@ -2158,14 +2485,10 @@ Tcl_AppendFormatToObj(
}
case 'u':
- if (useBig) {
- msg = "unsigned bignum format is invalid";
- errCode = "BADUNSIGNED";
- goto errorMsg;
- }
/* FALLTHRU */
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -2174,60 +2497,66 @@ Tcl_AppendFormatToObj(
long l;
Tcl_WideInt w;
mp_int big;
- int toAppend, isNegative = 0;
+ int isNegative = 0;
+ Tcl_Size toAppend;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (ch == 'p') {
+ useWide = 1;
+ }
+#endif
if (useBig) {
+ int cmpResult;
if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
- isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+ cmpResult = mp_cmp_d(&big, 0);
+ isNegative = (cmpResult == MP_LT);
+ if (cmpResult == MP_EQ) gotHash = 0;
+ if (ch == 'u') {
+ if (isNegative) {
+ mp_clear(&big);
+ msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
+ goto errorMsg;
+ } else {
+ ch = 'd';
+ }
+ }
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, CHAR_BIT*sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- Tcl_GetWideIntFromObj(NULL, objPtr, &w);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
+ if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &l);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
} else {
- l = Tcl_WideAsLong(w);
+ l = (long) w;
}
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
} else if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
TclNewObj(segment);
allocSegment = 1;
- segmentLimit = INT_MAX;
+ segmentLimit = TCL_SIZE_MAX;
Tcl_IncrRefCount(segment);
if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) {
@@ -2236,18 +2565,15 @@ Tcl_AppendFormatToObj(
segmentLimit -= 1;
}
- if (gotHash) {
+ if (gotHash || (ch == 'p')) {
switch (ch) {
case 'o':
- Tcl_AppendToObj(segment, "0", 1);
- segmentLimit -= 1;
- precision--;
- break;
- case 'X':
- Tcl_AppendToObj(segment, "0X", 2);
+ Tcl_AppendToObj(segment, "0o", 2);
segmentLimit -= 2;
break;
+ case 'p':
case 'x':
+ case 'X':
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
@@ -2255,25 +2581,29 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+ case 'd':
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ break;
}
}
switch (ch) {
case 'd': {
- int length;
+ Tcl_Size length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
- TclNewIntObj(pure, (int) s);
+ TclNewIntObj(pure, s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- pure = Tcl_NewWideIntObj(w);
+ TclNewIntObj(pure, w);
#endif
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
- pure = Tcl_NewLongObj(l);
+ TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
bytes = TclGetStringFromObj(pure, &length);
@@ -2305,7 +2635,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2326,12 +2656,14 @@ Tcl_AppendFormatToObj(
case 'u':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
- Tcl_WideUInt bits = (Tcl_WideUInt) 0;
- Tcl_WideInt numDigits = (Tcl_WideInt) 0;
- int length, numBits = 4, base = 16, index = 0, shift = 0;
+ Tcl_WideUInt bits = 0;
+ Tcl_WideInt numDigits = 0;
+ int numBits = 4, base = 16, index = 0, shift = 0;
+ Tcl_Size length;
Tcl_Obj *pure;
char *bytes;
@@ -2362,7 +2694,7 @@ Tcl_AppendFormatToObj(
uw /= base;
}
#endif
- } else if (useBig && big.used) {
+ } else if (useBig && !mp_iszero(&big)) {
int leftover = (big.used * MP_DIGIT_BIT) % numBits;
mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
@@ -2391,17 +2723,17 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
TclNewObj(pure);
- Tcl_SetObjLength(pure, (int) numDigits);
+ Tcl_SetObjLength(pure, numDigits);
bytes = TclGetString(pure);
- toAppend = length = (int) numDigits;
+ toAppend = length = numDigits;
while (numDigits--) {
int digitOffset;
- if (useBig && big.used) {
+ if (useBig && !mp_iszero(&big)) {
if (index < big.used && (size_t) shift <
CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
@@ -2409,7 +2741,7 @@ Tcl_AppendFormatToObj(
}
shift -= numBits;
}
- digitOffset = (int) (bits % base);
+ digitOffset = bits % base;
if (digitOffset > 9) {
if (ch == 'X') {
bytes[numDigits] = 'A' + digitOffset - 10;
@@ -2435,7 +2767,7 @@ Tcl_AppendFormatToObj(
gotZero = 0;
}
if (gotZero) {
- length += Tcl_GetCharLength(segment);
+ length += TclGetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
@@ -2458,6 +2790,8 @@ Tcl_AppendFormatToObj(
break;
}
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
@@ -2490,15 +2824,15 @@ Tcl_AppendFormatToObj(
*p++ = '+';
}
if (width) {
- p += snprintf(p, TCL_INTEGER_SPACE, "%d", width);
+ p += snprintf(p, TCL_INTEGER_SPACE, "%" TCL_LL_MODIFIER "d", width);
if (width > length) {
length = width;
}
}
if (gotPrecision) {
*p++ = '.';
- p += snprintf(p, TCL_INTEGER_SPACE, "%d", precision);
- if (precision > INT_MAX - length) {
+ p += snprintf(p, TCL_INTEGER_SPACE, "%" TCL_LL_MODIFIER "d", precision);
+ if (precision > TCL_SIZE_MAX - length) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
@@ -2526,19 +2860,25 @@ Tcl_AppendFormatToObj(
errCode = "OVERFLOW";
goto errorMsg;
}
+ if (ch == 'A') {
+ char *q = TclGetString(segment) + 1;
+ *q = 'x';
+ q = strchr(q, 'P');
+ if (q) *q = 'p';
+ }
break;
}
default:
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (void *)NULL);
}
goto error;
}
if (width>0 && numChars<0) {
- numChars = Tcl_GetCharLength(segment);
+ numChars = TclGetCharLength(segment);
}
if (!gotMinus && width>0) {
if (numChars < width) {
@@ -2592,7 +2932,7 @@ Tcl_AppendFormatToObj(
errorMsg:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, (void *)NULL);
}
error:
Tcl_SetObjLength(appendObj, originalLength);
@@ -2617,7 +2957,7 @@ Tcl_Obj *
Tcl_Format(
Tcl_Interp *interp,
const char *format,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
int result;
@@ -2650,7 +2990,8 @@ AppendPrintfToObjVA(
const char *format,
va_list argList)
{
- int code, objc;
+ int code;
+ Tcl_Size objc;
Tcl_Obj **objv, *list;
const char *p;
@@ -2694,22 +3035,27 @@ AppendPrintfToObjVA(
* multi-byte characters.
*/
- q = TclUtfPrev(end, bytes);
- if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
+ q = Tcl_UtfPrev(end, bytes);
+ if (!Tcl_UtfCharComplete(q, end - q)) {
end = q;
}
- q = bytes + TCL_UTF_MAX;
+ q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
}
Tcl_ListObjAppendElement(NULL, list,
- Tcl_NewStringObj(bytes , (int)(end - bytes)));
+ Tcl_NewStringObj(bytes , end - bytes));
break;
}
+ case 'p':
+ if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ /* FALLTHRU */
case 'c':
case 'i':
case 'u':
@@ -2721,34 +3067,49 @@ AppendPrintfToObjVA(
switch (size) {
case -1:
case 0:
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
- (long) va_arg(argList, int)));
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
+ va_arg(argList, int)));
break;
case 1:
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
va_arg(argList, long)));
break;
+ case 2:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
+ va_arg(argList, Tcl_WideInt)));
+ break;
+ case 3:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj(
+ va_arg(argList, mp_int *)));
+ break;
}
break;
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
+ if (size > 0) {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
- va_arg(argList, double)));
+ (double)va_arg(argList, long double)));
+ } else {
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
+ va_arg(argList, double)));
+ }
seekingConversion = 0;
break;
case '*':
- lastNum = (int) va_arg(argList, int);
- Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum));
+ lastNum = va_arg(argList, int);
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': {
char *end;
- lastNum = (int) strtoul(p, &end, 10);
+ lastNum = strtoul(p, &end, 10);
p = end;
break;
}
@@ -2756,9 +3117,35 @@ AppendPrintfToObjVA(
gotPrecision = 1;
p++;
break;
- /* TODO: support for wide (and bignum?) arguments */
case 'l':
- size = 1;
+ ++size;
+ p++;
+ break;
+ case 't':
+ case 'z':
+ if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ p++;
+ break;
+ case 'j':
+ case 'q':
+ size = 2;
+ p++;
+ break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ } else if (p[1]=='3' && p[2]=='2') {
+ p += 2;
+ } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ p++;
+ break;
+ case 'L':
+ size = 3;
p++;
break;
case 'h':
@@ -2769,7 +3156,7 @@ AppendPrintfToObjVA(
}
} while (seekingConversion);
}
- TclListObjGetElements(NULL, list, &objc, &objv);
+ TclListObjGetElementsM(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
@@ -2857,16 +3244,942 @@ TclGetStringStorage(
Tcl_Obj *objPtr,
unsigned int *sizePtr)
{
- String *stringPtr;
+ UniCharString *stringPtr;
- if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) {
- return TclGetStringFromObj(objPtr, (int *)sizePtr);
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) {
+ return TclGetStringFromObj(objPtr, (Tcl_Size *)sizePtr);
}
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringRepeat --
+ *
+ * Performs the [string repeat] function.
+ *
+ * Results:
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
+ *
+ * Side effects:
+ * On error, when interp is not NULL, error information is left in it.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringRepeat(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Size count,
+ int flags)
+{
+ Tcl_Obj *objResultPtr;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ Tcl_Size length = 0;
+ int unichar = 0;
+ Tcl_Size done = 1;
+ int binary = TclIsPureByteArray(objPtr);
+
+ /* assert (count >= 2) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ if (!binary) {
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
+ if (stringPtr->hasUnicode) {
+ unichar = 1;
+ }
+ }
+ }
+
+ if (binary) {
+ /* Result will be pure byte array. Pre-size it */
+ Tcl_GetByteArrayFromObj(objPtr, &length);
+ } else if (unichar) {
+ /* Result will be pure Tcl_UniChar array. Pre-size it. */
+ TclGetUnicodeFromObj(objPtr, &length);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ TclGetStringFromObj(objPtr, &length);
+ }
+
+ if (length == 0) {
+ /* Any repeats of empty is empty. */
+ return objPtr;
+ }
+
+ if (count > INT_MAX/length) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%" TCL_SIZE_MODIFIER
+ "d bytes) exceeded", TCL_SIZE_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
+ Tcl_DuplicateObj(objPtr) : objPtr;
+
+ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
+ Tcl_SetByteArrayLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ TclAppendBytesToByteArray(objResultPtr,
+ Tcl_GetByteArrayFromObj(objResultPtr, (Tcl_Size *) NULL),
+ (count - done) * length);
+ } else if (unichar) {
+ /*
+ * Efficiently produce a pure Tcl_UniChar array result.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = TclNewUnicodeObj(TclGetUnicodeFromObj(objPtr, NULL), length);
+ } else {
+ TclInvalidateStringRep(objPtr);
+ objResultPtr = objPtr;
+ }
+
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(count*length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ TclAppendUnicodeToObj(objResultPtr, TclGetUnicodeFromObj(objResultPtr, NULL),
+ (count - done) * length);
+ } else {
+ /*
+ * Efficiently concatenate string reps.
+ */
+
+ if (!inPlace || Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
+ } else {
+ TclFreeInternalRep(objPtr);
+ objResultPtr = objPtr;
+ }
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
+ count*length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
+ (count - done) * length);
+ }
+ return objResultPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCat --
+ *
+ * Performs the [string cat] function.
+ *
+ * Results:
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
+ *
+ * Side effects:
+ * On error, when interp is not NULL, error information is left in it.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringCat(
+ Tcl_Interp *interp,
+ Tcl_Size objc,
+ Tcl_Obj * const objv[],
+ int flags)
+{
+ Tcl_Obj *objResultPtr, * const *ov;
+ int binary = 1;
+ Tcl_Size oc, length = 0;
+ int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0;
+ Tcl_Size first = objc - 1; /* Index of first value possibly not empty */
+ Tcl_Size last = 0; /* Index of last value possibly not empty */
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+
+ /* assert ( objc >= 0 ) */
+
+ if (objc <= 1) {
+ if (objc != 1) {
+ /* Negative (shouldn't be) no objects; return empty */
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+ /* One object; return first */
+ return objv[0];
+ }
+
+ /* assert ( objc >= 2 ) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ ov = objv, oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ if (TclIsPureByteArray(objPtr)) {
+ allowUniChar = 0;
+ } else if (objPtr->bytes) {
+ /* Value has a string rep. */
+ if (objPtr->length) {
+ /*
+ * Non-empty string rep. Not a pure bytearray, so we won't
+ * create a pure bytearray.
+ */
+
+ binary = 0;
+ if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
+ forceUniChar = 1;
+ } else if ((objPtr->typePtr) && (objPtr->typePtr != &tclUniCharStringType)) {
+ /* Prevent shimmer of non-string types. */
+ allowUniChar = 0;
+ }
+ }
+ } else {
+ /* assert (objPtr->typePtr != NULL) -- stork! */
+ binary = 0;
+ if (TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ /* Have a pure Unicode value; ask to preserve it */
+ requestUniChar = 1;
+ } else {
+ /* Have another type; prevent shimmer */
+ allowUniChar = 0;
+ }
+ }
+ } while (--oc && (binary || allowUniChar));
+
+ if (binary) {
+ /*
+ * Result will be pure byte array. Pre-size it
+ */
+
+ Tcl_Size numBytes;
+ ov = objv;
+ oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to count bytes for the empty strings.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
+
+ if (numBytes) {
+ last = objc - oc;
+ if (length == 0) {
+ first = last;
+ }
+ if (length > (TCL_SIZE_MAX-numBytes)) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ }
+ } while (--oc);
+ } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ /*
+ * Result will be pure Tcl_UniChar array. Pre-size it.
+ */
+
+ ov = objv;
+ oc = objc;
+ do {
+ Tcl_Obj *objPtr = *ov++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ Tcl_Size numChars;
+
+ TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
+ if (numChars) {
+ last = objc - oc;
+ if (length == 0) {
+ first = last;
+ } else if (length > TCL_SIZE_MAX - numChars) {
+ goto overflow;
+ }
+ length += numChars;
+ }
+ }
+ } while (--oc);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ ov = objv; oc = objc;
+ do {
+ Tcl_Obj *pendingPtr = NULL;
+
+ /*
+ * Loop until a possibly non-empty value is reached.
+ * Keep string rep generation pending when possible.
+ */
+
+ do {
+ /* assert ( pendingPtr == NULL ) */
+ /* assert ( length == 0 ) */
+
+ Tcl_Obj *objPtr = *ov++;
+
+ if (objPtr->bytes == NULL) {
+ /* No string rep; Take the chance we can avoid making it */
+ pendingPtr = objPtr;
+ } else {
+ TclGetStringFromObj(objPtr, &length); /* PANIC? */
+ }
+ } while (--oc && (length == 0) && (pendingPtr == NULL));
+
+ /*
+ * Either we found a possibly non-empty value, and we remember
+ * this index as the first and last such value so far seen,
+ * or (oc == 0) and all values are known empty,
+ * so first = last = objc - 1 signals the right quick return.
+ */
+
+ first = last = objc - oc - 1;
+
+ if (oc && (length == 0)) {
+ Tcl_Size numBytes;
+
+ /* assert ( pendingPtr != NULL ) */
+
+ /*
+ * There's a pending value followed by more values. Loop over
+ * remaining values generating strings until a non-empty value
+ * is found, or the pending value gets its string generated.
+ */
+
+ do {
+ Tcl_Obj *objPtr = *ov++;
+ TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+ if (numBytes) {
+ last = objc -oc -1;
+ }
+ if (oc || numBytes) {
+ TclGetStringFromObj(pendingPtr, &length);
+ }
+ if (length == 0) {
+ if (numBytes) {
+ first = last;
+ }
+ } else if (numBytes > TCL_SIZE_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ } while (oc && (length == 0));
+
+ while (oc) {
+ Tcl_Size numBytes;
+ Tcl_Obj *objPtr = *ov++;
+
+ /* assert ( length > 0 && pendingPtr == NULL ) */
+
+ TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ if (numBytes) {
+ last = objc - oc;
+ if (numBytes > TCL_SIZE_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ --oc;
+ }
+ }
+
+ if (last <= first /*|| length == 0 */) {
+ /* Only one non-empty value or zero length; return first */
+ /* NOTE: (length == 0) implies (last <= first) */
+ return objv[first];
+ }
+
+ objv += first; objc = (last - first + 1);
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ unsigned char *dst;
+
+ /*
+ * Broken interface! Byte array value routines offer no way to handle
+ * failure to allocate enough space. Following stanza may panic.
+ */
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ Tcl_Size start;
+
+ objResultPtr = *objv++; objc--;
+ Tcl_GetByteArrayFromObj(objResultPtr, &start);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
+ } else {
+ objResultPtr = Tcl_NewByteArrayObj(NULL, length);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ /*
+ * Every argument is either a bytearray with a ("pure")
+ * value we know we can safely use, or it is an empty string.
+ * We don't need to copy bytes from the empty strings.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ Tcl_Size more;
+ unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
+ memcpy(dst, src, more);
+ dst += more;
+ }
+ }
+ } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ /* Efficiently produce a pure Tcl_UniChar array result */
+ Tcl_UniChar *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ Tcl_Size start;
+
+ objResultPtr = *objv++; objc--;
+
+ /* Ugly interface! Force resize of the unicode array. */
+ TclGetUnicodeFromObj(objResultPtr, &start);
+ Tcl_InvalidateStringRep(objResultPtr);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ dst = TclGetUnicodeFromObj(objResultPtr, NULL) + start;
+ } else {
+ Tcl_UniChar ch = 0;
+
+ /* Ugly interface! No scheme to init array size. */
+ objResultPtr = TclNewUnicodeObj(&ch, 0); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ Tcl_DecrRefCount(objResultPtr);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_Z_MODIFIER "u bytes",
+ UNICHAR_STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ dst = TclGetUnicodeFromObj(objResultPtr, NULL);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ Tcl_Size more;
+ Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more);
+ memcpy(dst, src, more * sizeof(Tcl_UniChar));
+ dst += more;
+ }
+ }
+ } else {
+ /* Efficiently concatenate string reps */
+ char *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ Tcl_Size start;
+
+ objResultPtr = *objv++; objc--;
+
+ TclGetStringFromObj(objResultPtr, &start);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetString(objResultPtr) + start;
+
+ /* assert ( length > start ) */
+ TclFreeInternalRep(objResultPtr);
+ } else {
+ TclNewObj(objResultPtr); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ Tcl_DecrRefCount(objResultPtr);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ dst = Tcl_GetString(objResultPtr);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ Tcl_Size more;
+ char *src = TclGetStringFromObj(objPtr, &more);
+
+ memcpy(dst, src, more);
+ dst += more;
+ }
+ }
+ /* Must NUL-terminate! */
+ *dst = '\0';
+ }
+ return objResultPtr;
+
+ overflow:
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCmp --
+ * Compare two Tcl_Obj values as strings.
+ *
+ * Results:
+ * Like memcmp, return -1, 0, or 1.
+ *
+ * Side effects:
+ * String representations may be generated. Internal representation may
+ * be changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringCmp(
+ Tcl_Obj *value1Ptr,
+ Tcl_Obj *value2Ptr,
+ int checkEq, /* comparison is only for equality */
+ int nocase, /* comparison is not case sensitive */
+ Tcl_Size reqlength) /* requested length in characters;
+ * negative to compare whole strings */
+{
+ const char *s1, *s2;
+ int empty, match;
+ Tcl_Size length, s1len, s2len;
+ memCmpFn_t memCmpFn;
+
+ if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
+ /*
+ * Always match at 0 chars of if it is the same obj.
+ * Note: as documented reqlength negative means it is ignored
+ */
+ match = 0;
+ } else {
+ if (!nocase && TclIsPureByteArray(value1Ptr)
+ && TclIsPureByteArray(value2Ptr)) {
+ /*
+ * Use binary versions of comparisons since that won't cause undue
+ * type conversions and it is much faster. Only do this if we're
+ * case-sensitive (which is all that really makes sense with byte
+ * arrays anyway, and we have no memcasecmp() for some reason... :^)
+ */
+
+ s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
+ s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+ memCmpFn = memcmp;
+ } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType)
+ && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) {
+ /*
+ * Do a Unicode-specific comparison if both of the args are of String
+ * type. If the char length == byte length, we can do a memcmp. In
+ * benchmark testing this proved the most efficient check between the
+ * Unicode and string comparison operations.
+ */
+
+ if (nocase) {
+ s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len);
+ s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len);
+ memCmpFn = (memCmpFn_t)(void *)TclUniCharNcasecmp;
+ } else {
+ s1len = TclGetCharLength(value1Ptr);
+ s2len = TclGetCharLength(value2Ptr);
+ if ((s1len == value1Ptr->length)
+ && (value1Ptr->bytes != NULL)
+ && (s2len == value2Ptr->length)
+ && (value2Ptr->bytes != NULL)) {
+ /* each byte represents one character so s1l3n, s2l3n, and
+ * reqlength are in both bytes and characters
+ */
+ s1 = value1Ptr->bytes;
+ s2 = value2Ptr->bytes;
+ memCmpFn = memcmp;
+ } else {
+ s1 = (char *) TclGetUnicodeFromObj(value1Ptr, NULL);
+ s2 = (char *) TclGetUnicodeFromObj(value2Ptr, NULL);
+ if (
+#if defined(WORDS_BIGENDIAN)
+ 1
+#else
+ checkEq
+#endif
+ ) {
+ memCmpFn = memcmp;
+ s1len *= sizeof(Tcl_UniChar);
+ s2len *= sizeof(Tcl_UniChar);
+ if (reqlength > 0) {
+ reqlength *= sizeof(Tcl_UniChar);
+ }
+ } else {
+ memCmpFn = (memCmpFn_t)(void *)TclUniCharNcmp;
+ }
+ }
+ }
+ } else {
+ empty = TclCheckEmptyString(value1Ptr);
+ if (empty > 0) {
+ switch (TclCheckEmptyString(value2Ptr)) {
+ case -1:
+ s1 = 0;
+ s1len = 0;
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ break;
+ case 0:
+ match = -1;
+ goto matchdone;
+ case 1:
+ default: /* avoid warn: `s2` may be used uninitialized */
+ match = 0;
+ goto matchdone;
+ }
+ } else if (TclCheckEmptyString(value2Ptr) > 0) {
+ switch (empty) {
+ case -1:
+ s2 = 0;
+ s2len = 0;
+ s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ break;
+ case 0:
+ match = 1;
+ goto matchdone;
+ case 1:
+ default: /* avoid warn: `s1` may be used uninitialized */
+ match = 0;
+ goto matchdone;
+ }
+ } else {
+ s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ }
+ if (!nocase && checkEq && reqlength < 0) {
+ /*
+ * When we have equal-length we can check only for
+ * (in)equality. We can use memcmp in all (n)eq cases because
+ * we don't need to worry about lexical LE/BE variance.
+ */
+
+ memCmpFn = memcmp;
+ } else {
+ /*
+ * As a catch-all we will work with UTF-8. We cannot use
+ * memcmp() as that is unsafe with any string containing NUL
+ * (\xC0\x80 in Tcl's utf rep). We can use the more efficient
+ * TclpUtfNcmp2 if we are case-sensitive and no specific
+ * length was requested.
+ */
+
+ if ((reqlength < 0) && !nocase) {
+ memCmpFn = (memCmpFn_t)(void *)TclpUtfNcmp2;
+ } else {
+ s1len = TclNumUtfChars(s1, s1len);
+ s2len = TclNumUtfChars(s2, s2len);
+ memCmpFn = (memCmpFn_t)(void *)
+ (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
+ }
+ }
+ }
+
+ /* At this point s1len, s2len, and reqlength should by now have been
+ * adjusted so that they are all in the units expected by the selected
+ * comparison function.
+ */
+ length = (s1len < s2len) ? s1len : s2len;
+ if (reqlength < 0) {
+ /*
+ * The requested length is negative, so ignore it by setting it
+ * to length + 1 to correct the match var.
+ */
+
+ reqlength = length + 1;
+ } else if (reqlength > 0 && reqlength < length) {
+ length = reqlength;
+ }
+
+ if (checkEq && reqlength < 0 && (s1len != s2len)) {
+ match = 1; /* This will be reversed below. */
+ } else {
+ /*
+ * The comparison function should compare up to the minimum byte
+ * length only.
+ */
+
+ match = memCmpFn(s1, s2, length);
+ }
+ if ((match == 0) && (reqlength > length)) {
+ match = s1len - s2len;
+ }
+ match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
+ }
+ matchdone:
+ return match;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringFirst --
+ *
+ * Implements the [string first] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * first instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringFirst(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ Tcl_Size start)
+{
+ Tcl_Size lh, ln = TclGetCharLength(needle);
+ Tcl_Size value = TCL_INDEX_NONE;
+ Tcl_UniChar *checkStr, *endStr, *uh, *un;
+ Tcl_Obj *obj;
+
+ if (start < 0) {
+ start = 0;
+ }
+ if (ln == 0) {
+ /* We don't find empty substrings. Bizarre!
+ * Whenever this routine is turned into a proper substring
+ * finder, change to `return start` after limits imposed. */
+ goto firstEnd;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *end, *check, *bh;
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ /* Find bytes in bytes */
+ bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+ if ((lh < ln) || (start > lh - ln)) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto firstEnd;
+ }
+ end = bh + lh;
+
+ check = bh + start;
+ while (check + ln <= end) {
+ /*
+ * Look for the leading byte of the needle in the haystack
+ * starting at check and stopping when there's not enough room
+ * for the needle left.
+ */
+ check = (unsigned char *)memchr(check, bn[0], (end + 1 - ln) - check);
+ if (check == NULL) {
+ /* Leading byte not found -> needle cannot be found. */
+ goto firstEnd;
+ }
+ /* Leading byte found, check rest of needle. */
+ if (0 == memcmp(check+1, bn+1, ln-1)) {
+ /* Checks! Return the successful index. */
+ value = (check - bh);
+ goto firstEnd;
+ }
+ /* Rest of needle match failed; Iterate to continue search. */
+ check++;
+ }
+ goto firstEnd;
+ }
+
+ /*
+ * TODO: It might be nice to support some cases where it is not
+ * necessary to shimmer to &tclStringType to compute the result,
+ * and instead operate just on the objPtr->bytes values directly.
+ * However, we also do not want the answer to change based on the
+ * code pathway, or if it does we want that to be for some values
+ * we explicitly decline to support. Getting there will involve
+ * locking down in practice more firmly just what encodings produce
+ * what supported results for the objPtr->bytes values. For now,
+ * do only the well-defined Tcl_UniChar array search.
+ */
+
+ un = TclGetUnicodeFromObj(needle, &ln);
+ uh = TclGetUnicodeFromObj(haystack, &lh);
+ if ((lh < ln) || (start > lh - ln)) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto firstEnd;
+ }
+ endStr = uh + lh;
+
+ for (checkStr = uh + start; checkStr + ln <= endStr; checkStr++) {
+ if ((*checkStr == *un) && (0 ==
+ memcmp(checkStr + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
+ value = (checkStr - uh);
+ goto firstEnd;
+ }
+ }
+ firstEnd:
+ TclNewIndexObj(obj, value);
+ return obj;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringLast --
+ *
+ * Implements the [string last] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * last instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringLast(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ Tcl_Size last)
+{
+ Tcl_Size lh, ln = TclGetCharLength(needle);
+ Tcl_Size value = TCL_INDEX_NONE;
+ Tcl_UniChar *checkStr, *uh, *un;
+ Tcl_Obj *obj;
+
+ if (ln == 0) {
+ /*
+ * We don't find empty substrings. Bizarre!
+ *
+ * TODO: When we one day make this a true substring
+ * finder, change this to "return last", after limitation.
+ */
+ goto lastEnd;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ if (last >= lh) {
+ last = lh - 1;
+ }
+ if (last + 1 < ln) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto lastEnd;
+ }
+ check = bh + last + 1 - ln;
+
+ while (check >= bh) {
+ if ((*check == bn[0])
+ && (0 == memcmp(check+1, bn+1, ln-1))) {
+ value = (check - bh);
+ goto lastEnd;
+ }
+ check--;
+ }
+ goto lastEnd;
+ }
+
+ uh = TclGetUnicodeFromObj(haystack, &lh);
+ un = TclGetUnicodeFromObj(needle, &ln);
+
+ if (last >= lh) {
+ last = lh - 1;
+ }
+ if (last + 1 < ln) {
+ /* Don't start the loop if there cannot be a valid answer */
+ goto lastEnd;
+ }
+ checkStr = uh + last + 1 - ln;
+ while (checkStr >= uh) {
+ if ((*checkStr == un[0])
+ && (0 == memcmp(checkStr+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ value = (checkStr - uh);
+ goto lastEnd;
+ }
+ checkStr--;
+ }
+ lastEnd:
+ TclNewIndexObj(obj, value);
+ return obj;
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -2875,9 +4188,9 @@ TclGetStringStorage(
* Implements the [string reverse] operation.
*
* Results:
- * An unshared Tcl value which is the [string reverse] of the argument
- * supplied. When sharing rules permit, the returned value might be the
- * argument with modifications done in place.
+ * A Tcl value which is the [string reverse] of the argument supplied.
+ * When sharing rules permit and the caller requests, the returned value
+ * might be the argument with modifications done in place.
*
* Side effects:
* May allocate a new Tcl_Obj.
@@ -2889,7 +4202,7 @@ static void
ReverseBytes(
unsigned char *to, /* Copy bytes into here... */
unsigned char *from, /* ...from here... */
- int count) /* Until this many are copied, */
+ Tcl_Size count) /* Until this many are copied, */
/* reversing as you go. */
{
unsigned char *src = from + count;
@@ -2911,99 +4224,65 @@ ReverseBytes(
Tcl_Obj *
TclStringReverse(
- Tcl_Obj *objPtr)
+ Tcl_Obj *objPtr,
+ int flags)
{
- String *stringPtr;
+ UniCharString *stringPtr;
Tcl_UniChar ch = 0;
-#if TCL_UTF_MAX <= 4
- int needFlip = 0;
-#endif
+ int inPlace = flags & TCL_STRING_IN_PLACE;
if (TclIsPureByteArray(objPtr)) {
- int numBytes;
+ Tcl_Size numBytes;
unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
}
- ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes);
+ ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)NULL), from, numBytes);
return objPtr;
}
SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
if (stringPtr->hasUnicode) {
- Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
+ Tcl_UniChar *from = TclGetUnicodeFromObj(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
Tcl_UniChar *to;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
/*
* Create a non-empty, pure Unicode value, so we can coax
* Tcl_SetObjLength into growing the Unicode rep buffer.
*/
- objPtr = Tcl_NewUnicodeObj(&ch, 1);
+ objPtr = TclNewUnicodeObj(&ch, 1);
Tcl_SetObjLength(objPtr, stringPtr->numChars);
- to = Tcl_GetUnicode(objPtr);
+ to = TclGetUnicodeFromObj(objPtr, NULL);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
while (--src >= from) {
-#if TCL_UTF_MAX <= 4
- ch = *src;
- if ((ch & 0xF800) == 0xD800) {
- needFlip = 1;
- }
- *to++ = ch;
-#else
*to++ = *src;
-#endif
}
} else {
/*
* Reversing in place.
*/
-#if TCL_UTF_MAX <= 4
- to = src;
-#endif
while (--src > from) {
ch = *src;
-#if TCL_UTF_MAX <= 4
- if ((ch & 0xF800) == 0xD800) {
- needFlip = 1;
- }
-#endif
*src = *from;
*from++ = ch;
}
}
-#if TCL_UTF_MAX <= 4
- if (needFlip) {
- /*
- * Flip back surrogate pairs.
- */
-
- from = to - stringPtr->numChars;
- while (--to >= from) {
- ch = *to;
- if ((ch & 0xFC00) == 0xD800) {
- if ((to-1 >= from) && ((to[-1] & 0xFC00) == 0xDC00)) {
- to[0] = to[-1];
- to[-1] = ch;
- --to;
- }
- }
- }
- }
-#endif
}
if (objPtr->bytes) {
- int numChars = stringPtr->numChars;
- int numBytes = objPtr->length;
+ Tcl_Size numChars = stringPtr->numChars;
+ Tcl_Size numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
TclNewObj(objPtr);
Tcl_SetObjLength(objPtr, numBytes);
}
@@ -3019,7 +4298,7 @@ TclStringReverse(
* Pass 1. Reverse the bytes of each multi-byte character.
*/
- int bytesLeft = numBytes;
+ Tcl_Size bytesLeft = numBytes;
int chw;
while (bytesLeft) {
@@ -3029,7 +4308,7 @@ TclStringReverse(
* skip calling Tcl_UtfCharComplete() here.
*/
- int bytesInChar = TclUtfToUCS4(from, &chw);
+ int bytesInChar = Tcl_UtfToUniChar(from, &chw);
ReverseBytes((unsigned char *)to, (unsigned char *)from,
bytesInChar);
@@ -3050,6 +4329,150 @@ TclStringReverse(
/*
*---------------------------------------------------------------------------
*
+ * TclStringReplace --
+ *
+ * Implements the inner engine of the [string replace] and
+ * [string insert] commands.
+ *
+ * The result is a concatenation of a prefix from objPtr, characters
+ * 0 through first-1, the insertPtr string value, and a suffix from
+ * objPtr, characters from first + count to the end. The effect is as if
+ * the inner substring of characters first through first+count-1 are
+ * removed and replaced with insertPtr. If insertPtr is NULL, it is
+ * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE,
+ * this routine will try to do the work within objPtr, so long as no
+ * sharing forbids it. Without that request, or as needed, a new Tcl
+ * value will be allocated to be the result.
+ *
+ * Results:
+ * A Tcl value that is the result of the substring replacement. May
+ * return NULL in case of an error. When NULL is returned and interp is
+ * non-NULL, error information is left in interp
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringReplace(
+ Tcl_Interp *interp, /* For error reporting, may be NULL */
+ Tcl_Obj *objPtr, /* String to act upon */
+ Tcl_Size first, /* First index to replace */
+ Tcl_Size count, /* How many chars to replace */
+ Tcl_Obj *insertPtr, /* Replacement string, may be NULL */
+ int flags) /* TCL_STRING_IN_PLACE => attempt in-place */
+{
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ Tcl_Obj *result;
+
+ /* Replace nothing with nothing */
+ if ((insertPtr == NULL) && (count <= 0)) {
+ if (inPlace) {
+ return objPtr;
+ } else {
+ return Tcl_DuplicateObj(objPtr);
+ }
+ }
+ if (first < 0) {
+ first = 0;
+ }
+
+ /*
+ * The caller very likely had to call Tcl_GetCharLength() or similar
+ * to be able to process index values. This means it is likely that
+ * objPtr is either a proper "bytearray" or a "string" or else it has
+ * a known and short string rep.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ Tcl_Size numBytes;
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
+
+ if (insertPtr == NULL) {
+ /* Replace something with nothing. */
+
+ assert ( first <= numBytes ) ;
+ assert ( count <= numBytes ) ;
+ assert ( first + count <= numBytes ) ;
+
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Replace everything */
+ if ((first == 0) && (count == numBytes)) {
+ return insertPtr;
+ }
+
+ if (TclIsPureByteArray(insertPtr)) {
+ Tcl_Size newBytes;
+ unsigned char *iBytes
+ = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);
+
+ if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
+ /*
+ * Removal count and replacement count are equal.
+ * Other conditions permit. Do in-place splice.
+ */
+
+ memcpy(bytes + first, iBytes, count);
+ Tcl_InvalidateStringRep(objPtr);
+ return objPtr;
+ }
+
+ if (newBytes > (TCL_SIZE_MAX - (numBytes - count))) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded",
+ TCL_SIZE_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
+ }
+ return NULL;
+ }
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
+ /* PANIC? */
+ Tcl_SetByteArrayLength(result, 0);
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, iBytes, newBytes);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Flow through to try other approaches below */
+ }
+
+ /*
+ * TODO: Figure out how not to generate a Tcl_UniChar array rep
+ * when it can be determined objPtr->bytes points to a string of
+ * all single-byte characters so we can index it directly.
+ */
+
+ /* The traditional implementation... */
+ {
+ Tcl_Size numChars;
+ Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars);
+
+ /* TODO: Is there an in-place option worth pursuing here? */
+
+ result = TclNewUnicodeObj(ustring, first);
+ if (insertPtr) {
+ Tcl_AppendObjToObj(result, insertPtr);
+ }
+ if ((first + count) < numChars) {
+ TclAppendUnicodeToObj(result, ustring + first + count,
+ numChars - first - count);
+ }
+
+ return result;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
@@ -3069,7 +4492,7 @@ FillUnicodeRep(
Tcl_Obj *objPtr) /* The object in which to fill the unicode
* rep. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length,
stringPtr->numChars);
@@ -3079,25 +4502,25 @@ static void
ExtendUnicodeRepWithString(
Tcl_Obj *objPtr,
const char *bytes,
- int numBytes,
- int numAppendChars)
+ Tcl_Size numBytes,
+ Tcl_Size numAppendChars)
{
- String *stringPtr = GET_STRING(objPtr);
- int needed, numOrigChars = 0;
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
+ Tcl_Size needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
- if (numAppendChars == -1) {
- TclNumUtfChars(numAppendChars, bytes, numBytes);
+ if (numAppendChars < 0) {
+ TclNumUtfCharsM(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
- stringCheckLimits(needed);
+ uniCharStringCheckLimits(needed);
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
- stringPtr = GET_STRING(objPtr);
+ stringPtr = GET_UNICHAR_STRING(objPtr);
}
stringPtr->hasUnicode = 1;
@@ -3106,9 +4529,20 @@ ExtendUnicodeRepWithString(
} else {
numAppendChars = 0;
}
- for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
+ dst = stringPtr->unicode + numOrigChars;
+ if (numAppendChars-- > 0) {
bytes += TclUtfToUniChar(bytes, &unichar);
- *dst = unichar;
+ /* join upper/lower surrogate */
+ if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) {
+ stringPtr->numChars--;
+ unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000;
+ dst--;
+ }
+ *dst++ = unichar;
+ while (numAppendChars-- > 0) {
+ bytes += TclUtfToUniChar(bytes, &unichar);
+ *dst++ = unichar;
+ }
}
*dst = 0;
}
@@ -3138,17 +4572,15 @@ DupStringInternalRep(
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
- String *srcStringPtr = GET_STRING(srcPtr);
- String *copyStringPtr = NULL;
+ UniCharString *srcStringPtr = GET_UNICHAR_STRING(srcPtr);
+ UniCharString *copyStringPtr = NULL;
-#if COMPAT==0
- if (srcStringPtr->numChars == -1) {
+ if (srcStringPtr->numChars == TCL_INDEX_NONE) {
/*
* The String struct in the source value holds zero useful data. Don't
* bother copying it. Don't even bother allocating space in which to
* copy it. Just let the copy be untyped.
*/
-
return;
}
@@ -3160,17 +4592,17 @@ DupStringInternalRep(
} else {
copyMaxChars = srcStringPtr->maxChars;
}
- copyStringPtr = stringAttemptAlloc(copyMaxChars);
+ copyStringPtr = uniCharStringAttemptAlloc(copyMaxChars);
if (copyStringPtr == NULL) {
copyMaxChars = srcStringPtr->numChars;
- copyStringPtr = stringAlloc(copyMaxChars);
+ copyStringPtr = uniCharStringAlloc(copyMaxChars);
}
copyStringPtr->maxChars = copyMaxChars;
memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
srcStringPtr->numChars * sizeof(Tcl_UniChar));
copyStringPtr->unicode[srcStringPtr->numChars] = 0;
} else {
- copyStringPtr = stringAlloc(0);
+ copyStringPtr = uniCharStringAlloc(0);
copyStringPtr->maxChars = 0;
copyStringPtr->unicode[0] = 0;
}
@@ -3184,44 +4616,9 @@ DupStringInternalRep(
*/
copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0;
-#else /* COMPAT!=0 */
- /*
- * If the src obj is a string of 1-byte Utf chars, then copy the string
- * rep of the source object and create an "empty" Unicode internal rep for
- * the new object. Otherwise, copy Unicode internal rep, and invalidate
- * the string rep of the new object.
- */
-
- if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) {
- /*
- * Copy the full allocation for the Unicode buffer.
- */
-
- copyStringPtr = stringAlloc(srcStringPtr->maxChars);
- copyStringPtr->maxChars = srcStringPtr->maxChars;
- memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
- srcStringPtr->numChars * sizeof(Tcl_UniChar));
- copyStringPtr->unicode[srcStringPtr->numChars] = 0;
- copyStringPtr->allocated = 0;
- } else {
- copyStringPtr = stringAlloc(0);
- copyStringPtr->unicode[0] = 0;
- copyStringPtr->maxChars = 0;
-
- /*
- * Tricky point: the string value was copied by generic object
- * management code, so it doesn't contain any extra bytes that might
- * exist in the source object.
- */
- copyStringPtr->allocated = copyPtr->length;
- }
- copyStringPtr->numChars = srcStringPtr->numChars;
- copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
-#endif /* COMPAT==0 */
-
- SET_STRING(copyPtr, copyStringPtr);
- copyPtr->typePtr = &tclStringType;
+ SET_UNICHAR_STRING(copyPtr, copyStringPtr);
+ copyPtr->typePtr = &tclUniCharStringType;
}
/*
@@ -3236,25 +4633,25 @@ DupStringInternalRep(
*
* Side effects:
* Any old internal representation for objPtr is freed and the internal
- * representation is set to "String".
+ * representation is set to &tclStringType.
*
*----------------------------------------------------------------------
*/
static int
SetStringFromAny(
- Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert. */
{
- if (objPtr->typePtr != &tclStringType) {
- String *stringPtr = stringAlloc(0);
+ if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) {
+ UniCharString *stringPtr = uniCharStringAlloc(0);
/*
* Convert whatever we have into an untyped value. Just A String.
*/
(void) TclGetString(objPtr);
- TclFreeIntRep(objPtr);
+ TclFreeInternalRep(objPtr);
/*
* Create a basic String internalrep that just points to the UTF-8 string
@@ -3265,8 +4662,8 @@ SetStringFromAny(
stringPtr->allocated = objPtr->length;
stringPtr->maxChars = 0;
stringPtr->hasUnicode = 0;
- SET_STRING(objPtr, stringPtr);
- objPtr->typePtr = &tclStringType;
+ SET_UNICHAR_STRING(objPtr, stringPtr);
+ objPtr->typePtr = &tclUniCharStringType;
}
return TCL_OK;
}
@@ -3293,7 +4690,7 @@ static void
UpdateStringOfString(
Tcl_Obj *objPtr) /* Object with string rep to update. */
{
- String *stringPtr = GET_STRING(objPtr);
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
/*
* This routine is only called when we need to generate the
@@ -3306,26 +4703,26 @@ UpdateStringOfString(
stringPtr->allocated = 0;
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitEmptyStringRep(objPtr);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
}
}
-static int
+static Tcl_Size
ExtendStringRepWithUnicode(
Tcl_Obj *objPtr,
const Tcl_UniChar *unicode,
- int numChars)
+ Tcl_Size numChars)
{
/*
* Precondition: this is the "string" Tcl_ObjType.
*/
- int i, origLength, size = 0;
- char *dst, buf[4] = "";
- String *stringPtr = GET_STRING(objPtr);
+ Tcl_Size i, origLength, size = 0;
+ char *dst;
+ UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr);
if (numChars < 0) {
numChars = UnicodeLength(unicode);
@@ -3344,16 +4741,16 @@ ExtendStringRepWithUnicode(
* Quick cheap check in case we have more than enough room.
*/
- if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
+ if (numChars <= (TCL_SIZE_MAX - size)/TCL_UTF_MAX
&& stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
goto copyBytes;
}
for (i = 0; i < numChars && size >= 0; i++) {
- size += (unsigned int)Tcl_UniCharToUtf((int) unicode[i], buf);
+ size += TclUtfCount(unicode[i]);
}
if (size < 0) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER "d bytes) exceeded", TCL_SIZE_MAX);
}
/*
@@ -3367,7 +4764,13 @@ ExtendStringRepWithUnicode(
copyBytes:
dst = objPtr->bytes + origLength;
for (i = 0; i < numChars; i++) {
+ if (LOW_SURROGATE(unicode[i]) && ((i == 0) || !HIGH_SURROGATE(unicode[i-1]))) {
+ *dst = 0; /* In case of lower surrogate, don't try to combine */
+ }
dst += Tcl_UniCharToUtf(unicode[i], dst);
+ if (HIGH_SURROGATE(unicode[i]) && ((i+1 >= numChars) || !LOW_SURROGATE(unicode[i+1]))) {
+ dst += Tcl_UniCharToUtf(-1, dst);
+ }
}
*dst = '\0';
objPtr->length = dst - objPtr->bytes;
@@ -3379,7 +4782,7 @@ ExtendStringRepWithUnicode(
*
* FreeStringInternalRep --
*
- * Deallocate the storage associated with a String data object's internal
+ * Deallocate the storage associated with a (UniChar)String data object's internal
* representation.
*
* Results:
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index 1850f17..aee378d 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -1,29 +1,12 @@
/*
* tclStringRep.h --
*
- * This file contains the definition of the Unicode string internal
- * representation and macros to access it.
+ * This file contains the definition of internal representations of a string
+ * and macros to access it.
*
- * A Unicode string is an internationalized string. Conceptually, a
- * Unicode string is an array of 16-bit quantities organized as a
- * sequence of properly formed UTF-8 characters. There is a one-to-one
- * map between Unicode and UTF characters. Because Unicode characters
- * have a fixed width, operations such as indexing operate on Unicode
- * data. The String object is optimized for the case where each UTF char
- * in a string is only one byte. In this case, we store the value of
- * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode
- * is explicitly called).
- *
- * The String object type stores one or both formats. The default
- * behavior is to store UTF. Once Unicode is calculated by a function, it
- * is stored in the internal rep for future access (without an additional
- * O(n) cost).
- *
- * To allow many appends to be done to an object without constantly
- * reallocating the space for the string or Unicode representation, we
- * allocate double the space for the string or Unicode and use the
- * internal representation to keep track of how much space is used vs.
- * allocated.
+ * Conceptually, a string is a sequence of Unicode code points. Internally
+ * it may be stored in an encoding form such as a modified version of UTF-8
+ * or UTF-16 (when TCL_UTF_MAX=3) or UTF-32.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
@@ -31,43 +14,44 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+
+#ifndef _TCLSTRINGREP
+#define _TCLSTRINGREP
+
/*
* The following structure is the internal rep for a String object. It keeps
* track of how much memory has been used and how much has been allocated for
- * the Unicode and UTF string to enable growing and shrinking of the UTF and
- * Unicode reps of the String object with fewer mallocs. To optimize string
+ * the various representations to enable growing and shrinking of
+ * the String object with fewer mallocs. To optimize string
* length and indexing operations, this structure also stores the number of
- * characters (same of UTF and Unicode!) once that value has been computed.
- *
- * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
- * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
- * can be officially modified by altering the definition of Tcl_UniChar in
- * tcl.h, but do not do that unless you are sure what you're doing!
+ * code points (independent of encoding form) once that value has been computed.
*/
-typedef struct String {
- int numChars; /* The number of chars in the string. -1 means
- * this value has not been calculated. >= 0
- * means that there is a valid Unicode rep, or
- * that the number of UTF bytes == the number
- * of chars. */
- int allocated; /* The amount of space actually allocated for
- * the UTF string (minus 1 byte for the
- * termination char). */
- int maxChars; /* Max number of chars that can fit in the
+typedef struct {
+ Tcl_Size numChars; /* The number of chars in the string.
+ * TCL_INDEX_NONE means this value has not been
+ * calculated. Any other means that there is a valid
+ * Unicode rep, or that the number of UTF bytes ==
+ * the number of chars. */
+ Tcl_Size allocated; /* The amount of space allocated for
+ * the UTF-8 string. Does not include nul
+ * terminator so actual allocation is
+ * (allocated+1). */
+ Tcl_Size maxChars; /* Max number of chars that can fit in the
* space allocated for the Unicode array. */
int hasUnicode; /* Boolean determining whether the string has
- * a Unicode representation. */
- Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size
- * of this field depends on the 'maxChars'
- * field above. */
+ * a Tcl_UniChar representation. */
+ unsigned short unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units.
+ * The actual size of this field depends on
+ * the maxChars field above. */
} String;
+/* Limit on string lengths. The -1 because limit does not include the nul */
#define STRING_MAXCHARS \
- (int)(((size_t)UINT_MAX - TclOffset(String, unicode))/sizeof(Tcl_UniChar) - 1)
+ (Tcl_Size)(((size_t)UINT_MAX - offsetof(String, unicode))/sizeof(unsigned short) - 1)
#define STRING_SIZE(numChars) \
- (TclOffset(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar)))
+ (offsetof(String, unicode) + sizeof(unsigned short) + ((numChars) * sizeof(unsigned short)))
#define stringCheckLimits(numChars) \
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
@@ -76,18 +60,20 @@ typedef struct String {
} \
} while (0)
#define stringAttemptAlloc(numChars) \
- (String *) attemptckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
- (String *) ckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
+ ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
+#endif /* _TCLSTRINGREP */
/*
* Local Variables:
* mode: c
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 34bf824..97f37b0 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -3,7 +3,7 @@
*
* This file contains the initializers for the Tcl stub vectors.
*
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright © 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.
@@ -11,6 +11,7 @@
#include "tclInt.h"
#include "tommath_private.h"
+#include "tclTomMath.h"
#ifdef __CYGWIN__
# include <wchar.h>
@@ -27,6 +28,8 @@
*/
#undef Tcl_Alloc
+#undef Tcl_AttemptAlloc
+#undef Tcl_AttemptRealloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_NewBooleanObj
@@ -35,35 +38,168 @@
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
+#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
+#undef Tcl_GetUnicode
+#undef Tcl_GetUnicodeFromObj
+#undef Tcl_AppendUnicodeToObj
+#undef Tcl_NewUnicodeObj
+#undef Tcl_SetUnicodeObj
+#undef Tcl_UniCharNcasecmp
+#undef Tcl_UniCharCaseMatch
+#undef Tcl_UniCharLen
+#undef Tcl_UniCharNcmp
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
+#undef Tcl_SetExitProc
+#undef Tcl_SetPanicProc
#undef TclpGetPid
#undef TclSockMinimumBuffers
-#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
+#undef Tcl_SetLongObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
-#undef TclBN_mp_tc_and
-#undef TclBN_mp_tc_or
-#undef TclBN_mp_tc_xor
+#undef TclWinNToHS
+#undef TclStaticLibrary
+#undef Tcl_BackgroundError
+#undef TclGuessPackageName
+#undef TclGetLoadedPackages
+#define TclStaticLibrary Tcl_StaticLibrary
+#undef Tcl_UniCharToUtfDString
+#undef Tcl_UtfToUniCharDString
+#undef Tcl_UtfToUniChar
+#undef Tcl_MacOSXOpenBundleResources
+#undef TclWinConvertWSAError
+#undef TclWinConvertError
#undef TclObjInterpProc
+
+#if defined(_WIN32) || defined(__CYGWIN__)
+#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError
+#endif
+
+
+#if defined(TCL_NO_DEPRECATED)
+static void uniCodePanic(void) {
+ Tcl_Panic("Tcl is compiled without the the UTF16 compatibility layer (-DTCL_NO_DEPRECATED)");
+}
+# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic
+# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
+# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_UtfAtIndex (const char *(*)(const char *, int))(void *)uniCodePanic
+# define Tcl_GetCharLength (int(*)(Tcl_Obj *))(void *)uniCodePanic
+# define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic
+# define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic
+# define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic
+# define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic
+# define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic
+# define Tcl_NumUtfChars (int(*)(const char *, int))(void *)uniCodePanic
+#endif
+
+#define TclUtfCharComplete UtfCharComplete
+#define TclUtfNext UtfNext
+#define TclUtfPrev UtfPrev
+
+static int TclUtfCharComplete(const char *src, int length) {
+ if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) {
+ return length < 3;
+ }
+ return Tcl_UtfCharComplete(src, length);
+}
+
+static const char *TclUtfNext(const char *src) {
+ if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) {
+ return src + 1;
+ }
+ return Tcl_UtfNext(src);
+}
+
+static const char *TclUtfPrev(const char *src, const char *start) {
+ if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80)
+ && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) {
+ return src - 3;
+ }
+ return Tcl_UtfPrev(src, start);
+}
+
+#define TclBN_mp_add mp_add
+#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
+#define TclBN_mp_cmp mp_cmp
+#define TclBN_mp_cmp_mag mp_cmp_mag
+#define TclBN_mp_cnt_lsb mp_cnt_lsb
+#define TclBN_mp_copy mp_copy
+#define TclBN_mp_count_bits mp_count_bits
+#define TclBN_mp_div mp_div
+#define TclBN_mp_div_2 mp_div_2
+#define TclBN_mp_div_2d mp_div_2d
+#define TclBN_mp_exch mp_exch
+#define TclBN_mp_get_mag_u64 mp_get_mag_u64
+#define TclBN_mp_grow mp_grow
+#define TclBN_mp_init mp_init
+#define TclBN_mp_init_copy mp_init_copy
+#define TclBN_mp_init_multi mp_init_multi
+#define TclBN_mp_init_size mp_init_size
+#define TclBN_mp_init_i64 mp_init_i64
+#define TclBN_mp_init_u64 mp_init_u64
+#define TclBN_mp_lshd mp_lshd
+#define TclBN_mp_mod mp_mod
+#define TclBN_mp_mod_2d mp_mod_2d
+#define TclBN_mp_mul mp_mul
+#define TclBN_mp_mul_2 mp_mul_2
+#define TclBN_mp_mul_2d mp_mul_2d
+#define TclBN_mp_neg mp_neg
+#define TclBN_mp_or mp_or
+#define TclBN_mp_pack mp_pack
+#define TclBN_mp_pack_count mp_pack_count
+#define TclBN_mp_radix_size mp_radix_size
+#define TclBN_mp_reverse mp_reverse
+#define TclBN_mp_read_radix mp_read_radix
+#define TclBN_mp_rshd mp_rshd
+#define TclBN_mp_set_i64 mp_set_i64
+#define TclBN_mp_set_u64 mp_set_u64
+#define TclBN_mp_shrink mp_shrink
+#define TclBN_mp_sqr mp_sqr
+#define TclBN_mp_sqrt mp_sqrt
+#define TclBN_mp_sub mp_sub
+#define TclBN_mp_signed_rsh mp_signed_rsh
#define TclBN_mp_tc_and TclBN_mp_and
+#define TclBN_mp_tc_div_2d mp_signed_rsh
#define TclBN_mp_tc_or TclBN_mp_or
#define TclBN_mp_tc_xor TclBN_mp_xor
-#define TclStaticPackage Tcl_StaticPackage
-#define TclMacOSXNotifierAddRunLoopMode_ TclMacOSXNotifierAddRunLoopMode
+#define TclBN_mp_to_radix mp_to_radix
+#define TclBN_mp_to_ubin mp_to_ubin
+#define TclBN_mp_ubin_size mp_ubin_size
+#define TclBN_mp_unpack mp_unpack
+#define TclBN_mp_xor mp_xor
+#define TclBN_mp_zero mp_zero
+#define TclBN_s_mp_add s_mp_add
+#define TclBN_s_mp_balance_mul s_mp_balance_mul
+#define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul
+#define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr
+#define TclBN_s_mp_mul_digs s_mp_mul_digs
+#define TclBN_s_mp_mul_digs_fast s_mp_mul_digs_fast
+#define TclBN_s_mp_reverse s_mp_reverse
+#define TclBN_s_mp_sqr s_mp_sqr
+#define TclBN_s_mp_sqr_fast s_mp_sqr_fast
+#define TclBN_s_mp_sub s_mp_sub
+#define TclBN_mp_toom_mul s_mp_toom_mul
+#define TclBN_mp_toom_sqr s_mp_toom_sqr
#define TclUnusedStubEntry 0
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
-#ifdef _WIN64
+#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
@@ -73,33 +209,41 @@ static int TclSockMinimumBuffersOld(int sock, int size)
}
#endif
-MP_SET_UNSIGNED(mp_set_ull, Tcl_WideUInt)
-MP_GET_MAG(mp_get_mag_ull, Tcl_WideUInt)
-MP_SET_SIGNED(mp_set_ll, mp_set_ull, Tcl_WideInt, Tcl_WideUInt)
-
-
mp_err TclBN_mp_set_int(mp_int *a, unsigned long i)
{
- mp_set_ull(a, i);
- return MP_OKAY;
+ TclBN_mp_set_u64(a, i);
+ return MP_OKAY;
}
-mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i)
+static mp_err TclBN_mp_set_long(mp_int *a, unsigned long i)
{
- mp_err result = mp_init(a);
- if (result == MP_OKAY) {
- mp_set_ull(a, i);
- }
- return result;
+ TclBN_mp_set_u64(a, i);
+ return MP_OKAY;
}
-int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
-{
+#define TclBN_mp_set_ul (void (*)(mp_int *a, unsigned long i))(void *)TclBN_mp_set_long
+
+mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) {
return mp_expt_u32(a, b, c);
}
-
-#define TclBN_mp_div_ld TclBNMpDivLd
-static mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *c, Tcl_WideUInt *d) {
+mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_add_d(a, b, c);
+}
+mp_err TclBN_mp_cmp_d(const mp_int *a, unsigned int b) {
+ return mp_cmp_d(a, b);
+}
+mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_sub_d(a, b, c);
+}
+mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *c, unsigned int *d) {
+ mp_digit d2;
+ mp_err result = mp_div_d(a, b, c, (d ? &d2 : NULL));
+ if (d) {
+ *d = d2;
+ }
+ return result;
+}
+mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) {
mp_err result;
mp_digit d2;
@@ -112,6 +256,140 @@ static mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *c, Tcl_Wi
}
return result;
}
+mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
+ return mp_init_set(a, b);
+}
+mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) {
+ return mp_mul_d(a, b, c);
+}
+
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+# define TclBN_mp_expt_d_ex 0
+# define TclBN_mp_to_unsigned_bin 0
+# define TclBN_mp_to_unsigned_bin_n 0
+# define TclBN_mp_toradix_n 0
+# undef TclBN_mp_sqr
+# define TclBN_mp_sqr 0
+# undef TclBN_mp_div_3
+# define TclBN_mp_div_3 0
+# define TclBN_mp_init_l 0
+# define TclBN_mp_init_ul 0
+# define TclBN_mp_set 0
+# define TclSetStartupScriptPath 0
+# define TclGetStartupScriptPath 0
+# define TclSetStartupScriptFileName 0
+# define TclGetStartupScriptFileName 0
+# define TclPrecTraceProc 0
+# define TclpInetNtoa 0
+# define TclWinGetServByName 0
+# define TclWinGetSockOpt 0
+# define TclWinSetSockOpt 0
+# define TclWinNToHS 0
+# define TclWinGetPlatformId 0
+# define TclWinResetInterfaces 0
+# define TclWinSetInterfaces 0
+# define TclWinGetPlatformId 0
+# define Tcl_Backslash 0
+# define Tcl_GetDefaultEncodingDir 0
+# define Tcl_SetDefaultEncodingDir 0
+# define Tcl_EvalTokens 0
+# define Tcl_CreateMathFunc 0
+# define Tcl_GetMathFuncInfo 0
+# define Tcl_ListMathFuncs 0
+# define Tcl_SetIntObj 0
+# define Tcl_SetLongObj 0
+# define Tcl_NewIntObj 0
+# define Tcl_NewLongObj 0
+# define Tcl_DbNewLongObj 0
+# define Tcl_BackgroundError 0
+# define Tcl_FreeResult 0
+# define Tcl_ChannelSeekProc 0
+# define Tcl_ChannelCloseProc 0
+# define Tcl_Close 0
+# define Tcl_MacOSXOpenBundleResources 0
+# define TclGuessPackageName 0
+# define TclGetLoadedPackages 0
+# undef TclSetPreInitScript
+# define TclSetPreInitScript 0
+# define TclInitCompiledLocals 0
+#else
+
+#define TclGuessPackageName guessPackageName
+static int TclGuessPackageName(
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(Tcl_DString *)) {
+ return 0;
+}
+#define TclGetLoadedPackages getLoadedPackages
+static int TclGetLoadedPackages(
+ Tcl_Interp *interp, /* Interpreter in which to return information
+ * or error message. */
+ const char *targetName) /* Name of target interpreter or NULL. If
+ * NULL, return info about all interps;
+ * otherwise, just return info about this
+ * interpreter. */
+{
+ return TclGetLoadedLibraries(interp, targetName, NULL);
+}
+
+mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
+ mp_digit d2;
+ mp_err result = mp_div_d(a, 3, c, &d2);
+ if (d) {
+ *d = d2;
+ }
+ return result;
+}
+
+int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c,
+ TCL_UNUSED(int) /*fast*/)
+{
+ return TclBN_mp_expt_u32(a, b, c);
+}
+
+mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
+{
+ return TclBN_mp_to_ubin(a, b, INT_MAX, NULL);
+}
+
+mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
+{
+ size_t n = TclBN_mp_ubin_size(a);
+ if (*outlen < (unsigned long)n) {
+ return MP_VAL;
+ }
+ *outlen = (unsigned long)n;
+ return TclBN_mp_to_ubin(a, b, n, NULL);
+}
+
+void TclBN_reverse(unsigned char *s, int len)
+{
+ if (len > 0) {
+ TclBN_s_mp_reverse(s, (size_t)len);
+ }
+}
+
+mp_err TclBN_mp_init_ul(mp_int *a, unsigned long b)
+{
+ return TclBN_mp_init_u64(a,b);
+}
+
+mp_err TclBN_mp_init_l(mp_int *a, long b)
+{
+ return TclBN_mp_init_i64(a,b);
+}
+
+void TclBN_mp_set(mp_int *a, unsigned int b) {
+ TclBN_mp_set_u64(a, b);
+}
+
+mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
+{
+ if (maxlen < 0) {
+ return MP_VAL;
+ }
+ return TclBN_mp_to_radix(a, str, maxlen, NULL, radix);
+}
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -138,24 +416,36 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
+#undef TclWinGetPlatformId
+#undef TclWinResetInterfaces
+#undef TclWinSetInterfaces
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
-#define TclWinConvertError_ winConvertError
-static void
-TclWinConvertError_(unsigned errCode) {
- TclWinConvertError(errCode);
+#define TclWinGetPlatformId winGetPlatformId
+static int
+TclWinGetPlatformId(void)
+{
+ return 2; /* VER_PLATFORM_WIN32_NT */;
}
-
+#define TclWinResetInterfaces doNothing
+#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
+#endif /* TCL_NO_DEPRECATED */
#define TclpCreateTempFile_ TclpCreateTempFile
#define TclUnixWaitForFile_ TclUnixWaitForFile
-#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
+#ifdef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
+#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode
+#else
#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess
#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty
#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile
@@ -171,20 +461,17 @@ TclWinConvertError_(unsigned errCode) {
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty isatty
-# define TclWinSetInterfaces (void (*) (int))(void *)doNothing
-# define TclWinAddProcess (void (*) (void *, unsigned int))(void *)doNothing
-# define TclWinFlushDirtyChannels doNothing
-# define TclWinResetInterfaces doNothing
-
-#define TclWinGetPlatformId winGetPlatformId
-static int
-TclWinGetPlatformId()
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+static void
+doNothing(void)
{
- /* Don't bother to determine the real platform on cygwin,
- * because VER_PLATFORM_WIN32_NT is the only supported platform */
- return 2; /* VER_PLATFORM_WIN32_NT */;
+ /* dummy implementation, no need to do anything */
}
+#endif
+# define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing
+# define TclWinFlushDirtyChannels doNothing
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TclWinSetSockOpt winSetSockOpt
static int
TclWinSetSockOpt(SOCKET s, int level, int optname,
@@ -207,6 +494,7 @@ TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
+#endif /* TCL_NO_DEPRECATED */
#define TclWinNoBackslash winNoBackslash
static char *
@@ -226,144 +514,38 @@ void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- (const char *)&TclWinNoBackslash, &hInstance);
+ (const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
int
TclpGetPid(Tcl_Pid pid)
{
- return (int)(size_t)pid;
-}
-
-static void
-doNothing(void)
-{
- /* dummy implementation, no need to do anything */
+ return (TCL_HASH_TYPE)(size_t)pid;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef Tcl_WinUtfToTChar
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 4
- Tcl_UniChar ch = 0;
- wchar_t *w, *wString;
- const char *p, *end;
- int oldLength;
-#endif
-
Tcl_DStringInit(dsPtr);
- if (!string) {
- return NULL;
- }
-#if TCL_UTF_MAX > 4
-
- if (len < 0) {
- len = strlen(string);
- }
-
- /*
- * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
- * bytes.
- */
-
- oldLength = Tcl_DStringLength(dsPtr);
-
- Tcl_DStringSetLength(dsPtr,
- oldLength + (int) ((len + 1) * sizeof(wchar_t)));
- wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength);
-
- w = wString;
- p = string;
- end = string + len - 4;
- while (p < end) {
- p += TclUtfToUniChar(p, &ch);
- if (ch > 0xFFFF) {
- *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
- } else {
- *w++ = ch;
- }
- }
- end += 4;
- while (p < end) {
- if (Tcl_UtfCharComplete(p, end-p)) {
- p += TclUtfToUniChar(p, &ch);
- } else {
- ch = UCHAR(*p++);
- }
- if (ch > 0xFFFF) {
- *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10));
- *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF));
- } else {
- *w++ = ch;
- }
- }
- *w = '\0';
- Tcl_DStringSetLength(dsPtr,
- oldLength + ((char *) w - (char *) wString));
-
- return (char *)wString;
-#else
- return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr);
-#endif
+ return (char *)Tcl_UtfToChar16DString(string, len, dsPtr);
}
-
+#undef Tcl_WinTCharToUtf
char *
Tcl_WinTCharToUtf(
const char *string,
int len,
Tcl_DString *dsPtr)
{
-#if TCL_UTF_MAX > 4
- const wchar_t *w, *wEnd;
- char *p, *result;
- int oldLength, blen = 1;
-#endif
-
Tcl_DStringInit(dsPtr);
- if (!string) {
- return NULL;
- }
- if (len < 0) {
- len = wcslen((wchar_t *)string);
- } else {
- len /= 2;
- }
-#if TCL_UTF_MAX > 4
- oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4);
- result = Tcl_DStringValue(dsPtr) + oldLength;
-
- p = result;
- wEnd = (wchar_t *)string + len;
- for (w = (wchar_t *)string; w < wEnd; ) {
- if (!blen && ((*w & 0xFC00) != 0xDC00)) {
- /* Special case for handling high surrogates. */
- p += Tcl_UniCharToUtf(-1, p);
- }
- blen = Tcl_UniCharToUtf(*w, p);
- p += blen;
- if ((*w >= 0xD800) && (blen < 3)) {
- /* Indication that high surrogate is handled */
- blen = 0;
- }
- w++;
- }
- if (!blen) {
- /* Special case for handling high surrogates. */
- p += Tcl_UniCharToUtf(-1, p);
- }
- Tcl_DStringSetLength(dsPtr, oldLength + (p - result));
-
- return result;
-#else
- return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr);
-#endif
+ return Tcl_Char16ToUtfDString((const unsigned short *)string, len >> 1, dsPtr);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
@@ -371,33 +553,11 @@ Tcl_WinTCharToUtf(
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
-#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))(void *)dbNewLongObj)
-static Tcl_Obj *dbNewLongObj(
- int intValue,
- const char *file,
- int line
-) {
-#ifdef TCL_MEM_DEBUG
- Tcl_Obj *objPtr;
-
- TclDbNewObj(objPtr, file, line);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.longValue = (long) intValue;
- objPtr->typePtr = &tclIntType;
- return objPtr;
-#else
- return Tcl_NewIntObj(intValue);
-#endif
-}
-#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj
-#define Tcl_NewLongObj (Tcl_Obj*(*)(long))(void *)Tcl_NewIntObj
-#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))(void *)Tcl_SetIntObj
static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
- if ((longValue >= -(long)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -413,7 +573,7 @@ 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)(UINT_MAX))
+ if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
@@ -425,10 +585,6 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
-static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
- return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
-}
-#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
@@ -437,51 +593,169 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp
-static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
- return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
-}
-#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp
-static int formatInt(char *buffer, int n){
- return TclFormatInt(buffer, (long)n);
-}
-#define TclFormatInt (int(*)(char *, long))(void *)formatInt
-#endif
+#endif /* TCL_WIDE_INT_IS_LONG */
-#else /* UNIX and MAC */
+#endif /* __CYGWIN__ */
+
+#if defined(TCL_NO_DEPRECATED)
+# define Tcl_SeekOld 0
+# define Tcl_TellOld 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_PkgPresent
+# define Tcl_PkgPresent 0
+# undef Tcl_PkgProvide
+# define Tcl_PkgProvide 0
+# undef Tcl_PkgRequire
+# define Tcl_PkgRequire 0
+# undef Tcl_GetIndexFromObj
+# define Tcl_GetIndexFromObj 0
+# define Tcl_NewBooleanObj 0
+# undef Tcl_DbNewBooleanObj
+# define Tcl_DbNewBooleanObj 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_SetVar
+# define Tcl_SetVar 0
+# undef Tcl_UnsetVar
+# define Tcl_UnsetVar 0
+# undef Tcl_GetVar
+# define Tcl_GetVar 0
+# undef Tcl_TraceVar
+# define Tcl_TraceVar 0
+# undef Tcl_UntraceVar
+# define Tcl_UntraceVar 0
+# undef Tcl_VarTraceInfo
+# define Tcl_VarTraceInfo 0
+# undef Tcl_UpVar
+# define Tcl_UpVar 0
+# undef Tcl_AddErrorInfo
+# define Tcl_AddErrorInfo 0
+# undef Tcl_AddObjErrorInfo
+# define Tcl_AddObjErrorInfo 0
+# undef Tcl_Eval
+# define Tcl_Eval 0
+# undef Tcl_GlobalEval
+# define Tcl_GlobalEval 0
+# undef Tcl_SaveResult
+# define Tcl_SaveResult 0
+# undef Tcl_RestoreResult
+# define Tcl_RestoreResult 0
+# undef Tcl_DiscardResult
+# define Tcl_DiscardResult 0
+# undef Tcl_SetResult
+# define Tcl_SetResult 0
+# undef Tcl_EvalObj
+# define Tcl_EvalObj 0
+# undef Tcl_GlobalEvalObj
+# define Tcl_GlobalEvalObj 0
+# define TclBackgroundException 0
+# undef TclpReaddir
+# define TclpReaddir 0
+# define TclSetStartupScript 0
+# define TclGetStartupScript 0
+# define TclGetIntForIndex 0
+# define TclCreateNamespace 0
+# define TclDeleteNamespace 0
+# define TclAppendExportList 0
+# define TclExport 0
+# define TclImport 0
+# define TclForgetImport 0
+# define TclGetCurrentNamespace_ 0
+# define TclGetGlobalNamespace_ 0
+# define TclFindNamespace 0
+# define TclFindCommand 0
+# define TclGetCommandFromObj 0
+# define TclGetCommandFullName 0
+# define TclCopyChannelOld 0
+# define Tcl_AppendResultVA 0
+# define Tcl_AppendStringsToObjVA 0
+# define Tcl_SetErrorCodeVA 0
+# define Tcl_PanicVA 0
+# define Tcl_VarEvalVA 0
+# undef TclpGetDate
+# define TclpGetDate 0
+# undef TclpLocaltime
+# define TclpLocaltime 0
+# undef TclpGmtime
+# define TclpGmtime 0
+# define TclpLocaltime_unix 0
+# define TclpGmtime_unix 0
+# define Tcl_SetExitProc 0
+# define Tcl_SetPanicProc 0
+# define Tcl_FindExecutable 0
+# undef Tcl_StringMatch
+# define Tcl_StringMatch 0
+# define TclBN_reverse 0
+# undef TclBN_s_mp_mul_digs_fast
+# define TclBN_s_mp_mul_digs_fast 0
+# undef TclBN_s_mp_sqr_fast
+# define TclBN_s_mp_sqr_fast 0
+# undef TclBN_mp_karatsuba_mul
+# define TclBN_mp_karatsuba_mul 0
+# undef TclBN_mp_karatsuba_sqr
+# define TclBN_mp_karatsuba_sqr 0
+# undef TclBN_mp_toom_mul
+# define TclBN_mp_toom_mul 0
+# undef TclBN_mp_toom_sqr
+# define TclBN_mp_toom_sqr 0
+# undef TclBN_s_mp_add
+# define TclBN_s_mp_add 0
+# undef TclBN_s_mp_mul_digs
+# define TclBN_s_mp_mul_digs 0
+# undef TclBN_s_mp_sqr
+# define TclBN_s_mp_sqr 0
+# undef TclBN_s_mp_sub
+# define TclBN_s_mp_sub 0
+# define Tcl_MakeSafe 0
+# define TclpHasSockets 0
+#else /* TCL_NO_DEPRECATED */
+# define Tcl_SeekOld seekOld
+# define Tcl_TellOld tellOld
+# define TclBackgroundException Tcl_BackgroundException
+# define TclSetStartupScript Tcl_SetStartupScript
+# define TclGetStartupScript Tcl_GetStartupScript
+# define TclGetIntForIndex Tcl_GetIntForIndex
+# define TclCreateNamespace Tcl_CreateNamespace
+# define TclDeleteNamespace Tcl_DeleteNamespace
+# define TclAppendExportList Tcl_AppendExportList
+# define TclExport Tcl_Export
+# define TclImport Tcl_Import
+# define TclForgetImport Tcl_ForgetImport
+# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace
+# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace
+# define TclFindNamespace Tcl_FindNamespace
+# define TclFindCommand Tcl_FindCommand
+# define TclGetCommandFromObj Tcl_GetCommandFromObj
+# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
-#endif
+# define Tcl_MakeSafe TclMakeSafe
-mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
-{
- return mp_to_ubin(a, b, INT_MAX, NULL);
-}
+int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;}
-mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
+static int
+seekOld(
+ Tcl_Channel chan, /* The channel on which to seek. */
+ int offset, /* Offset to seek to. */
+ int mode) /* Relative to which location to seek? */
{
- size_t n = mp_ubin_size(a);
- if (*outlen < (unsigned long)n) {
- return MP_VAL;
- }
- *outlen = (unsigned long)n;
- return mp_to_ubin(a, b, n, NULL);
+ return Tcl_Seek(chan, offset, mode);
}
-mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
+static int
+tellOld(
+ Tcl_Channel chan) /* The channel to return pos for. */
{
- if (maxlen < 0) {
- return MP_VAL;
- }
- return mp_to_radix(a, str, maxlen, NULL, radix);
+ return Tcl_Tell(chan);
}
+#endif /* !TCL_NO_DEPRECATED */
-void bn_reverse(unsigned char *s, int len)
-{
- if (len > 0) {
- s_mp_reverse(s, (size_t)len);
- }
-}
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+#define Tcl_WinUtfToTChar 0
+#define Tcl_WinTCharToUtf 0
+#endif
/*
* WARNING: The contents of this file is automatically generated by the
@@ -492,6 +766,15 @@ void bn_reverse(unsigned char *s, int len)
MODULE_SCOPE const TclStubs tclStubs;
MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/* !BEGIN!: Do not edit below this line. */
static const TclIntStubs tclIntStubs = {
@@ -609,22 +892,22 @@ static const TclIntStubs tclIntStubs = {
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
- Tcl_AppendExportList, /* 112 */
- Tcl_CreateNamespace, /* 113 */
- Tcl_DeleteNamespace, /* 114 */
- Tcl_Export, /* 115 */
- Tcl_FindCommand, /* 116 */
- Tcl_FindNamespace, /* 117 */
+ TclAppendExportList, /* 112 */
+ TclCreateNamespace, /* 113 */
+ TclDeleteNamespace, /* 114 */
+ TclExport, /* 115 */
+ TclFindCommand, /* 116 */
+ TclFindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
- Tcl_ForgetImport, /* 121 */
- Tcl_GetCommandFromObj, /* 122 */
- Tcl_GetCommandFullName, /* 123 */
- Tcl_GetCurrentNamespace, /* 124 */
- Tcl_GetGlobalNamespace, /* 125 */
+ TclForgetImport, /* 121 */
+ TclGetCommandFromObj, /* 122 */
+ TclGetCommandFullName, /* 123 */
+ TclGetCurrentNamespace_, /* 124 */
+ TclGetGlobalNamespace_, /* 125 */
Tcl_GetVariableFullName, /* 126 */
- Tcl_Import, /* 127 */
+ TclImport, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
@@ -675,8 +958,8 @@ static const TclIntStubs tclIntStubs = {
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- Tcl_SetStartupScript, /* 178 */
- Tcl_GetStartupScript, /* 179 */
+ TclSetStartupScript, /* 178 */
+ TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
@@ -716,10 +999,10 @@ static const TclIntStubs tclIntStubs = {
TclStackFree, /* 216 */
TclPushStackFrame, /* 217 */
TclPopStackFrame, /* 218 */
- 0, /* 219 */
+ TclpCreateTemporaryDirectory, /* 219 */
0, /* 220 */
- 0, /* 221 */
- 0, /* 222 */
+ TclListTestObj, /* 221 */
+ TclListObjValidate, /* 222 */
TclGetCStackPtr, /* 223 */
TclGetPlatform, /* 224 */
TclTraceDictPath, /* 225 */
@@ -747,14 +1030,14 @@ static const TclIntStubs tclIntStubs = {
TclResetRewriteEnsemble, /* 247 */
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
- TclSetSlaveCancelFlags, /* 250 */
+ TclSetChildCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
- TclStaticPackage, /* 257 */
+ TclStaticLibrary, /* 257 */
0, /* 258 */
0, /* 259 */
0, /* 260 */
@@ -872,12 +1155,12 @@ static const TclPlatStubs tclPlatStubs = {
Tcl_WinUtfToTChar, /* 0 */
Tcl_WinTCharToUtf, /* 1 */
0, /* 2 */
- TclWinConvertError_, /* 3 */
+ Tcl_WinConvertError, /* 3 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
Tcl_MacOSXOpenBundleResources, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
- TclMacOSXNotifierAddRunLoopMode_, /* 2 */
+ Tcl_MacOSXNotifierAddRunLoopMode, /* 2 */
#endif /* MACOSX */
};
@@ -903,7 +1186,7 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_div_2d, /* 16 */
TclBN_mp_div_3, /* 17 */
TclBN_mp_exch, /* 18 */
- TclBN_mp_expt_d, /* 19 */
+ TclBN_mp_expt_u32, /* 19 */
TclBN_mp_grow, /* 20 */
TclBN_mp_init, /* 21 */
TclBN_mp_init_copy, /* 22 */
@@ -931,12 +1214,12 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
- TclBN_mp_unsigned_bin_size, /* 47 */
+ TclBN_mp_ubin_size, /* 47 */
TclBN_mp_xor, /* 48 */
TclBN_mp_zero, /* 49 */
TclBN_reverse, /* 50 */
- TclBN_fast_s_mp_mul_digs, /* 51 */
- TclBN_fast_s_mp_sqr, /* 52 */
+ TclBN_s_mp_mul_digs_fast, /* 51 */
+ TclBN_s_mp_sqr_fast, /* 52 */
TclBN_mp_karatsuba_mul, /* 53 */
TclBN_mp_karatsuba_sqr, /* 54 */
TclBN_mp_toom_mul, /* 55 */
@@ -945,16 +1228,16 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_s_mp_mul_digs, /* 58 */
TclBN_s_mp_sqr, /* 59 */
TclBN_s_mp_sub, /* 60 */
- TclBN_mp_init_set_int, /* 61 */
- TclBN_mp_set_int, /* 62 */
+ TclBN_mp_init_ul, /* 61 */
+ TclBN_mp_set_ul, /* 62 */
TclBN_mp_cnt_lsb, /* 63 */
- TclBNInitBignumFromLong, /* 64 */
- TclBNInitBignumFromWideInt, /* 65 */
- TclBNInitBignumFromWideUInt, /* 66 */
+ TclBN_mp_init_l, /* 64 */
+ TclBN_mp_init_i64, /* 65 */
+ TclBN_mp_init_u64, /* 66 */
TclBN_mp_expt_d_ex, /* 67 */
- TclBN_mp_set_ull, /* 68 */
- TclBN_mp_get_mag_ull, /* 69 */
- TclBN_mp_set_ll, /* 70 */
+ TclBN_mp_set_u64, /* 68 */
+ TclBN_mp_get_mag_u64, /* 69 */
+ TclBN_mp_set_i64, /* 70 */
TclBN_mp_unpack, /* 71 */
TclBN_mp_pack, /* 72 */
TclBN_mp_tc_and, /* 73 */
@@ -1089,7 +1372,7 @@ const TclStubs tclStubs = {
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
- Tcl_CreateSlave, /* 97 */
+ Tcl_CreateChild, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
@@ -1156,7 +1439,7 @@ const TclStubs tclStubs = {
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
- Tcl_GetMaster, /* 164 */
+ Tcl_GetParent, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
@@ -1172,7 +1455,7 @@ const TclStubs tclStubs = {
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
- Tcl_GetSlave, /* 172 */
+ Tcl_GetChild, /* 172 */
Tcl_GetStdChannel, /* 173 */
Tcl_GetStringResult, /* 174 */
Tcl_GetVar, /* 175 */
@@ -1244,7 +1527,7 @@ const TclStubs tclStubs = {
Tcl_SourceRCFile, /* 241 */
Tcl_SplitList, /* 242 */
Tcl_SplitPath, /* 243 */
- Tcl_StaticPackage, /* 244 */
+ Tcl_StaticLibrary, /* 244 */
Tcl_StringMatch, /* 245 */
Tcl_TellOld, /* 246 */
Tcl_TraceVar, /* 247 */
@@ -1326,17 +1609,17 @@ const TclStubs tclStubs = {
Tcl_UniCharToUpper, /* 323 */
Tcl_UniCharToUtf, /* 324 */
Tcl_UtfAtIndex, /* 325 */
- Tcl_UtfCharComplete, /* 326 */
+ TclUtfCharComplete, /* 326 */
Tcl_UtfBackslash, /* 327 */
Tcl_UtfFindFirst, /* 328 */
Tcl_UtfFindLast, /* 329 */
- Tcl_UtfNext, /* 330 */
- Tcl_UtfPrev, /* 331 */
+ TclUtfNext, /* 330 */
+ TclUtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
- Tcl_UtfToUniChar, /* 336 */
+ Tcl_UtfToChar16, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
@@ -1352,10 +1635,10 @@ const TclStubs tclStubs = {
Tcl_UniCharIsSpace, /* 349 */
Tcl_UniCharIsUpper, /* 350 */
Tcl_UniCharIsWordChar, /* 351 */
- Tcl_UniCharLen, /* 352 */
+ Tcl_Char16Len, /* 352 */
Tcl_UniCharNcmp, /* 353 */
- Tcl_UniCharToUtfDString, /* 354 */
- Tcl_UtfToUniCharDString, /* 355 */
+ Tcl_Char16ToUtfDString, /* 354 */
+ Tcl_UtfToChar16DString, /* 355 */
Tcl_GetRegExpFromObj, /* 356 */
Tcl_EvalTokens, /* 357 */
Tcl_FreeParse, /* 358 */
@@ -1631,36 +1914,36 @@ const TclStubs tclStubs = {
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
- 0, /* 631 */
- 0, /* 632 */
- 0, /* 633 */
- 0, /* 634 */
- 0, /* 635 */
- 0, /* 636 */
- 0, /* 637 */
- 0, /* 638 */
- 0, /* 639 */
- 0, /* 640 */
- 0, /* 641 */
- 0, /* 642 */
- 0, /* 643 */
- 0, /* 644 */
- 0, /* 645 */
- 0, /* 646 */
- 0, /* 647 */
- 0, /* 648 */
- 0, /* 649 */
+ Tcl_OpenTcpServerEx, /* 631 */
+ TclZipfs_Mount, /* 632 */
+ TclZipfs_Unmount, /* 633 */
+ TclZipfs_TclLibrary, /* 634 */
+ TclZipfs_MountBuffer, /* 635 */
+ Tcl_FreeInternalRep, /* 636 */
+ Tcl_InitStringRep, /* 637 */
+ Tcl_FetchInternalRep, /* 638 */
+ Tcl_StoreInternalRep, /* 639 */
+ Tcl_HasStringRep, /* 640 */
+ Tcl_IncrRefCount, /* 641 */
+ Tcl_DecrRefCount, /* 642 */
+ Tcl_IsShared, /* 643 */
+ Tcl_LinkArray, /* 644 */
+ Tcl_GetIntForIndex, /* 645 */
+ Tcl_UtfToUniChar, /* 646 */
+ Tcl_UniCharToUtfDString, /* 647 */
+ Tcl_UtfToUniCharDString, /* 648 */
+ Tcl_GetBytesFromObj, /* 649 */
0, /* 650 */
0, /* 651 */
0, /* 652 */
0, /* 653 */
- 0, /* 654 */
- 0, /* 655 */
- 0, /* 656 */
- 0, /* 657 */
- 0, /* 658 */
- 0, /* 659 */
- 0, /* 660 */
+ Tcl_UtfCharComplete, /* 654 */
+ Tcl_UtfNext, /* 655 */
+ Tcl_UtfPrev, /* 656 */
+ Tcl_UniCharIsUnicode, /* 657 */
+ Tcl_ExternalToUtfDStringEx, /* 658 */
+ Tcl_UtfToExternalDStringEx, /* 659 */
+ Tcl_AsyncMarkFromSignal, /* 660 */
0, /* 661 */
0, /* 662 */
0, /* 663 */
@@ -1668,24 +1951,24 @@ const TclStubs tclStubs = {
0, /* 665 */
0, /* 666 */
0, /* 667 */
- 0, /* 668 */
- 0, /* 669 */
- 0, /* 670 */
- 0, /* 671 */
- 0, /* 672 */
- 0, /* 673 */
- 0, /* 674 */
- 0, /* 675 */
+ Tcl_UniCharLen, /* 668 */
+ TclNumUtfChars, /* 669 */
+ TclGetCharLength, /* 670 */
+ TclUtfAtIndex, /* 671 */
+ TclGetRange, /* 672 */
+ TclGetUniChar, /* 673 */
+ Tcl_GetBool, /* 674 */
+ Tcl_GetBoolFromObj, /* 675 */
0, /* 676 */
0, /* 677 */
0, /* 678 */
0, /* 679 */
- 0, /* 680 */
- 0, /* 681 */
- 0, /* 682 */
- 0, /* 683 */
- 0, /* 684 */
- 0, /* 685 */
+ Tcl_GetNumberFromObj, /* 680 */
+ Tcl_GetNumber, /* 681 */
+ Tcl_RemoveChannelMode, /* 682 */
+ Tcl_GetEncodingNulLength, /* 683 */
+ Tcl_GetWideUIntFromObj, /* 684 */
+ Tcl_DStringToObj, /* 685 */
0, /* 686 */
0, /* 687 */
TclUnusedStubEntry, /* 688 */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index bebea81..f06b2d1 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -4,8 +4,8 @@
* Stub object that will be statically linked into extensions that want
* to access Tcl.
*
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 1998 Paul Duffin.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 1998 Paul Duffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,20 +17,19 @@ MODULE_SCOPE const TclStubs *tclStubsPtr;
MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr;
MODULE_SCOPE const TclIntStubs *tclIntStubsPtr;
MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr;
+MODULE_SCOPE void *tclStubsHandle;
const TclStubs *tclStubsPtr = NULL;
const TclPlatStubs *tclPlatStubsPtr = NULL;
const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
+void *tclStubsHandle = NULL;
/*
- * Use our own isDigit to avoid linking to libc on windows
+ * Use our own ISDIGIT to avoid linking to libc on windows
*/
-static int isDigit(const int c)
-{
- return (c >= '0' && c <= '9');
-}
+#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9)
/*
*----------------------------------------------------------------------
@@ -54,35 +53,39 @@ MODULE_SCOPE const char *
Tcl_InitStubs(
Tcl_Interp *interp,
const char *version,
- int exact)
+ int exact,
+ int magic)
{
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
const char *actualVersion = NULL;
- ClientData pkgData = 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 != TCL_STUB_MAGIC)) {
+ if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
- iPtr->freeProc = TCL_STATIC;
+ iPtr->freeProc = 0; /* TCL_STATIC */
return NULL;
}
- actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
+ actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
- if (exact) {
+ if (exact&1) {
const char *p = version;
int count = 0;
while (*p) {
- count += !isDigit(*p++);
+ count += !ISDIGIT(*p++);
}
if (count == 1) {
const char *q = actualVersion;
@@ -91,24 +94,31 @@ Tcl_InitStubs(
while (*p && (*p == *q)) {
p++; q++;
}
- if (*p || isDigit(*q)) {
+ if (*p || ISDIGIT(*q)) {
/* Construct error message */
- stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+ stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
return NULL;
}
} else {
- actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+ actualVersion = stubsPtr->tcl_PkgRequireEx(interp, tclName, version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
- tclStubsPtr = (TclStubs *)pkgData;
+ if (((exact&0xFF00) < 0x900)) {
+ /* We are running Tcl 8.x */
+ stubsPtr = (TclStubs *)pkgData;
+ }
+ if (tclStubsHandle == NULL) {
+ tclStubsHandle = INT2PTR(-1);
+ }
+ tclStubsPtr = stubsPtr;
- if (tclStubsPtr->hooks) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
+ if (stubsPtr->hooks) {
+ tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
+ tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
+ tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ea23d40..a07d449 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6,20 +6,33 @@
* commands are not normally included in Tcl applications; they're only
* used for testing.
*
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Ajuba Solutions.
- * Copyright (c) 2003 Kevin B. Kenny. All rights reserved.
+ * Copyright © 1993-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Ajuba Solutions.
+ * Copyright © 2003 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#undef STATIC_BUILD
+#undef BUILD_tcl
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
+#undef TCL_UTF_MAX
+#ifdef TCL_NO_DEPRECATED
+# define TCL_UTF_MAX 4
+#else
+# define TCL_NO_DEPRECATED
+# define TCL_UTF_MAX 3
+#endif
#include "tclInt.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
#include "tclOO.h"
#include <math.h>
@@ -29,29 +42,17 @@
#include "tclRegexp.h"
/*
- * Required for TestlocaleCmd
- */
-#include <locale.h>
-
-/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
-/*
- * Declare external functions used in Windows tests.
- */
+#include "tclUuid.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Tcltest_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
+ * Declare external functions used in Windows tests.
*/
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-EXTERN int Tcltest_Init(Tcl_Interp *interp);
-EXTERN int Tcltest_SafeInit(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
+DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
@@ -62,6 +63,22 @@ 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. */
+ const char *value;
+ 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".
*/
@@ -75,6 +92,17 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
+/*
+ * 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;
@@ -120,7 +148,9 @@ typedef struct {
* was called for a result.
*/
+#ifndef TCL_NO_DEPRECATED
static int freeCount;
+#endif /* TCL_NO_DEPRECATED */
/*
* Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands.
@@ -151,68 +181,74 @@ typedef struct TestChannel {
static TestChannel *firstDetached;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/*
* Forward declarations for procedures defined later in this file:
*/
-static int AsyncHandlerProc(ClientData clientData,
+static int AsyncHandlerProc(void *clientData,
Tcl_Interp *interp, int code);
-#ifdef TCL_THREADS
-static Tcl_ThreadCreateType AsyncThreadProc(ClientData);
-#endif
+static Tcl_ThreadCreateType AsyncThreadProc(void *);
static void CleanupTestSetassocdataTests(
- ClientData clientData, Tcl_Interp *interp);
-static void CmdDelProc1(ClientData clientData);
-static void CmdDelProc2(ClientData clientData);
+ void *clientData, Tcl_Interp *interp);
+static void CmdDelProc1(void *clientData);
+static void CmdDelProc2(void *clientData);
static Tcl_CmdProc CmdProc1;
static Tcl_CmdProc CmdProc2;
static void CmdTraceDeleteProc(
- ClientData clientData, Tcl_Interp *interp,
+ void *clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
- ClientData cmdClientData, int argc,
+ void *cmdClientData, int argc,
const char *argv[]);
-static void CmdTraceProc(ClientData clientData,
+static void CmdTraceProc(void *clientData,
Tcl_Interp *interp, int level, char *command,
- Tcl_CmdProc *cmdProc, ClientData cmdClientData,
+ Tcl_CmdProc *cmdProc, void *cmdClientData,
int argc, const char *argv[]);
static Tcl_CmdProc CreatedCommandProc;
static Tcl_CmdProc CreatedCommandProc2;
-static void DelCallbackProc(ClientData clientData,
+static void DelCallbackProc(void *clientData,
Tcl_Interp *interp);
static Tcl_CmdProc DelCmdProc;
-static void DelDeleteProc(ClientData clientData);
-static void EncodingFreeProc(ClientData clientData);
-static int EncodingToUtfProc(ClientData clientData,
+static void DelDeleteProc(void *clientData);
+static void EncodingFreeProc(void *clientData);
+static int EncodingToUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static int EncodingFromUtfProc(ClientData clientData,
+static int EncodingFromUtfProc(void *clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr);
-static void ExitProcEven(ClientData clientData);
-static void ExitProcOdd(ClientData clientData);
+static void ExitProcEven(void *clientData);
+static void ExitProcOdd(void *clientData);
static Tcl_ObjCmdProc GetTimesObjCmd;
+static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver;
static void MainLoop(void);
static Tcl_CmdProc NoopCmd;
static Tcl_ObjCmdProc NoopObjCmd;
-static int ObjTraceProc(ClientData clientData,
- Tcl_Interp *interp, int level, const char *command,
- Tcl_Command commandToken, int objc,
- Tcl_Obj *const objv[]);
-static void ObjTraceDeleteProc(ClientData clientData);
+static Tcl_CmdObjTraceProc2 ObjTraceProc;
+static void ObjTraceDeleteProc(void *clientData);
static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
static Tcl_FreeProc SpecialFree;
static int StaticInitProc(Tcl_Interp *interp);
static Tcl_CmdProc TestasyncCmd;
static Tcl_ObjCmdProc TestbumpinterpepochObjCmd;
+static Tcl_ObjCmdProc TestbytestringObjCmd;
static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd;
static Tcl_ObjCmdProc TestpurebytesobjObjCmd;
-static Tcl_ObjCmdProc TestbytestringObjCmd;
static Tcl_ObjCmdProc TeststringbytesObjCmd;
-static Tcl_CmdProc TestcmdinfoCmd;
+static Tcl_ObjCmdProc Testutf16stringObjCmd;
+static Tcl_ObjCmdProc TestcmdinfoObjCmd;
static Tcl_CmdProc TestcmdtokenCmd;
static Tcl_CmdProc TestcmdtraceCmd;
static Tcl_CmdProc TestconcatobjCmd;
@@ -228,7 +264,7 @@ static Tcl_ObjCmdProc TestevalobjvObjCmd;
static Tcl_ObjCmdProc TesteventObjCmd;
static int TesteventProc(Tcl_Event *event, int flags);
static int TesteventDeleteProc(Tcl_Event *event,
- ClientData clientData);
+ void *clientData);
static Tcl_CmdProc TestexithandlerCmd;
static Tcl_CmdProc TestexprlongCmd;
static Tcl_ObjCmdProc TestexprlongobjCmd;
@@ -241,17 +277,14 @@ static Tcl_ObjCmdProc TestfilelinkCmd;
static Tcl_CmdProc TestfeventCmd;
static Tcl_CmdProc TestgetassocdataCmd;
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 int TestMathFunc(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-static int TestMathFunc2(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
static Tcl_CmdProc TestmainthreadCmd;
static Tcl_CmdProc TestsetmainloopCmd;
static Tcl_CmdProc TestexitmainloopCmd;
@@ -260,29 +293,36 @@ static Tcl_ObjCmdProc TestparseargsCmd;
static Tcl_ObjCmdProc TestparserObjCmd;
static Tcl_ObjCmdProc TestparsevarObjCmd;
static Tcl_ObjCmdProc TestparsevarnameObjCmd;
+static Tcl_ObjCmdProc TestpreferstableObjCmd;
+static Tcl_ObjCmdProc TestprintObjCmd;
static Tcl_ObjCmdProc TestregexpObjCmd;
static Tcl_ObjCmdProc TestreturnObjCmd;
static void TestregexpXflags(const char *string,
- int length, int *cflagsPtr, int *eflagsPtr);
+ size_t length, int *cflagsPtr, int *eflagsPtr);
+#ifndef TCL_NO_DEPRECATED
static Tcl_ObjCmdProc TestsaveresultCmd;
static Tcl_FreeProc TestsaveresultFree;
+#endif /* TCL_NO_DEPRECATED */
static Tcl_CmdProc TestsetassocdataCmd;
static Tcl_CmdProc TestsetCmd;
static Tcl_CmdProc Testset2Cmd;
static Tcl_CmdProc TestseterrorcodeCmd;
static Tcl_ObjCmdProc TestsetobjerrorcodeCmd;
static Tcl_CmdProc TestsetplatformCmd;
-static Tcl_CmdProc TeststaticpkgCmd;
+static Tcl_CmdProc TeststaticlibraryCmd;
static Tcl_CmdProc TesttranslatefilenameCmd;
static Tcl_CmdProc TestupvarCmd;
-static Tcl_ObjCmdProc TestWrongNumArgsObjCmd;
+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,
Tcl_Obj *arg2);
+static Tcl_ObjCmdProc TestgetencpathObjCmd;
+static Tcl_ObjCmdProc TestsetencpathObjCmd;
static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr);
static Tcl_FSStatProc TestReportStat;
static Tcl_FSAccessProc TestReportAccess;
@@ -322,6 +362,7 @@ static Tcl_ObjCmdProc TestGetUniCharCmd;
static Tcl_ObjCmdProc TestFindFirstCmd;
static Tcl_ObjCmdProc TestFindLastCmd;
static Tcl_ObjCmdProc TestHashSystemHashCmd;
+static Tcl_ObjCmdProc TestGetIntForIndexCmd;
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
@@ -433,14 +474,84 @@ static const Tcl_Filesystem simpleFilesystem = {
*----------------------------------------------------------------------
*/
+#ifndef STRINGIFY
+# define STRINGIFY(x) STRINGIFY1(x)
+# define STRINGIFY1(x) #x
+#endif
+
+static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID)
+#if defined(__clang__) && defined(__clang_major__)
+ ".clang-" STRINGIFY(__clang_major__)
+#if __clang_minor__ < 10
+ "0"
+#endif
+ STRINGIFY(__clang_minor__)
+#endif
+#ifdef TCL_COMPILE_DEBUG
+ ".compiledebug"
+#endif
+#ifdef TCL_COMPILE_STATS
+ ".compilestats"
+#endif
+#if defined(__cplusplus) && !defined(__OBJC__)
+ ".cplusplus"
+#endif
+#ifndef NDEBUG
+ ".debug"
+#endif
+#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
+ ".gcc-" STRINGIFY(__GNUC__)
+#if __GNUC_MINOR__ < 10
+ "0"
+#endif
+ STRINGIFY(__GNUC_MINOR__)
+#endif
+#ifdef __INTEL_COMPILER
+ ".icc-" STRINGIFY(__INTEL_COMPILER)
+#endif
+#if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL)
+ ".ilp32"
+#endif
+#ifdef TCL_MEM_DEBUG
+ ".memdebug"
+#endif
+#if defined(_MSC_VER)
+ ".msvc-" STRINGIFY(_MSC_VER)
+#endif
+#ifdef USE_NMAKE
+ ".nmake"
+#endif
+#if !TCL_THREADS
+ ".no-thread"
+#endif
+#ifndef TCL_CFG_OPTIMIZED
+ ".no-optimize"
+#endif
+#ifdef __OBJC__
+ ".objective-c"
+#if defined(__cplusplus)
+ "plusplus"
+#endif
+#endif
+#ifdef TCL_CFG_PROFILED
+ ".profile"
+#endif
+#ifdef PURIFY
+ ".purify"
+#endif
+#ifdef STATIC_BUILD
+ ".static"
+#endif
+;
+
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
- Tcl_ValueType t3ArgTypes[2];
-
+ Tcl_CmdInfo info;
Tcl_Obj **objv, *objPtr;
- int objc, index;
+ Tcl_Size objc;
+ int index;
static const char *const specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
@@ -449,15 +560,26 @@ Tcltest_Init(
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
- if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
+#ifndef TCL_WITH_EXTERNAL_TOMMATH
+ if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
+#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
- /* TIP #268: Full patchlevel instead of just major.minor */
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == 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;
}
@@ -472,7 +594,8 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
- Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
+ Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
@@ -489,7 +612,7 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
- Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
+ Tcl_CreateObjCommand(interp, "testcmdinfo", TestcmdinfoObjCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
NULL, NULL);
@@ -540,6 +663,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
@@ -547,6 +672,8 @@ Tcltest_Init(
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);
@@ -557,12 +684,18 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
+ NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
+#endif
Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
@@ -589,15 +722,17 @@ Tcltest_Init(
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testgetintforindex",
+ TestGetIntForIndexCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
- Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
+ Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
+ NULL, NULL);
+ Tcl_CreateCommand(interp, "teststaticlibrary", TeststaticlibraryCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
- Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
- Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -608,17 +743,16 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
NULL, NULL);
#endif
- t3ArgTypes[0] = TCL_EITHER;
- t3ArgTypes[1] = TCL_EITHER;
- Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- NULL);
-
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
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);
@@ -628,7 +762,7 @@ Tcltest_Init(
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
-#ifdef TCL_THREADS
+#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
@@ -658,7 +792,7 @@ Tcltest_Init(
return TCL_ERROR;
}
case 3:
- if (objc-1) {
+ if (objc > 1) {
Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1],
TCL_GLOBAL_ONLY);
}
@@ -697,9 +831,24 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
+ Tcl_CmdInfo info;
+
if (Tcl_InitStubs(interp, "8.5-", 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);
}
@@ -722,7 +871,7 @@ Tcltest_SafeInit(
static int
TestasyncCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -730,11 +879,10 @@ TestasyncCmd(
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- (void)dummy;
if (argc < 2) {
wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args", NULL);
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
@@ -752,7 +900,7 @@ TestasyncCmd(
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
@@ -808,7 +956,6 @@ TestasyncCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
-#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -824,7 +971,7 @@ TestasyncCmd(
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
- Tcl_AppendResult(interp, "can't create thread", NULL);
+ Tcl_AppendResult(interp, "can't create thread", (void *)NULL);
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
@@ -834,21 +981,15 @@ TestasyncCmd(
Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, int, mark, or marklater", NULL);
- return TCL_ERROR;
-#else /* !TCL_THREADS */
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, int, or mark", NULL);
+ "\": must be create, delete, int, mark, or marklater", (void *)NULL);
return TCL_ERROR;
-#endif
}
return TCL_OK;
}
static int
AsyncHandlerProc(
- ClientData clientData, /* If of TestAsyncHandler structure.
+ void *clientData, /* If of TestAsyncHandler structure.
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
@@ -856,7 +997,8 @@ AsyncHandlerProc(
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
- const char *listArgv[4], *cmd;
+ const char *listArgv[4];
+ char *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
@@ -875,12 +1017,12 @@ AsyncHandlerProc(
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
- listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
+ listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
- code = Tcl_EvalEx(interp, cmd, -1, 0);
+ code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
@@ -907,10 +1049,9 @@ AsyncHandlerProc(
*----------------------------------------------------------------------
*/
-#ifdef TCL_THREADS
static Tcl_ThreadCreateType
AsyncThreadProc(
- ClientData clientData) /* Parameter is the id of a
+ void *clientData) /* Parameter is the id of a
* TestAsyncHandler, defined above. */
{
TestAsyncHandler *asyncPtr;
@@ -929,11 +1070,10 @@ AsyncThreadProc(
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
-#endif
static int
TestbumpinterpepochObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -951,7 +1091,7 @@ TestbumpinterpepochObjCmd(
/*
*----------------------------------------------------------------------
*
- * TestcmdinfoCmd --
+ * TestcmdinfoObjCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
* test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and
@@ -967,101 +1107,154 @@ TestbumpinterpepochObjCmd(
*/
static int
-TestcmdinfoCmd(
- ClientData dummy, /* Not used. */
+TestcmdinfoObjCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
+ static const char *const subcmds[] = {
+ "create", "delete", "get", "modify", NULL
+ };
+ enum options {
+ CMDINFO_CREATE, CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY
+ } idx;
Tcl_CmdInfo info;
- (void)dummy;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option cmdName\"", NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command arg");
return TCL_ERROR;
}
- if (strcmp(argv[1], "create") == 0) {
- Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
- CmdDelProc1);
- } else if (strcmp(argv[1], "delete") == 0) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case CMDINFO_CREATE:
+ Tcl_CreateCommand(interp, Tcl_GetString(objv[2]), CmdProc1,
+ (void *)"original", CmdDelProc1);
+ break;
+ case CMDINFO_DELETE:
Tcl_DStringInit(&delString);
- Tcl_DeleteCommand(interp, argv[2]);
+ Tcl_DeleteCommand(interp, Tcl_GetString(objv[2]));
Tcl_DStringResult(interp, &delString);
- } else if (strcmp(argv[1], "get") == 0) {
- if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
- Tcl_AppendResult(interp, "??", NULL);
+ break;
+ case CMDINFO_GET:
+ if (Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &info) ==0) {
+ Tcl_AppendResult(interp, "??", (void *)NULL);
return TCL_OK;
}
if (info.proc == CmdProc1) {
Tcl_AppendResult(interp, "CmdProc1", " ",
- (char *) info.clientData, NULL);
+ (char *) info.clientData, (void *)NULL);
} else if (info.proc == CmdProc2) {
Tcl_AppendResult(interp, "CmdProc2", " ",
- (char *) info.clientData, NULL);
+ (char *) info.clientData, (void *)NULL);
} else {
- Tcl_AppendResult(interp, "unknown", NULL);
+ Tcl_AppendResult(interp, "unknown", (void *)NULL);
}
if (info.deleteProc == CmdDelProc1) {
Tcl_AppendResult(interp, " CmdDelProc1", " ",
- (char *) info.deleteData, NULL);
+ (char *) info.deleteData, (void *)NULL);
} else if (info.deleteProc == CmdDelProc2) {
Tcl_AppendResult(interp, " CmdDelProc2", " ",
- (char *) info.deleteData, NULL);
+ (char *) info.deleteData, (void *)NULL);
} else {
- Tcl_AppendResult(interp, " unknown", NULL);
- }
- Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, NULL);
- if (info.isNativeObjectProc) {
- Tcl_AppendResult(interp, " nativeObjectProc", NULL);
+ Tcl_AppendResult(interp, " unknown", (void *)NULL);
+ }
+ Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, (void *)NULL);
+ if (info.isNativeObjectProc == 0) {
+ Tcl_AppendResult(interp, " stringProc", (void *)NULL);
+ } else if (info.isNativeObjectProc == 1) {
+ Tcl_AppendResult(interp, " nativeObjectProc", (void *)NULL);
+ } else if (info.isNativeObjectProc == 2) {
+ Tcl_AppendResult(interp, " nativeObjectProc2", (void *)NULL);
} else {
- Tcl_AppendResult(interp, " stringProc", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid isNativeObjectProc value %d",
+ info.isNativeObjectProc));
+ return TCL_ERROR;
}
- } else if (strcmp(argv[1], "modify") == 0) {
+ break;
+ case CMDINFO_MODIFY:
info.proc = CmdProc2;
- info.clientData = (ClientData) "new_command_data";
+ info.clientData = (void *) "new_command_data";
info.objProc = NULL;
info.objClientData = NULL;
info.deleteProc = CmdDelProc2;
- info.deleteData = (ClientData) "new_delete_data";
- if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+ info.deleteData = (void *) "new_delete_data";
+ info.namespacePtr = NULL;
+ info.objProc2 = NULL;
+ info.objClientData2 = NULL;
+ if (Tcl_SetCommandInfo(interp, Tcl_GetString(objv[2]), &info) == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1));
}
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, get, or modify", NULL);
- return TCL_ERROR;
+ break;
}
+
+ return TCL_OK;
+}
+
+static int
+CmdProc0(
+ void *clientData, /* String to return. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
+{
+ TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData;
+ Tcl_AppendResult(interp, "CmdProc1 ", refPtr->value, (void *)NULL);
return TCL_OK;
}
static int
CmdProc1(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL);
+ Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, (void *)NULL);
return TCL_OK;
}
static int
CmdProc2(
- ClientData clientData, /* String to return. */
+ void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
- Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL);
+ Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, (void *)NULL);
return TCL_OK;
}
static void
+CmdDelProc0(
+ void *clientData) /* String to save. */
+{
+ TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL;
+ TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData;
+ int id = refPtr->id;
+ for (thisRefPtr = firstCommandTokenRef; refPtr != NULL;
+ thisRefPtr = thisRefPtr->nextPtr) {
+ if (thisRefPtr->id == id) {
+ if (prevRefPtr != NULL) {
+ prevRefPtr->nextPtr = thisRefPtr->nextPtr;
+ } else {
+ firstCommandTokenRef = thisRefPtr->nextPtr;
+ }
+ break;
+ }
+ prevRefPtr = thisRefPtr;
+ }
+ ckfree(refPtr);
+}
+
+static void
CmdDelProc1(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
@@ -1070,7 +1263,7 @@ CmdDelProc1(
static void
CmdDelProc2(
- ClientData clientData) /* String to save. */
+ void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
@@ -1096,46 +1289,68 @@ CmdDelProc2(
static int
TestcmdtokenCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- Tcl_Command token;
- int *l;
+ TestCommandTokenRef *refPtr;
+ int id;
char buf[30];
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option arg\"", NULL);
+ " option arg\"", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
- (ClientData) "original", NULL);
- snprintf(buf, sizeof(buf), "%p", (void *)token);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- } else if (strcmp(argv[1], "name") == 0) {
- Tcl_Obj *objPtr;
-
- if (sscanf(argv[2], "%p", &l) != 1) {
+ refPtr = (TestCommandTokenRef *)ckalloc(sizeof(TestCommandTokenRef));
+ refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc0,
+ refPtr, CmdDelProc0);
+ refPtr->id = nextCommandTokenRefId;
+ refPtr->value = "original";
+ nextCommandTokenRefId++;
+ refPtr->nextPtr = firstCommandTokenRef;
+ firstCommandTokenRef = refPtr;
+ snprintf(buf, sizeof(buf), "%d", refPtr->id);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
+ } else {
+ if (sscanf(argv[2], "%d", &id) != 1) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
- "\"", NULL);
+ "\"", (void *)NULL);
return TCL_ERROR;
}
- objPtr = Tcl_NewObj();
- Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
+ for (refPtr = firstCommandTokenRef; refPtr != NULL;
+ refPtr = refPtr->nextPtr) {
+ if (refPtr->id == id) {
+ break;
+ }
+ }
- Tcl_AppendElement(interp,
- Tcl_GetCommandName(interp, (Tcl_Command) l));
- 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;
+ if (refPtr == NULL) {
+ Tcl_AppendResult(interp, "bad command token \"", argv[2],
+ "\"", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[1], "name") == 0) {
+ Tcl_Obj *objPtr;
+
+ 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, name, or free", (void *)NULL);
+ return TCL_ERROR;
+ }
}
+
return TCL_OK;
}
@@ -1159,7 +1374,7 @@ TestcmdtokenCmd(
static int
TestcmdtraceCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1169,17 +1384,17 @@ TestcmdtraceCmd(
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option script\"", NULL);
+ " option script\"", (void *)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], -1, 0);
+ 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_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
@@ -1192,16 +1407,16 @@ TestcmdtraceCmd(
*/
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
- Tcl_EvalEx(interp, argv[2], -1, 0);
+ 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], -1, 0);
+ 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_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
@@ -1213,13 +1428,13 @@ TestcmdtraceCmd(
static int deleteCalled;
deleteCalled = 0;
- cmdTrace = Tcl_CreateObjTrace(interp, 50000,
+ cmdTrace = Tcl_CreateObjTrace2(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
&deleteCalled, ObjTraceDeleteProc);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
- Tcl_AppendResult(interp, "Delete wasn't called", NULL);
+ Tcl_AppendResult(interp, "Delete wasn't called", (void *)NULL);
return TCL_ERROR;
} else {
return result;
@@ -1230,17 +1445,17 @@ TestcmdtraceCmd(
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_Eval(interp, argv[2]);
+ 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_AppendResult(interp, Tcl_DStringValue(&buffer), (void *)NULL);
}
Tcl_DeleteTrace(interp, t2);
Tcl_DeleteTrace(interp, t1);
Tcl_DStringFree(&buffer);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be tracetest, deletetest, doubletest or resulttest", NULL);
+ "\": must be tracetest, deletetest, doubletest or resulttest", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1248,16 +1463,15 @@ TestcmdtraceCmd(
static void
CmdTraceProc(
- ClientData clientData, /* Pointer to buffer in which the
+ void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
- Tcl_Interp *interp, /* Current interpreter. */
- int level, /* Current trace level. */
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*level*/,
char *command, /* The command being traced (after
* substitutions). */
- Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
- * procedure. */
+ TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
+ TCL_UNUSED(void *),
int argc, /* Number of arguments. */
const char *argv[]) /* Argument strings. */
{
@@ -1275,16 +1489,14 @@ CmdTraceProc(
static void
CmdTraceDeleteProc(
- ClientData clientData, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int level, /* Current trace level. */
- char *command, /* The command being traced (after
- * substitutions). */
- Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */
- ClientData cmdClientData, /* Client data associated with command
- * procedure. */
- int argc, /* Number of arguments. */
- const char *argv[]) /* Argument strings. */
+ TCL_UNUSED(int) /*level*/,
+ TCL_UNUSED(char *) /*command*/,
+ TCL_UNUSED(Tcl_CmdProc *),
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
/*
* Remove ourselves to test whether calling Tcl_DeleteTrace within a trace
@@ -1297,13 +1509,13 @@ CmdTraceDeleteProc(
static int
ObjTraceProc(
- ClientData clientData, /* unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
- int level, /* Execution level */
- const char *command, /* Command being executed */
- Tcl_Command token, /* Command information */
- int objc, /* Parameter count */
- Tcl_Obj *const objv[]) /* Parameter list */
+ TCL_UNUSED(Tcl_Size) /* level */,
+ const char *command,
+ TCL_UNUSED(Tcl_Command),
+ TCL_UNUSED(Tcl_Size) /*objc*/,
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
@@ -1325,7 +1537,7 @@ ObjTraceProc(
static void
ObjTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
int *intPtr = (int *) clientData;
*intPtr = 1; /* Record that the trace was deleted */
@@ -1354,14 +1566,14 @@ ObjTraceDeleteProc(
static int
TestcreatecommandCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option\"", NULL);
+ " option\"", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
@@ -1376,7 +1588,7 @@ TestcreatecommandCmd(
Tcl_DeleteCommand(interp, "value:at:");
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create, delete, create2, or delete2", NULL);
+ "\": must be create, delete, create2, or delete2", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1384,10 +1596,10 @@ TestcreatecommandCmd(
static int
CreatedCommandProc(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
@@ -1396,20 +1608,20 @@ CreatedCommandProc(
&info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
- info.namespacePtr->fullName, NULL);
+ info.namespacePtr->fullName, (void *)NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
- ClientData clientData, /* String to return. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
@@ -1417,11 +1629,11 @@ CreatedCommandProc2(
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
- info.namespacePtr->fullName, NULL);
+ info.namespacePtr->fullName, (void *)NULL);
return TCL_OK;
}
@@ -1444,7 +1656,7 @@ CreatedCommandProc2(
static int
TestdcallCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1476,7 +1688,7 @@ TestdcallCmd(
static void
DelCallbackProc(
- ClientData clientData, /* Numerical value to append to delString. */
+ void *clientData, /* Numerical value to append to delString. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
int id = PTR2INT(clientData);
@@ -1508,7 +1720,7 @@ DelCallbackProc(
static int
TestdelCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1517,7 +1729,7 @@ TestdelCmd(
Tcl_Interp *child;
if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args", NULL);
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
return TCL_ERROR;
}
@@ -1538,14 +1750,14 @@ TestdelCmd(
static int
DelCmdProc(
- ClientData clientData, /* String result to return. */
+ void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
DelCmd *dPtr = (DelCmd *) clientData;
- Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
+ Tcl_AppendResult(interp, dPtr->deleteCmd, (void *)NULL);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
return TCL_OK;
@@ -1553,11 +1765,11 @@ DelCmdProc(
static void
DelDeleteProc(
- ClientData clientData) /* String command to evaluate. */
+ void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
- Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
+ Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
@@ -1583,14 +1795,14 @@ DelDeleteProc(
static int
TestdelassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key\"", NULL);
+ " data_key\"", (void *)NULL);
return TCL_ERROR;
}
Tcl_DeleteAssocData(interp, argv[1]);
@@ -1612,7 +1824,7 @@ TestdelassocdataCmd(
* Parameters:
* fpval - Floating-point value to format.
* ndigits - Digit count to request from Tcl_DoubleDigits
- * type - One of 'shortest', 'Steele', 'e', 'f'
+ * type - One of 'shortest', 'e', 'f'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
@@ -1620,21 +1832,19 @@ TestdelassocdataCmd(
static int
TestdoubledigitsObjCmd(
- ClientData unused, /* NULL */
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char *options[] = {
"shortest",
- "Steele",
"e",
"f",
NULL
};
static const int types[] = {
TCL_DD_SHORTEST,
- TCL_DD_STEELE,
TCL_DD_E_FORMAT,
TCL_DD_F_FORMAT
};
@@ -1658,8 +1868,8 @@ TestdoubledigitsObjCmd(
status = Tcl_GetDoubleFromObj(interp, objv[1], &d);
if (status != TCL_OK) {
doubleType = Tcl_GetObjType("double");
- if (objv[1]->typePtr == doubleType
- || TclIsNaN(objv[1]->internalRep.doubleValue)) {
+ if (Tcl_FetchInternalRep(objv[1], doubleType)
+ && isnan(objv[1]->internalRep.doubleValue)) {
status = TCL_OK;
memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double));
}
@@ -1677,13 +1887,13 @@ TestdoubledigitsObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
return TCL_ERROR;
}
- type |= TCL_DD_SHORTEN_FLAG;
+ type |= TCL_DD_SHORTEST;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
ckfree(str);
retval = Tcl_NewListObj(1, &strObj);
- Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
+ Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt));
strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
Tcl_ListObjAppendElement(NULL, retval, strObj);
Tcl_SetObjResult(interp, retval);
@@ -1709,7 +1919,7 @@ TestdoubledigitsObjCmd(
static int
TestdstringCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -1718,7 +1928,7 @@ TestdstringCmd(
if (argc < 2) {
wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args", NULL);
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "append") == 0) {
@@ -1754,9 +1964,9 @@ TestdstringCmd(
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
- Tcl_AppendResult(interp, "short", NULL);
+ Tcl_AppendResult(interp, "short", (void *)NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
- Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
+ Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", (void *)NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = (char *)ckalloc(100);
strcpy(s, "This is a malloc-ed string");
@@ -1768,7 +1978,7 @@ TestdstringCmd(
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
Tcl_DStringGetResult(interp, &dstring);
@@ -1777,12 +1987,17 @@ TestdstringCmd(
if (argc != 2) {
goto wrongNumArgs;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring)));
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
goto wrongNumArgs;
}
Tcl_DStringResult(interp, &dstring);
+ } else if (strcmp(argv[1], "toobj") == 0) {
+ if (argc != 2) {
+ goto wrongNumArgs;
+ }
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring));
} else if (strcmp(argv[1], "trunc") == 0) {
if (argc != 3) {
goto wrongNumArgs;
@@ -1798,8 +2013,8 @@ TestdstringCmd(
Tcl_DStringStartSublist(&dstring);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be append, element, end, free, get, length, "
- "result, trunc, or start", NULL);
+ "\": must be append, element, end, free, get, gresult, length, "
+ "result, start, toobj, or trunc", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -1855,14 +2070,14 @@ static void SpecialFree(
*------------------------------------------------------------------------
*/
typedef int
-UtfTransformFn(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
- char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
+UtfTransformFn(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr,
+ char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
static int UtfExtWrapper(
Tcl_Interp *interp, UtfTransformFn *transformer, int objc, Tcl_Obj *const objv[])
{
Tcl_Encoding encoding;
Tcl_EncodingState encState, *encStatePtr;
- int srcLen, bufLen;
+ Tcl_Size srcLen, bufLen;
const unsigned char *bytes;
unsigned char *bufPtr;
int srcRead, dstLen, dstWrote, dstChars;
@@ -1870,19 +2085,21 @@ static int UtfExtWrapper(
int result;
int flags;
Tcl_Obj **flagObjs;
- int nflags;
+ Tcl_Size nflags;
static const struct {
const char *flagKey;
int flag;
} flagMap[] = {
{"start", TCL_ENCODING_START},
{"end", TCL_ENCODING_END},
- {"stoponerror", TCL_ENCODING_STOPONERROR},
{"noterminate", TCL_ENCODING_NO_TERMINATE},
{"charlimit", TCL_ENCODING_CHAR_LIMIT},
+ {"profiletcl8", TCL_ENCODING_PROFILE_TCL8},
+ {"profilestrict", TCL_ENCODING_PROFILE_STRICT},
+ {"profilereplace", TCL_ENCODING_PROFILE_REPLACE},
{NULL, 0}
};
- int i;
+ Tcl_Size i;
Tcl_WideInt wide;
if (objc < 7 || objc > 10) {
@@ -1978,10 +2195,10 @@ static int UtfExtWrapper(
memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */
bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */
result = (*transformer)(interp, encoding, (const char *)bytes, srcLen, flags,
- encStatePtr, (char *) bufPtr, dstLen,
- srcReadVar ? &srcRead : NULL,
- &dstWrote,
- dstCharsVar ? &dstChars : NULL);
+ encStatePtr, (char *) bufPtr, dstLen,
+ srcReadVar ? &srcRead : NULL,
+ &dstWrote,
+ dstCharsVar ? &dstChars : NULL);
if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) {
Tcl_SetResult(interp,
"Tcl_ExternalToUtf wrote past output buffer",
@@ -1991,19 +2208,19 @@ static int UtfExtWrapper(
Tcl_Obj *resultObjs[3];
switch (result) {
case TCL_OK:
- resultObjs[0] = Tcl_NewStringObj("ok", -1);
+ resultObjs[0] = Tcl_NewStringObj("ok", TCL_INDEX_NONE);
break;
case TCL_CONVERT_MULTIBYTE:
- resultObjs[0] = Tcl_NewStringObj("multibyte", -1);
+ resultObjs[0] = Tcl_NewStringObj("multibyte", TCL_INDEX_NONE);
break;
case TCL_CONVERT_SYNTAX:
- resultObjs[0] = Tcl_NewStringObj("syntax", -1);
+ resultObjs[0] = Tcl_NewStringObj("syntax", TCL_INDEX_NONE);
break;
case TCL_CONVERT_UNKNOWN:
- resultObjs[0] = Tcl_NewStringObj("unknown", -1);
+ resultObjs[0] = Tcl_NewStringObj("unknown", TCL_INDEX_NONE);
break;
case TCL_CONVERT_NOSPACE:
- resultObjs[0] = Tcl_NewStringObj("nospace", -1);
+ resultObjs[0] = Tcl_NewStringObj("nospace", TCL_INDEX_NONE);
break;
default:
resultObjs[0] = Tcl_NewIntObj(result);
@@ -2067,21 +2284,22 @@ static int UtfExtWrapper(
static int
TestencodingObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Encoding encoding;
- int index, length;
+ Tcl_Size length;
const char *string;
TclEncoding *encodingPtr;
static const char *const optionStrings[] = {
- "create", "delete", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", NULL
+ "create", "delete", "nullength", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", NULL
};
enum options {
- ENC_CREATE, ENC_DELETE, ENC_EXTTOUTF, ENC_UTFTOEXT
+ ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT
};
+ int index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?args?");
@@ -2133,7 +2351,23 @@ TestencodingObjCmd(
}
Tcl_FreeEncoding(encoding); /* Free returned reference */
Tcl_FreeEncoding(encoding); /* Free to match CREATE */
+ TclFreeInternalRep(objv[2]); /* Free the cached ref */
break;
+
+ case ENC_NULLENGTH:
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
+ return TCL_ERROR;
+ }
+ encoding =
+ Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2]));
+ if (encoding == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp,
+ Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding)));
+ Tcl_FreeEncoding(encoding);
+ break;
case ENC_EXTTOUTF:
return UtfExtWrapper(interp,Tcl_ExternalToUtf,objc,objv);
case ENC_UTFTOEXT:
@@ -2144,11 +2378,11 @@ TestencodingObjCmd(
static int
EncodingToUtfProc(
- ClientData clientData, /* TclEncoding structure. */
- const char *src, /* Source string in specified encoding. */
+ void *clientData, /* TclEncoding structure. */
+ TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
- int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Current state. */
+ TCL_UNUSED(int) /*flags*/,
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
@@ -2159,7 +2393,7 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2176,11 +2410,11 @@ EncodingToUtfProc(
static int
EncodingFromUtfProc(
- ClientData clientData, /* TclEncoding structure. */
- const char *src, /* Source string in specified encoding. */
+ void *clientData, /* TclEncoding structure. */
+ TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
- int flags, /* Conversion control flags. */
- Tcl_EncodingState *statePtr,/* Current state. */
+ TCL_UNUSED(int) /*flags*/,
+ TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
@@ -2191,7 +2425,7 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2208,7 +2442,7 @@ EncodingFromUtfProc(
static void
EncodingFreeProc(
- ClientData clientData) /* ClientData associated with type. */
+ void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
@@ -2236,12 +2470,13 @@ EncodingFreeProc(
static int
TestevalexObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int length, flags;
+ int flags;
+ Tcl_Size length;
const char *script;
flags = 0;
@@ -2249,7 +2484,7 @@ TestevalexObjCmd(
const char *global = Tcl_GetString(objv[2]);
if (strcmp(global, "global") != 0) {
Tcl_AppendResult(interp, "bad value \"", global,
- "\": must be global", NULL);
+ "\": must be global", (void *)NULL);
return TCL_ERROR;
}
flags = TCL_EVAL_GLOBAL;
@@ -2281,7 +2516,7 @@ TestevalexObjCmd(
static int
TestevalobjvObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2330,7 +2565,7 @@ TestevalobjvObjCmd(
static int
TesteventObjCmd(
- ClientData unused, /* Not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
@@ -2343,7 +2578,7 @@ TesteventObjCmd(
"head", "tail", "mark", NULL
};
int posIndex; /* Index of the chosen position */
- static const Tcl_QueuePosition posNum[] = {
+ static const int posNum[] = {
/* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
@@ -2415,7 +2650,7 @@ TesteventObjCmd(
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
- int flags) /* Current flags for Tcl_ServiceEvent */
+ TCL_UNUSED(int) /*flags*/)
{
TestEvent *ev = (TestEvent *) event;
Tcl_Interp *interp = ev->interp;
@@ -2427,14 +2662,14 @@ TesteventProc(
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (command bound to \"testevent\" callback)");
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, TCL_ERROR);
return 1; /* Avoid looping on errors */
}
if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp),
&retval) != TCL_OK) {
Tcl_AddErrorInfo(interp,
" (return value from \"testevent\" callback)");
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, TCL_ERROR);
return 1;
}
if (retval) {
@@ -2466,7 +2701,7 @@ TesteventProc(
static int
TesteventDeleteProc(
Tcl_Event *event, /* Event to examine */
- ClientData clientData) /* Tcl_Obj containing the name of the event(s)
+ void *clientData) /* Tcl_Obj containing the name of the event(s)
* to remove */
{
TestEvent *ev; /* Event to examine */
@@ -2509,7 +2744,7 @@ TesteventDeleteProc(
static int
TestexithandlerCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2518,7 +2753,7 @@ TestexithandlerCmd(
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " create|delete value\"", NULL);
+ " create|delete value\"", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
@@ -2532,7 +2767,7 @@ TestexithandlerCmd(
INT2PTR(value));
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be create or delete", NULL);
+ "\": must be create or delete", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -2540,7 +2775,7 @@ TestexithandlerCmd(
static void
ExitProcOdd(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
@@ -2554,7 +2789,7 @@ ExitProcOdd(
static void
ExitProcEven(
- ClientData clientData) /* Integer value to print. */
+ void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
@@ -2585,7 +2820,7 @@ ExitProcEven(
static int
TestexprlongCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2596,16 +2831,16 @@ TestexprlongCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " expression\"", NULL);
+ " expression\"", (void *)NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "This is a result", NULL);
+ Tcl_AppendResult(interp, "This is a result", (void *)NULL);
result = Tcl_ExprLong(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
snprintf(buf, sizeof(buf), ": %ld", exprResult);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
@@ -2628,7 +2863,7 @@ TestexprlongCmd(
static int
TestexprlongobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2641,13 +2876,13 @@ TestexprlongobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "This is a result", NULL);
+ Tcl_AppendResult(interp, "This is a result", (void *)NULL);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
snprintf(buf, sizeof(buf), ": %ld", exprResult);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
@@ -2670,7 +2905,7 @@ TestexprlongobjCmd(
static int
TestexprdoubleCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2681,17 +2916,17 @@ TestexprdoubleCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " expression\"", NULL);
+ " expression\"", (void *)NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "This is a result", NULL);
+ Tcl_AppendResult(interp, "This is a result", (void *)NULL);
result = Tcl_ExprDouble(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
strcpy(buf, ": ");
Tcl_PrintDouble(interp, exprResult, buf+2);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
@@ -2714,7 +2949,7 @@ TestexprdoubleCmd(
static int
TestexprdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument objects. */
@@ -2727,14 +2962,14 @@ TestexprdoubleobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_AppendResult(interp, "This is a result", NULL);
+ Tcl_AppendResult(interp, "This is a result", (void *)NULL);
result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
}
strcpy(buf, ": ");
Tcl_PrintDouble(interp, exprResult, buf+2);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
@@ -2756,14 +2991,14 @@ TestexprdoubleobjCmd(
static int
TestexprstringCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " expression\"", NULL);
+ " expression\"", (void *)NULL);
return TCL_ERROR;
}
return Tcl_ExprString(interp, argv[1]);
@@ -2788,7 +3023,7 @@ TestexprstringCmd(
static int
TestfilelinkCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -2812,7 +3047,7 @@ TestfilelinkCmd(
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Tcl_GetString(objv[2]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_PosixError(interp), (void *)NULL);
return TCL_ERROR;
}
} else {
@@ -2821,7 +3056,7 @@ TestfilelinkCmd(
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[1]), "\": ",
- Tcl_PosixError(interp), NULL);
+ Tcl_PosixError(interp), (void *)NULL);
return TCL_ERROR;
}
}
@@ -2855,7 +3090,7 @@ TestfilelinkCmd(
static int
TestgetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2864,12 +3099,12 @@ TestgetassocdataCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key\"", NULL);
+ " data_key\"", (void *)NULL);
return TCL_ERROR;
}
res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
if (res != NULL) {
- Tcl_AppendResult(interp, res, NULL);
+ Tcl_AppendResult(interp, res, (void *)NULL);
}
return TCL_OK;
}
@@ -2893,7 +3128,7 @@ TestgetassocdataCmd(
static int
TestgetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2905,11 +3140,11 @@ TestgetplatformCmd(
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, platformStrings[*platform], NULL);
+ Tcl_AppendResult(interp, platformStrings[*platform], (void *)NULL);
return TCL_OK;
}
@@ -2933,7 +3168,7 @@ TestgetplatformCmd(
static int
TestinterpdeleteCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -2942,7 +3177,7 @@ TestinterpdeleteCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " path\"", NULL);
+ " path\"", (void *)NULL);
return TCL_ERROR;
}
childToDelete = Tcl_GetChild(interp, argv[1]);
@@ -2973,7 +3208,7 @@ TestinterpdeleteCmd(
static int
TestlinkCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -3000,7 +3235,7 @@ TestlinkCmd(
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option ?arg arg arg arg arg arg arg arg arg arg arg arg"
- " arg arg?\"", NULL);
+ " arg arg?\"", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
@@ -3008,7 +3243,7 @@ TestlinkCmd(
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
" intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO"
- " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", NULL);
+ " ushortRO uintRO longRO ulongRO floatRO uwideRO\"", (void *)NULL);
return TCL_ERROR;
}
if (created) {
@@ -3032,7 +3267,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "int", (char *)&intVar,
+ if (Tcl_LinkVar(interp, "int", &intVar,
TCL_LINK_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3040,7 +3275,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "real", (char *)&realVar,
+ if (Tcl_LinkVar(interp, "real", &realVar,
TCL_LINK_DOUBLE | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3048,7 +3283,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "bool", (char *)&boolVar,
+ if (Tcl_LinkVar(interp, "bool", &boolVar,
TCL_LINK_BOOLEAN | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3056,7 +3291,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "string", (char *)&stringVar,
+ if (Tcl_LinkVar(interp, "string", &stringVar,
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3064,7 +3299,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "wide", (char *)&wideVar,
+ if (Tcl_LinkVar(interp, "wide", &wideVar,
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3072,7 +3307,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "char", (char *)&charVar,
+ if (Tcl_LinkVar(interp, "char", &charVar,
TCL_LINK_CHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3080,7 +3315,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uchar", (char *)&ucharVar,
+ if (Tcl_LinkVar(interp, "uchar", &ucharVar,
TCL_LINK_UCHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3088,7 +3323,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "short", (char *)&shortVar,
+ if (Tcl_LinkVar(interp, "short", &shortVar,
TCL_LINK_SHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3096,7 +3331,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "ushort", (char *)&ushortVar,
+ if (Tcl_LinkVar(interp, "ushort", &ushortVar,
TCL_LINK_USHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3104,7 +3339,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uint", (char *)&uintVar,
+ if (Tcl_LinkVar(interp, "uint", &uintVar,
TCL_LINK_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3112,7 +3347,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "long", (char *)&longVar,
+ if (Tcl_LinkVar(interp, "long", &longVar,
TCL_LINK_LONG | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3120,7 +3355,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "ulong", (char *)&ulongVar,
+ if (Tcl_LinkVar(interp, "ulong", &ulongVar,
TCL_LINK_ULONG | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3128,7 +3363,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "float", (char *)&floatVar,
+ if (Tcl_LinkVar(interp, "float", &floatVar,
TCL_LINK_FLOAT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3136,7 +3371,7 @@ TestlinkCmd(
return TCL_ERROR;
}
flag = writable ? 0 : TCL_LINK_READ_ONLY;
- if (Tcl_LinkVar(interp, "uwide", (char *)&uwideVar,
+ if (Tcl_LinkVar(interp, "uwide", &uwideVar,
TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
@@ -3181,15 +3416,32 @@ TestlinkCmd(
Tcl_AppendElement(interp, buffer);
TclFormatInt(buffer, (int) uintVar);
Tcl_AppendElement(interp, buffer);
- tmp = Tcl_NewLongObj(longVar);
+ tmp = Tcl_NewWideIntObj(longVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
- tmp = Tcl_NewLongObj((long)ulongVar);
+#ifdef TCL_WIDE_INT_IS_LONG
+ if (ulongVar > WIDE_MAX) {
+ mp_int bignumValue;
+ if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) {
+ Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
+ }
+ tmp = Tcl_NewBignumObj(&bignumValue);
+ } else
+#endif /* TCL_WIDE_INT_IS_LONG */
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
Tcl_PrintDouble(NULL, (double)floatVar, buffer);
Tcl_AppendElement(interp, buffer);
- tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ if (uwideVar > WIDE_MAX) {
+ mp_int bignumValue;
+ if (mp_init_u64(&bignumValue, uwideVar) != MP_OKAY) {
+ Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj");
+ }
+ tmp = Tcl_NewBignumObj(&bignumValue);
+ } else {
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ }
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
@@ -3200,7 +3452,7 @@ TestlinkCmd(
argv[0], " ", argv[1],
" intValue realValue boolValue stringValue wideValue"
" charValue ucharValue shortValue ushortValue uintValue"
- " longValue ulongValue floatValue uwideValue\"", NULL);
+ " longValue ulongValue floatValue uwideValue\"", (void *)NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
@@ -3304,7 +3556,7 @@ TestlinkCmd(
argv[0], " ", argv[1],
" intValue realValue boolValue stringValue wideValue"
" charValue ucharValue shortValue ushortValue uintValue"
- " longValue ulongValue floatValue uwideValue\"", NULL);
+ " longValue ulongValue floatValue uwideValue\"", (void *)NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
@@ -3416,7 +3668,7 @@ TestlinkCmd(
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be create, delete, get, set, or update", NULL);
+ "\": should be create, delete, get, set, or update", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -3425,75 +3677,132 @@ TestlinkCmd(
/*
*----------------------------------------------------------------------
*
- * TestlocaleCmd --
+ * TestlinkarrayCmd --
*
- * This procedure implements the "testlocale" command. It is used
- * to test the effects of setting different locales in Tcl.
+ * This function is invoked to process the "testlinkarray" Tcl command.
+ * It is used to test the 'Tcl_LinkArray' function.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * Modifies the current C locale.
+ * Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
static int
-TestlocaleCmd(
- ClientData clientData, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* The argument objects. */
-{
- int index;
- const char *locale;
-
- static const char *const optionStrings[] = {
- "ctype", "numeric", "time", "collate", "monetary",
- "all", NULL
+TestlinkarrayCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *LinkOption[] = {
+ "update", "remove", "create", NULL
};
- static const int lcTypes[] = {
- LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
- LC_ALL
+ enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE };
+ static const char *LinkType[] = {
+ "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong",
+ "wide", "uwide", "float", "double", "string", "char*", "binary", NULL
};
+ /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */
+ static int LinkTypes[] = {
+ TCL_LINK_CHAR, TCL_LINK_UCHAR,
+ TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT,
+ TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT,
+ TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS,
+ TCL_LINK_BINARY
+ };
+ int optionIndex, typeIndex, readonly, i, size;
+ Tcl_Size length;
+ char *name, *arg;
+ Tcl_WideInt addr;
- /*
- * LC_CTYPE, etc. correspond to the indices for the strings.
- */
-
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option args");
return TCL_ERROR;
}
-
- if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0,
+ &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
+ switch ((enum LinkOptionEnum) optionIndex) {
+ case LINK_UPDATE:
+ for (i=2; i<objc; i++) {
+ Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_REMOVE:
+ for (i=2; i<objc; i++) {
+ Tcl_UnlinkVar(interp, Tcl_GetString(objv[i]));
+ }
+ return TCL_OK;
+ case LINK_CREATE:
+ if (objc < 4) {
+ goto wrongArgs;
+ }
+ readonly = 0;
+ i = 2;
- if (objc == 3) {
- locale = Tcl_GetString(objv[2]);
- } else {
- locale = NULL;
- }
- locale = setlocale(lcTypes[index], locale);
- if (locale) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ /*
+ * test on switch -r...
+ */
+
+ arg = Tcl_GetStringFromObj(objv[i], &length);
+ if (length < 2) {
+ goto wrongArgs;
+ }
+ if (arg[0] == '-') {
+ if (arg[1] != 'r') {
+ goto wrongArgs;
+ }
+ readonly = TCL_LINK_READ_ONLY;
+ 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", -1));
+ 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", -1));
+ 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;
}
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
+ * TestlistrepCmd --
*
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
+ * This function is invoked to generate a list object with a specific
+ * internal representation.
*
* Results:
- * A normal Tcl completion code.
+ * A standard Tcl result.
*
* Side effects:
* None.
@@ -3502,122 +3811,203 @@ TestlocaleCmd(
*/
static int
-TestMathFunc(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Not used. */
- Tcl_Value *args, /* Not used. */
- Tcl_Value *resultPtr) /* Where to store result. */
-{
- resultPtr->type = TCL_INT;
- resultPtr->intValue = PTR2INT(clientData);
+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 */
+ static const char *const 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 {
+ Tcl_WideUInt length;
+ Tcl_WideUInt leadSpace = 0;
+ Tcl_WideUInt endSpace = 0;
+ if (Tcl_GetWideUIntFromObj(interp, objv[2], &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetWideUIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 4) {
+ if (Tcl_GetWideUIntFromObj(interp, objv[4], &endSpace)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ resultObj = TclListTestObj(length, leadSpace, endSpace);
+ if (resultObj == NULL) {
+ Tcl_AppendResult(interp, "List capacity exceeded", (void *)NULL);
+ return TCL_ERROR;
+ }
+ }
+ break;
+
+ case LISTREP_DESCRIBE:
+#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
+ do { \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
+ } while (0)
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **objs;
+ Tcl_Size nobjs;
+ ListRep listRep;
+ Tcl_Obj *listRepObjs[4];
+
+ /* Force list representation */
+ if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ListObjGetRep(objv[2], &listRep);
+ listRepObjs[0] = Tcl_NewStringObj("store", -1);
+ listRepObjs[1] = Tcl_NewListObj(12, NULL);
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
+ if (listRep.spanPtr) {
+ listRepObjs[2] = Tcl_NewStringObj("span", -1);
+ listRepObjs[3] = Tcl_NewListObj(8, NULL);
+ Tcl_ListObjAppendElement(interp,
+ listRepObjs[3],
+ Tcl_NewStringObj("memoryAddress", -1));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
+ APPEND_FIELD(
+ listRepObjs[3], listRep.spanPtr, spanLength);
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
+ }
+ resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
+ }
+#undef APPEND_FIELD
+ break;
+
+ case LISTREP_CONFIG:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewListObj(2, NULL);
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1));
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
+ break;
+
+ case LISTREP_VALIDATE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ TclListObjValidate(interp, objv[2]); /* Panics if invalid */
+ resultObj = Tcl_NewObj();
+ break;
+ }
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TestMathFunc2 --
+ * TestlocaleCmd --
*
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
+ * This procedure implements the "testlocale" command. It is used
+ * to test the effects of setting different locales in Tcl.
*
* Results:
- * A normal Tcl completion code.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
-TestMathFunc2(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Used to report errors. */
- Tcl_Value *args, /* Points to an array of two Tcl_Value structs
- * for the two arguments. */
- Tcl_Value *resultPtr) /* Where to store the result. */
+TestlocaleCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
{
- int result = TCL_OK;
+ int index;
+ const char *locale;
+ static const char *const optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
+ "all", NULL
+ };
+ static const int lcTypes[] = {
+ LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
+ LC_ALL
+ };
/*
- * Return the maximum of the two arguments with the correct type.
+ * LC_CTYPE, etc. correspond to the indices for the strings.
*/
- if (args[0].type == TCL_INT) {
- int i0 = args[0].intValue;
-
- if (args[1].type == TCL_INT) {
- int i1 = args[1].intValue;
-
- resultPtr->type = TCL_INT;
- resultPtr->intValue = ((i0 > i1)? i0 : i1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = i0;
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = Tcl_LongAsWide(i0);
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_DOUBLE) {
- double d0 = args[0].doubleValue;
-
- if (args[1].type == TCL_INT) {
- double d1 = args[1].intValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- double d1 = Tcl_WideAsDouble(args[1].wideValue);
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = args[0].wideValue;
-
- if (args[1].type == TCL_INT) {
- Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = Tcl_WideAsDouble(w0);
- double d1 = args[1].doubleValue;
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ return TCL_ERROR;
+ }
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w1 = args[1].wideValue;
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
- result = TCL_ERROR;
- }
+ if (objc == 3) {
+ locale = Tcl_GetString(objv[2]);
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
- result = TCL_ERROR;
+ locale = NULL;
}
- return result;
+ locale = setlocale(lcTypes[index], locale);
+ if (locale) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ }
+ return TCL_OK;
}
/*
@@ -3639,8 +4029,8 @@ TestMathFunc2(
static void
CleanupTestSetassocdataTests(
- ClientData clientData, /* Data to be released. */
- Tcl_Interp *interp) /* Interpreter being deleted. */
+ void *clientData, /* Data to be released. */
+ TCL_UNUSED(Tcl_Interp *))
{
ckfree(clientData);
}
@@ -3664,13 +4054,14 @@ CleanupTestSetassocdataTests(
static int
TestparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
- int length, dummy;
+ Tcl_Size dummy;
+ int length;
Tcl_Parse parse;
if (objc != 3) {
@@ -3720,13 +4111,14 @@ TestparserObjCmd(
static int
TestexprparserObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
- int length, dummy;
+ Tcl_Size dummy;
+ int length;
Tcl_Parse parse;
if (objc != 3) {
@@ -3788,7 +4180,7 @@ PrintParse(
Tcl_Obj *objPtr;
const char *typeString;
Tcl_Token *tokenPtr;
- int i;
+ Tcl_Size i;
objPtr = Tcl_GetObjResult(interp);
if (parsePtr->commentSize > 0) {
@@ -3801,7 +4193,7 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(parsePtr->numWords));
+ Tcl_NewWideIntObj(parsePtr->numWords));
for (i = 0; i < parsePtr->numTokens; i++) {
tokenPtr = &parsePtr->tokenPtr[i];
switch (tokenPtr->type) {
@@ -3841,12 +4233,12 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewIntObj(tokenPtr->numComponents));
+ Tcl_NewWideIntObj(tokenPtr->numComponents));
}
Tcl_ListObjAppendElement(NULL, objPtr,
parsePtr->commandStart ?
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
- -1) : Tcl_NewObj());
+ TCL_INDEX_NONE) : Tcl_NewObj());
}
/*
@@ -3868,7 +4260,7 @@ PrintParse(
static int
TestparsevarObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -3909,13 +4301,14 @@ TestparsevarObjCmd(
static int
TestparsevarnameObjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
const char *script;
- int append, length, dummy;
+ int length, append;
+ Tcl_Size dummy;
Tcl_Parse parse;
if (objc != 4) {
@@ -3955,6 +4348,76 @@ TestparsevarnameObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestpreferstableObjCmd --
+ *
+ * This procedure implements the "testpreferstable" command. It is
+ * used for being able to test the "package" command even when the
+ * environment variable TCL_PKG_PREFER_LATEST is set in your environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestpreferstableObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ iPtr->packagePrefer = PKG_PREFER_STABLE;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestprintObjCmd --
+ *
+ * This procedure implements the "testprint" command. It is
+ * used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_WideInt argv1 = 0;
+ size_t argv2;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
+ }
+
+ if (objc > 1) {
+ Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+ }
+ argv2 = (size_t)argv1;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
@@ -3973,12 +4436,13 @@ TestparsevarnameObjCmd(
static int
TestregexpObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i, ii, indices, stringLength, match, about;
+ int i, indices, match, about;
+ Tcl_Size stringLength, ii;
int hasxflags, cflags, eflags;
Tcl_RegExp regExpr;
const char *string;
@@ -3996,6 +4460,7 @@ TestregexpObjCmd(
REGEXP_XFLAGS,
REGEXP_LAST
};
+ int index;
indices = 0;
about = 0;
@@ -4005,7 +4470,6 @@ TestregexpObjCmd(
for (i = 1; i < objc; i++) {
const char *name;
- int index;
name = Tcl_GetString(objv[i]);
if (name[0] != '-') {
@@ -4087,20 +4551,20 @@ TestregexpObjCmd(
* value 0.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags&REG_EXPECT) && indices) {
const char *varName;
const char *value;
- int start, end;
+ Tcl_Size start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
- TclRegExpRangeUniChar(regExpr, -1, &start, &end);
+ TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
snprintf(resinfo, sizeof(resinfo), "%d %d", start, end-1);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- varName, "\"", NULL);
+ varName, "\"", (void *)NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
@@ -4111,10 +4575,10 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
snprintf(resinfo, sizeof(resinfo), "%ld", info.extendStart);
- value = Tcl_SetVar(interp, varName, resinfo, 0);
+ value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- varName, "\"", NULL);
+ varName, "\"", (void *)NULL);
return TCL_ERROR;
}
}
@@ -4131,19 +4595,19 @@ TestregexpObjCmd(
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
- int start, end;
+ Tcl_Size start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
- ii = ((cflags&REG_EXPECT) && i == objc-1) ? -1 : i;
+ ii = ((cflags&REG_EXPECT) && i == objc-1) ? TCL_INDEX_NONE : (Tcl_Size)i;
if (indices) {
Tcl_Obj *objs[2];
- if (ii == -1) {
+ if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
- start = -1;
- end = -1;
+ start = TCL_INDEX_NONE;
+ end = TCL_INDEX_NONE;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
@@ -4158,12 +4622,12 @@ TestregexpObjCmd(
end--;
}
- objs[0] = Tcl_NewLongObj(start);
- objs[1] = Tcl_NewLongObj(end);
+ objs[0] = Tcl_NewWideIntObj(start);
+ objs[1] = Tcl_NewWideIntObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
- if (ii == -1) {
+ if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs || info.matches[ii].end <= 0) {
@@ -4183,7 +4647,7 @@ TestregexpObjCmd(
* Set the interpreter's object result to an integer object w/ value 1.
*/
- Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1);
return TCL_OK;
}
@@ -4207,11 +4671,12 @@ TestregexpObjCmd(
static void
TestregexpXflags(
const char *string, /* The string of flags. */
- int length, /* The length of the string in bytes. */
+ size_t length, /* The length of the string in bytes. */
int *cflagsPtr, /* compile flags word */
int *eflagsPtr) /* exec flags word */
{
- int i, cflags, eflags;
+ size_t i;
+ int cflags, eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
@@ -4296,10 +4761,10 @@ TestregexpXflags(
static int
TestreturnObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
@@ -4324,7 +4789,7 @@ TestreturnObjCmd(
static int
TestsetassocdataCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4334,7 +4799,7 @@ TestsetassocdataCmd(
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " data_key data_item\"", NULL);
+ " data_key data_item\"", (void *)NULL);
return TCL_ERROR;
}
@@ -4375,7 +4840,7 @@ TestsetassocdataCmd(
static int
TestsetplatformCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4387,7 +4852,7 @@ TestsetplatformCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " platform\"", NULL);
+ " platform\"", (void *)NULL);
return TCL_ERROR;
}
@@ -4398,7 +4863,7 @@ TestsetplatformCmd(
*platform = TCL_PLATFORM_WINDOWS;
} else {
Tcl_AppendResult(interp, "unsupported platform: should be one of "
- "unix, or windows", NULL);
+ "unix, or windows", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -4407,10 +4872,10 @@ TestsetplatformCmd(
/*
*----------------------------------------------------------------------
*
- * TeststaticpkgCmd --
+ * TeststaticlibraryCmd --
*
- * This procedure implements the "teststaticpkg" command.
- * It is used to test the procedure Tcl_StaticPackage.
+ * This procedure implements the "teststaticlibrary" command.
+ * It is used to test the procedure Tcl_StaticLibrary.
*
* Results:
* A standard Tcl result.
@@ -4423,8 +4888,8 @@ TestsetplatformCmd(
*/
static int
-TeststaticpkgCmd(
- ClientData dummy, /* Not used. */
+TeststaticlibraryCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4433,7 +4898,7 @@ TeststaticpkgCmd(
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " prefix safe loaded\"", NULL);
+ argv[0], " prefix safe loaded\"", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
@@ -4442,7 +4907,7 @@ TeststaticpkgCmd(
if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
return TCL_ERROR;
}
- tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1],
+ Tcl_StaticLibrary((loaded) ? interp : NULL, argv[1],
StaticInitProc, (safe) ? StaticInitProc : NULL);
return TCL_OK;
}
@@ -4452,7 +4917,7 @@ StaticInitProc(
Tcl_Interp *interp) /* Interpreter in which package is supposedly
* being loaded. */
{
- Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
+ Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY);
return TCL_OK;
}
@@ -4475,7 +4940,7 @@ StaticInitProc(
static int
TesttranslatefilenameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4485,14 +4950,14 @@ TesttranslatefilenameCmd(
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " path\"", NULL);
+ argv[0], " path\"", (void *)NULL);
return TCL_ERROR;
}
result = Tcl_TranslateFileName(interp, argv[1], &buffer);
if (result == NULL) {
return TCL_ERROR;
}
- Tcl_AppendResult(interp, result, NULL);
+ Tcl_AppendResult(interp, result, (void *)NULL);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
@@ -4516,7 +4981,7 @@ TesttranslatefilenameCmd(
static int
TestupvarCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4525,7 +4990,7 @@ TestupvarCmd(
if ((argc != 5) && (argc != 6)) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " level name ?name2? dest global\"", NULL);
+ argv[0], " level name ?name2? dest global\"", (void *)NULL);
return TCL_ERROR;
}
@@ -4535,7 +5000,7 @@ TestupvarCmd(
} else if (strcmp(argv[4], "namespace") == 0) {
flags = TCL_NAMESPACE_ONLY;
}
- return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
+ return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags);
} else {
if (strcmp(argv[5], "global") == 0) {
flags = TCL_GLOBAL_ONLY;
@@ -4568,34 +5033,34 @@ TestupvarCmd(
static int
TestseterrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
if (argc > 6) {
- Tcl_AppendResult(interp, "too many args", NULL);
+ Tcl_AppendResult(interp, "too many args", (void *)NULL);
return TCL_ERROR;
}
switch (argc) {
case 1:
- Tcl_SetErrorCode(interp, "NONE", NULL);
+ Tcl_SetErrorCode(interp, "NONE", (void *)NULL);
break;
case 2:
- Tcl_SetErrorCode(interp, argv[1], NULL);
+ Tcl_SetErrorCode(interp, argv[1], (void *)NULL);
break;
case 3:
- Tcl_SetErrorCode(interp, argv[1], argv[2], NULL);
+ Tcl_SetErrorCode(interp, argv[1], argv[2], (void *)NULL);
break;
case 4:
- Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL);
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], (void *)NULL);
break;
case 5:
- Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL);
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], (void *)NULL);
break;
case 6:
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
- argv[5], NULL);
+ argv[5], (void *)NULL);
}
return TCL_ERROR;
}
@@ -4620,7 +5085,7 @@ TestseterrorcodeCmd(
static int
TestsetobjerrorcodeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4648,7 +5113,7 @@ TestsetobjerrorcodeCmd(
static int
TestfeventCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -4659,23 +5124,23 @@ TestfeventCmd(
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg ...?", NULL);
+ " option ?arg ...?", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "cmd") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " cmd script", NULL);
+ " cmd script", (void *)NULL);
return TCL_ERROR;
}
if (interp2 != NULL) {
- code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL);
+ 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);
+ (void *)NULL);
return TCL_ERROR;
}
} else if (strcmp(argv[1], "create") == 0) {
@@ -4720,19 +5185,17 @@ TestfeventCmd(
static int
TestpanicCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- char *argString;
-
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
- argString = Tcl_Merge(argc-1, argv+1);
+ char *argString = Tcl_Merge(argc-1, argv+1);
Tcl_Panic("%s", argString);
ckfree(argString);
@@ -4741,7 +5204,7 @@ TestpanicCmd(
static int
TestfileCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
Tcl_Obj *const argv[]) /* The argument objects. */
@@ -4793,11 +5256,11 @@ TestfileCmd(
if (result != TCL_OK) {
if (error != NULL) {
if (Tcl_GetString(error)[0] != '\0') {
- Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);
+ Tcl_AppendResult(interp, Tcl_GetString(error), " ", (void *)NULL);
}
Tcl_DecrRefCount(error);
}
- Tcl_AppendResult(interp, Tcl_ErrnoId(), NULL);
+ Tcl_AppendResult(interp, Tcl_ErrnoId(), (void *)NULL);
}
end:
@@ -4823,7 +5286,7 @@ TestfileCmd(
static int
TestgetvarfullnameCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -4884,7 +5347,7 @@ TestgetvarfullnameCmd(
*
* This procedure implements the "gettimes" command. It is used for
* computing the time needed for various basic operations such as reading
- * variables, allocating memory, sprintf, converting variables, etc.
+ * variables, allocating memory, snprintf, converting variables, etc.
*
* Results:
* A standard Tcl result.
@@ -4897,10 +5360,10 @@ TestgetvarfullnameCmd(
static int
GetTimesObjCmd(
- ClientData unused, /* Unused. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* The current interpreter. */
- int objc, /* Number of arguments. (not used)*/
- Tcl_Obj *const dummy[]) /* The argument objects (not used). */
+ TCL_UNUSED(int) /*cobjc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/)
{
Interp *iPtr = (Interp *) interp;
int i, n;
@@ -4909,8 +5372,6 @@ GetTimesObjCmd(
Tcl_Obj *objPtr, **objv;
const char *s;
char newString[TCL_INTEGER_SPACE];
- (void)objc;
- (void)dummy;
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
@@ -4967,7 +5428,7 @@ GetTimesObjCmd(
ckfree(objv);
/* TclGetString 100000 times */
- fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
+ fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
@@ -4975,7 +5436,7 @@ GetTimesObjCmd(
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
- fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
+ fprintf(stderr, " %.3f usec per Tcl_GetStringFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
@@ -5028,10 +5489,10 @@ GetTimesObjCmd(
timePer/100000);
/* Tcl_SetVar 100000 times */
- fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
+ fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
+ s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -5045,7 +5506,7 @@ GetTimesObjCmd(
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
- s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
+ s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
@@ -5078,10 +5539,10 @@ GetTimesObjCmd(
static int
NoopCmd(
- ClientData unused, /* Unused. */
- Tcl_Interp *interp, /* The current interpreter. */
- int argc, /* The number of arguments. */
- const char **argv) /* The argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
@@ -5105,10 +5566,10 @@ NoopCmd(
static int
NoopObjCmd(
- ClientData unused, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* The argument objects. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
@@ -5130,14 +5591,13 @@ NoopObjCmd(
static int
TeststringbytesObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int n;
+ Tcl_Size n;
const unsigned char *p;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
@@ -5171,13 +5631,12 @@ TeststringbytesObjCmd(
static int
TestpurebytesobjObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
- (void)dummy;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?string?");
@@ -5219,14 +5678,13 @@ TestpurebytesobjObjCmd(
static int
TestsetbytearraylengthObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
Tcl_Obj *obj = NULL;
- (void)dummy;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
@@ -5235,12 +5693,17 @@ TestsetbytearraylengthObjCmd(
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
- if (Tcl_IsShared(objv[1])) {
- obj = Tcl_DuplicateObj(objv[1]);
- } else {
- obj = objv[1];
+ 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", (void *)NULL);
+ return TCL_ERROR;
}
- Tcl_SetByteArrayLength(obj, n);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
@@ -5264,22 +5727,68 @@ TestsetbytearraylengthObjCmd(
static int
TestbytestringObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int n = 0;
+ struct {
+ Tcl_Size n;
+ int m; /* This variable should not be overwritten */
+ } x = {0, 1};
const char *p;
- (void)dummy;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
- p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
+ p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n);
+ if (p == NULL) {
+ return TCL_ERROR;
+ }
+ if (x.m != 1) {
+ Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Testutf16stringObjCmd --
+ *
+ * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj
+ * C functions which broke in Tcl 8.7 and were undetected by the
+ * existing test suite. Bug [b79df322a9]
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+Testutf16stringObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ const unsigned short *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ p = Tcl_GetUnicode(objv[1]);
+ Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE));
return TCL_OK;
}
@@ -5302,7 +5811,7 @@ TestbytestringObjCmd(
static int
TestsetCmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5311,7 +5820,7 @@ TestsetCmd(
const char *value;
if (argc == 2) {
- Tcl_AppendResult(interp, "before get", NULL);
+ Tcl_AppendResult(interp, "before get", (void *)NULL);
value = Tcl_GetVar2(interp, argv[1], NULL, flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5319,7 +5828,7 @@ TestsetCmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
- Tcl_AppendResult(interp, "before set", NULL);
+ Tcl_AppendResult(interp, "before set", (void *)NULL);
value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5328,13 +5837,13 @@ TestsetCmd(
return TCL_OK;
} else {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " varName ?newValue?\"", NULL);
+ argv[0], " varName ?newValue?\"", (void *)NULL);
return TCL_ERROR;
}
}
static int
Testset2Cmd(
- ClientData data, /* Additional flags for Get/SetVar2. */
+ void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -5343,7 +5852,7 @@ Testset2Cmd(
const char *value;
if (argc == 3) {
- Tcl_AppendResult(interp, "before get", NULL);
+ Tcl_AppendResult(interp, "before get", (void *)NULL);
value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5351,7 +5860,7 @@ Testset2Cmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 4) {
- Tcl_AppendResult(interp, "before set", NULL);
+ Tcl_AppendResult(interp, "before set", (void *)NULL);
value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5360,7 +5869,7 @@ Testset2Cmd(
return TCL_OK;
} else {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " varName elemName ?newValue?\"", NULL);
+ argv[0], " varName elemName ?newValue?\"", (void *)NULL);
return TCL_ERROR;
}
}
@@ -5382,9 +5891,10 @@ Testset2Cmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static int
TestsaveresultCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
@@ -5416,16 +5926,17 @@ TestsaveresultCmd(
return TCL_ERROR;
}
- objPtr = NULL; /* Lint. */
+ freeCount = 0;
+ objPtr = NULL;
switch ((enum options) index) {
case RESULT_SMALL:
- Tcl_SetResult(interp, "small result", TCL_VOLATILE);
+ Tcl_AppendResult(interp, "small result", (void *)NULL);
break;
case RESULT_APPEND:
- Tcl_AppendResult(interp, "append result", NULL);
+ Tcl_AppendResult(interp, "append result", (void *)NULL);
break;
case RESULT_FREE: {
- char *buf = ckalloc(200);
+ char *buf = (char *)ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
@@ -5435,18 +5946,17 @@ TestsaveresultCmd(
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
- objPtr = Tcl_NewStringObj("object result", -1);
+ objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE);
Tcl_SetObjResult(interp, objPtr);
break;
}
- freeCount = 0;
Tcl_SaveResult(interp, &state);
if (((enum options) index) == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
- result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
+ result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
}
if (discard) {
@@ -5458,11 +5968,9 @@ TestsaveresultCmd(
switch ((enum options) index) {
case RESULT_DYNAMIC: {
- int present = iPtr->freeProc == TestsaveresultFree;
- int called = freeCount;
+ int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount;
- Tcl_AppendElement(interp, called ? "called" : "notCalled");
- Tcl_AppendElement(interp, present ? "present" : "missing");
+ Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak");
break;
}
case RESULT_OBJECT:
@@ -5494,13 +6002,14 @@ TestsaveresultCmd(
static void
TestsaveresultFree(
#if TCL_MAJOR_VERSION > 8
- void *blockPtr)
+ TCL_UNUSED(void *))
#else
- char *blockPtr)
+ TCL_UNUSED(char *))
#endif
{
freeCount++;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5521,10 +6030,10 @@ TestsaveresultFree(
static int
TestmainthreadCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(const char **) /*argv*/)
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
@@ -5532,7 +6041,7 @@ TestmainthreadCmd(
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
- Tcl_AppendResult(interp, "wrong # args", NULL);
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
return TCL_ERROR;
}
}
@@ -5582,10 +6091,10 @@ MainLoop(void)
static int
TestsetmainloopCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
@@ -5611,10 +6120,10 @@ TestsetmainloopCmd(
static int
TestexitmainloopCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp,/* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(void *),
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 1;
return TCL_OK;
@@ -5639,7 +6148,7 @@ TestexitmainloopCmd(
static int
TestChannelCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter for result. */
int argc, /* Count of additional args. */
const char **argv) /* Additional arg strings. */
@@ -5658,7 +6167,7 @@ TestChannelCmd(
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " subcommand ?additional args..?\"", NULL);
+ " subcommand ?additional args..?\"", (void *)NULL);
return TCL_ERROR;
}
cmdName = argv[1];
@@ -5741,7 +6250,7 @@ TestChannelCmd(
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " cut channelName\"", NULL);
+ " cut channelName\"", (void *)NULL);
return TCL_ERROR;
}
@@ -5764,7 +6273,7 @@ TestChannelCmd(
(strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " clearchannelhandlers channelName\"", NULL);
+ " clearchannelhandlers channelName\"", (void *)NULL);
return TCL_ERROR;
}
Tcl_ClearChannelHandlers(chan);
@@ -5774,7 +6283,7 @@ TestChannelCmd(
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " info channelName\"", NULL);
+ " info channelName\"", (void *)NULL);
return TCL_ERROR;
}
Tcl_AppendElement(interp, argv[2]);
@@ -5866,40 +6375,40 @@ TestChannelCmd(
if ((cmdName[0] == 'i') &&
(strncmp(cmdName, "inputbuffered", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
IOQueued = Tcl_InputBuffered(chan);
TclFormatInt(buf, IOQueued);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsChannelShared(chan));
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, Tcl_IsStandardChannel(chan));
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
@@ -5916,9 +6425,46 @@ TestChannelCmd(
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ if (statePtr->maxPerms & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->maxPerms & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
@@ -5929,10 +6475,10 @@ TestChannelCmd(
if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, statePtr->channelName, NULL);
+ Tcl_AppendResult(interp, statePtr->channelName, (void *)NULL);
return TCL_OK;
}
@@ -5952,25 +6498,25 @@ TestChannelCmd(
if ((cmdName[0] == 'o') &&
(strncmp(cmdName, "outputbuffered", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
IOQueued = Tcl_OutputBuffered(chan);
TclFormatInt(buf, IOQueued);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
if ((cmdName[0] == 'q') &&
(strncmp(cmdName, "queuedcr", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp,
- (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", NULL);
+ (statePtr->flags & INPUT_SAW_CR) ? "1" : "0", (void *)NULL);
return TCL_OK;
}
@@ -5993,12 +6539,12 @@ TestChannelCmd(
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
TclFormatInt(buf, statePtr->refCount);
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_AppendResult(interp, buf, (void *)NULL);
return TCL_OK;
}
@@ -6011,7 +6557,7 @@ TestChannelCmd(
if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
@@ -6025,10 +6571,10 @@ TestChannelCmd(
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
if (argc != 3) {
- Tcl_AppendResult(interp, "channel name required", NULL);
+ Tcl_AppendResult(interp, "channel name required", (void *)NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), NULL);
+ Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), (void *)NULL);
return TCL_OK;
}
@@ -6055,12 +6601,12 @@ TestChannelCmd(
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " transform channelId -command cmd\"", NULL);
+ " transform channelId -command cmd\"", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "-command") != 0) {
Tcl_AppendResult(interp, "bad argument \"", argv[3],
- "\": should be \"-command\"", NULL);
+ "\": should be \"-command\"", (void *)NULL);
return TCL_ERROR;
}
@@ -6075,7 +6621,7 @@ TestChannelCmd(
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " unstack channel\"", NULL);
+ " unstack channel\"", (void *)NULL);
return TCL_ERROR;
}
return Tcl_UnstackChannel(interp, chan);
@@ -6083,7 +6629,7 @@ TestChannelCmd(
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
"cut, clearchannelhandlers, info, isshared, mode, open, "
- "readable, splice, writable, transform, unstack", NULL);
+ "readable, splice, writable, transform, unstack", (void *)NULL);
return TCL_ERROR;
}
@@ -6106,7 +6652,7 @@ TestChannelCmd(
static int
TestChannelEventCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -6120,7 +6666,7 @@ TestChannelEventCmd(
if ((argc < 3) || (argc > 5)) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName cmd ?arg1? ?arg2?\"", NULL);
+ " channelName cmd ?arg1? ?arg2?\"", (void *)NULL);
return TCL_ERROR;
}
chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
@@ -6134,7 +6680,7 @@ TestChannelEventCmd(
if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName add eventSpec script\"", NULL);
+ " channelName add eventSpec script\"", (void *)NULL);
return TCL_ERROR;
}
if (strcmp(argv[3], "readable") == 0) {
@@ -6145,7 +6691,7 @@ TestChannelEventCmd(
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
- "\": must be readable, writable, or none", NULL);
+ "\": must be readable, writable, or none", (void *)NULL);
return TCL_ERROR;
}
@@ -6168,7 +6714,7 @@ TestChannelEventCmd(
if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) {
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName delete index\"", NULL);
+ " channelName delete index\"", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
@@ -6176,7 +6722,7 @@ TestChannelEventCmd(
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
- ": must be nonnegative", NULL);
+ ": must be nonnegative", (void *)NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
@@ -6186,7 +6732,7 @@ TestChannelEventCmd(
}
if (esPtr == NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
- ": out of range", NULL);
+ ": out of range", (void *)NULL);
return TCL_ERROR;
}
if (esPtr == statePtr->scriptRecordPtr) {
@@ -6214,7 +6760,7 @@ TestChannelEventCmd(
if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName list\"", NULL);
+ " channelName list\"", (void *)NULL);
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
@@ -6237,7 +6783,7 @@ TestChannelEventCmd(
if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName removeall\"", NULL);
+ " channelName removeall\"", (void *)NULL);
return TCL_ERROR;
}
for (esPtr = statePtr->scriptRecordPtr;
@@ -6256,7 +6802,7 @@ TestChannelEventCmd(
if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelName delete index event\"", NULL);
+ " channelName delete index event\"", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
@@ -6264,7 +6810,7 @@ TestChannelEventCmd(
}
if (index < 0) {
Tcl_AppendResult(interp, "bad event index: ", argv[3],
- ": must be nonnegative", NULL);
+ ": must be nonnegative", (void *)NULL);
return TCL_ERROR;
}
for (i = 0, esPtr = statePtr->scriptRecordPtr;
@@ -6274,7 +6820,7 @@ TestChannelEventCmd(
}
if (esPtr == NULL) {
Tcl_AppendResult(interp, "bad event index ", argv[3],
- ": out of range", NULL);
+ ": out of range", (void *)NULL);
return TCL_ERROR;
}
@@ -6286,7 +6832,7 @@ TestChannelEventCmd(
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[4],
- "\": must be readable, writable, or none", NULL);
+ "\": must be readable, writable, or none", (void *)NULL);
return TCL_ERROR;
}
esPtr->mask = mask;
@@ -6295,7 +6841,87 @@ TestChannelEventCmd(
return TCL_OK;
}
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
- "add, delete, list, set, or removeall", NULL);
+ "add, delete, list, set, or removeall", (void *)NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestSocketCmd --
+ *
+ * Implements the Tcl "testsocket" debugging command and its
+ * subcommands. This is part of the testing environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * 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. */
+{
+ const char *cmdName; /* Sub command. */
+ size_t len; /* Length of subcommand string. */
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", (void *)NULL);
+ return TCL_ERROR;
+ }
+ 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],
+ " testflags channel flags\"", (void *)NULL);
+ return TCL_ERROR;
+ }
+ hChannel = Tcl_GetChannel(interp, argv[2], &modePtr);
+ if ( NULL == hChannel ) {
+ Tcl_AppendResult(interp, "unknown channel:", argv[2], (void *)NULL);
+ return TCL_ERROR;
+ }
+ statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
+ if ( NULL == statePtr) {
+ Tcl_AppendResult(interp, "No channel instance data:", argv[2],
+ (void *)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", (void *)NULL);
return TCL_ERROR;
}
@@ -6321,7 +6947,7 @@ TestChannelEventCmd(
static int
TestServiceModeCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -6329,7 +6955,7 @@ TestServiceModeCmd(
int newmode, oldmode;
if (argc > 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?newmode?\"", NULL);
+ " ?newmode?\"", (void *)NULL);
return TCL_ERROR;
}
oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE);
@@ -6343,7 +6969,7 @@ TestServiceModeCmd(
Tcl_SetServiceMode(TCL_SERVICE_ALL);
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode));
return TCL_OK;
}
@@ -6365,19 +6991,19 @@ TestServiceModeCmd(
static int
TestWrongNumArgsObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i, length;
+ Tcl_Size i, length;
const char *msg;
if (objc < 3) {
goto insufArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -6391,7 +7017,7 @@ TestWrongNumArgsObjCmd(
* Asked for more arguments than were given.
*/
insufArgs:
- Tcl_AppendResult(interp, "insufficient arguments", NULL);
+ Tcl_AppendResult(interp, "insufficient arguments", (void *)NULL);
return TCL_ERROR;
}
@@ -6417,7 +7043,7 @@ TestWrongNumArgsObjCmd(
static int
TestGetIndexFromObjStructObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6425,7 +7051,8 @@ TestGetIndexFromObjStructObjCmd(
const char *const ary[] = {
"a", "b", "c", "d", "ee", "ff", NULL, NULL
};
- int idx,target, flags = 0;
+ int target, flags = 0;
+ signed char idx[8];
if (objc != 3 && objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?");
@@ -6437,17 +7064,21 @@ TestGetIndexFromObjStructObjCmd(
if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) {
return TCL_ERROR;
}
+ memset(idx, 85, sizeof(idx));
if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *),
- "dummy", flags, &idx) != TCL_OK) {
+ "dummy", flags, &idx[1]) != TCL_OK) {
return TCL_ERROR;
}
- if (idx != target) {
+ if (idx[0] != 85 || idx[2] != 85) {
+ Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", (void *)NULL);
+ return TCL_ERROR;
+ } else if (idx[1] != target) {
char buffer[64];
- snprintf(buffer, sizeof(buffer), "%d", idx);
+ snprintf(buffer, sizeof(buffer), "%d", idx[1]);
Tcl_AppendResult(interp, "index value comparison failed: got ",
- buffer, NULL);
+ buffer, (void *)NULL);
snprintf(buffer, sizeof(buffer), "%d", target);
- Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
+ Tcl_AppendResult(interp, " when ", buffer, " expected", (void *)NULL);
return TCL_ERROR;
}
Tcl_WrongNumArgs(interp, objc, objv, NULL);
@@ -6474,7 +7105,7 @@ TestGetIndexFromObjStructObjCmd(
static int
TestFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6503,7 +7134,7 @@ TestFilesystemObjCmd(
static int
TestReportInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
static Tcl_Obj *lastPathPtr = NULL;
Tcl_Obj *newPathPtr;
@@ -6543,7 +7174,7 @@ TestReportGetNativePath(
static void
TestReportFreeInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *nativeRep = (Tcl_Obj *) clientData;
@@ -6553,9 +7184,9 @@ TestReportFreeInternalRep(
}
}
-static ClientData
+static void *
TestReportDupInternalRep(
- ClientData clientData)
+ void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
@@ -6591,7 +7222,7 @@ TestReport(
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_Eval(interp, Tcl_DStringValue(&ds));
+ Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
@@ -6805,7 +7436,7 @@ TestReportUtime(
static int
TestReportNormalizePath(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
@@ -6816,7 +7447,7 @@ TestReportNormalizePath(
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
- ClientData *clientDataPtr)
+ TCL_UNUSED(void **))
{
const char *str = Tcl_GetString(pathPtr);
@@ -6845,7 +7476,7 @@ SimplePathInFilesystem(
static int
TestSimpleFilesystemObjCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -6880,7 +7511,7 @@ static Tcl_Obj *
SimpleRedirect(
Tcl_Obj *pathPtr) /* Name of file to copy. */
{
- int len;
+ Tcl_Size len;
const char *str;
Tcl_Obj *origPtr;
@@ -6926,7 +7557,7 @@ SimpleMatchInDirectory(
origPtr = SimpleRedirect(dirPtr);
res = Tcl_FSMatchInDirectory(interp, resPtr, origPtr, pattern, types);
if (res == TCL_OK) {
- int gLength, j;
+ Tcl_Size gLength, j;
Tcl_ListObjLength(NULL, resPtr, &gLength);
for (j = 0; j < gLength; j++) {
Tcl_Obj *gElt, *nElt;
@@ -6954,7 +7585,7 @@ SimpleOpenFileChannel(
Tcl_Channel chan;
if ((mode != 0) && !(mode & O_RDONLY)) {
- Tcl_AppendResult(interp, "read-only", NULL);
+ Tcl_AppendResult(interp, "read-only", (void *)NULL);
return NULL;
}
@@ -7002,71 +7633,45 @@ SimpleListVolumes(void)
/*
* Used to check operations of Tcl_UtfNext.
*
- * Usage: testutfnext $bytes $offset
+ * Usage: testutfnext -bytestring $bytes
*/
static int
TestUtfNextCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- int numBytes; /* Number of bytes supplied in the test string */
- int offset; /* Number of bytes we are permitted to read */
+ Tcl_Size numBytes;
char *bytes;
const char *result, *first;
char buffer[32];
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
- (void)dummy;
- if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "string ?numBytes?");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
+ bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
- bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
-
- offset = numBytes +TCL_UTF_MAX -1; /* If no constraint is given, allow
- * the terminating NUL to limit
- * operations. */
-
- if (objc == 3) {
- if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) {
- return TCL_ERROR;
- }
- if (offset < 0) {
- offset = 0;
- }
- if (offset > numBytes +TCL_UTF_MAX -1) {
- offset = numBytes +TCL_UTF_MAX -1;
- }
- }
-
- if (numBytes > (int)sizeof(buffer) - 3) {
+ if ((size_t)numBytes > sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"testutfnext\" can only handle %d bytes",
- (int)sizeof(buffer) - 4));
+ "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes",
+ sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
- if (!Tcl_UtfCharComplete(buffer + 1, offset)) {
- /* Cannot scan a complete sequence from the data */
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- return TCL_OK;
- }
-
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
- Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", NULL);
+ Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", (void *)NULL);
return TCL_ERROR;
}
}
@@ -7082,7 +7687,7 @@ TestUtfNextCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1));
return TCL_OK;
}
@@ -7094,12 +7699,12 @@ TestUtfNextCmd(
static int
TestUtfPrevCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- int numBytes, offset;
+ Tcl_Size numBytes, offset;
char *bytes;
const char *result;
@@ -7111,7 +7716,7 @@ TestUtfPrevCmd(
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
- if (TCL_OK != TclGetIntForIndex(interp, objv[2], numBytes, &offset)) {
+ if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset < 0) {
@@ -7123,8 +7728,8 @@ TestUtfPrevCmd(
} else {
offset = numBytes;
}
- result = TclUtfPrev(bytes + offset, bytes);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes));
+ result = Tcl_UtfPrev(bytes + offset, bytes);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes));
return TCL_OK;
}
@@ -7134,17 +7739,17 @@ TestUtfPrevCmd(
static int
TestNumUtfCharsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
- int numBytes, len, limit = -1;
+ Tcl_Size numBytes, len, limit = TCL_INDEX_NONE;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
- if (TclGetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
@@ -7152,7 +7757,7 @@ TestNumUtfCharsCmd(
}
}
len = Tcl_NumUtfChars(bytes, limit);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len));
}
return TCL_OK;
}
@@ -7166,7 +7771,7 @@ TestNumUtfCharsCmd(
*/
static int
TestGetUniCharCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[] /* Argument strings */
@@ -7191,7 +7796,7 @@ TestGetUniCharCmd(
static int
TestFindFirstCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7213,7 +7818,7 @@ TestFindFirstCmd(
static int
TestFindLastCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7229,6 +7834,33 @@ TestFindLastCmd(
return TCL_OK;
}
+static int
+TestGetIntForIndexCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Size result;
+ Tcl_WideInt endvalue;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "index endvalue");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &endvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
+ return TCL_OK;
+}
+
+
+
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
/*
*----------------------------------------------------------------------
@@ -7255,13 +7887,13 @@ TestFindLastCmd(
static int
TestcpuidCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
- unsigned int regs[4];
+ int regs[4];
Tcl_Obj *regsObjs[4];
if (objc != 2) {
@@ -7271,14 +7903,14 @@ TestcpuidCmd(
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
- status = TclWinCPUID((unsigned) index, regs);
+ status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", -1));
return status;
}
for (i=0 ; i<4 ; ++i) {
- regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ regsObjs[i] = Tcl_NewWideIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -7291,7 +7923,7 @@ TestcpuidCmd(
static int
TestHashSystemHashCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -7303,7 +7935,6 @@ TestHashSystemHashCmd(
Tcl_HashTable hash;
Tcl_HashEntry *hPtr;
int i, isNew, limit = 100;
- (void)dummy;
if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
return TCL_ERROR;
@@ -7312,7 +7943,7 @@ TestHashSystemHashCmd(
Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType);
if (hash.numEntries != 0) {
- Tcl_AppendResult(interp, "non-zero initial size", NULL);
+ Tcl_AppendResult(interp, "non-zero initial size", (void *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7320,7 +7951,7 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
@@ -7328,8 +7959,8 @@ TestHashSystemHashCmd(
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
- if (hash.numEntries != limit) {
- Tcl_AppendResult(interp, "unexpected maximal size", NULL);
+ if (hash.numEntries != (Tcl_Size)limit) {
+ Tcl_AppendResult(interp, "unexpected maximal size", (void *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7337,14 +7968,14 @@ TestHashSystemHashCmd(
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", -1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7352,13 +7983,13 @@ TestHashSystemHashCmd(
}
if (hash.numEntries != 0) {
- Tcl_AppendResult(interp, "non-zero final size", NULL);
+ Tcl_AppendResult(interp, "non-zero final size", (void *)NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_DeleteHashTable(&hash);
- Tcl_AppendResult(interp, "OK", NULL);
+ Tcl_AppendResult(interp, "OK", (void *)NULL);
return TCL_OK;
}
@@ -7368,15 +7999,13 @@ TestHashSystemHashCmd(
*/
static int
TestgetintCmd(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int argc,
const char **argv)
{
- (void)dummy;
-
if (argc < 2) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
return TCL_ERROR;
} else {
int val, i, total=0;
@@ -7387,19 +8016,36 @@ TestgetintCmd(
}
total += val;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(total));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(total));
return TCL_OK;
}
}
+/*
+ * Used for determining sizeof(long) at script level.
+ */
+static int
+TestlongsizeCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp,
+ int argc,
+ TCL_UNUSED(const char **) /*argv*/)
+{
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args", (void *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(long)));
+ return TCL_OK;
+}
+
static int
NREUnwind_callback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
- int result)
+ TCL_UNUSED(int) /*result*/)
{
void *cStackPtr = TclGetCStackPtr();
- (void)result;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, cStackPtr, INT2PTR(-1),
@@ -7412,9 +8058,9 @@ NREUnwind_callback(
cStackPtr, NULL);
} else {
Tcl_Obj *idata[3];
- idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0]));
- idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0]));
- idata[2] = Tcl_NewIntObj((int) ((char *) cStackPtr - (char *) data[0]));
+ idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0]));
+ idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0]));
+ idata[2] = Tcl_NewWideIntObj(((char *) cStackPtr - (char *) data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
@@ -7422,15 +8068,11 @@ NREUnwind_callback(
static int
TestNREUnwind(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
- (void)dummy;
- (void)objc;
- (void)objv;
-
/*
* Insure that callbacks effectively run at the proper level during the
* unwinding of the NRE stack.
@@ -7444,20 +8086,17 @@ TestNREUnwind(
static int
TestNRELevels(
- ClientData dummy,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
Tcl_Obj *levels[6];
- int i = 0;
+ Tcl_Size i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
- (void)dummy;
- (void)objc;
- (void)objv;
if (refDepth == NULL) {
refDepth = (ptrdiff_t *)TclGetCStackPtr();
@@ -7465,18 +8104,18 @@ TestNRELevels(
depth = (refDepth - (ptrdiff_t *)TclGetCStackPtr());
- levels[0] = Tcl_NewIntObj(depth);
- levels[1] = Tcl_NewIntObj(iPtr->numLevels);
- levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
- levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
- levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
+ levels[0] = Tcl_NewWideIntObj(depth);
+ levels[1] = Tcl_NewWideIntObj(iPtr->numLevels);
+ levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level);
+ levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level);
+ levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
- iPtr->execEnvPtr->execStackPtr->stackWords);
while (cbPtr) {
i++;
cbPtr = cbPtr->nextPtr;
}
- levels[5] = Tcl_NewIntObj(i);
+ levels[5] = Tcl_NewWideIntObj(i);
Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
return TCL_OK;
@@ -7503,13 +8142,14 @@ TestNRELevels(
static int
TestconcatobjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- const char **argv) /* Argument strings. */
+ TCL_UNUSED(int) /*argc*/,
+ TCL_UNUSED(const char **) /*argv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
- int result = TCL_OK, len;
+ int result = TCL_OK;
+ Tcl_Size len;
Tcl_Obj *objv[3];
/*
@@ -7524,17 +8164,11 @@ TestconcatobjCmd(
list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
Tcl_ListObjLength(NULL, list1Ptr, &len);
- if (list1Ptr->bytes != NULL) {
- ckfree(list1Ptr->bytes);
- list1Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list1Ptr);
list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
Tcl_ListObjLength(NULL, list2Ptr, &len);
- if (list2Ptr->bytes != NULL) {
- ckfree(list2Ptr->bytes);
- list2Ptr->bytes = NULL;
- }
+ Tcl_InvalidateStringRep(list2Ptr);
/*
* Verify that concat'ing a list obj with one or more empty strings does
@@ -7549,21 +8183,21 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (a) concatObj does not have refCount 0", NULL);
+ "\n\t* (a) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (a) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
switch (tmpPtr->refCount) {
case 0:
- Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL);
break;
case 1:
- Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_AppendResult(interp, "(refCount added)", (void *)NULL);
break;
default:
- Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
@@ -7576,26 +8210,26 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (b) concatObj does not have refCount 0", NULL);
+ "\n\t* (b) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (b) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
switch (tmpPtr->refCount) {
case 0:
- Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
break;
case 1:
- Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL);
break;
case 2:
- Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_AppendResult(interp, "(refCount added)", (void *)NULL);
Tcl_DecrRefCount(tmpPtr);
break;
default:
- Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
@@ -7610,21 +8244,21 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (c) concatObj does not have refCount 0", NULL);
+ "\n\t* (c) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (c) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
switch (tmpPtr->refCount) {
case 0:
- Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL);
break;
case 1:
- Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_AppendResult(interp, "(refCount added)", (void *)NULL);
break;
default:
- Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
@@ -7637,26 +8271,26 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (d) concatObj does not have refCount 0", NULL);
+ "\n\t* (d) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (d) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
switch (tmpPtr->refCount) {
case 0:
- Tcl_AppendResult(interp, "(refCount removed?)", NULL);
+ Tcl_AppendResult(interp, "(refCount removed?)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
break;
case 1:
- Tcl_AppendResult(interp, "(no new refCount)", NULL);
+ Tcl_AppendResult(interp, "(no new refCount)", (void *)NULL);
break;
case 2:
- Tcl_AppendResult(interp, "(refCount added)", NULL);
+ Tcl_AppendResult(interp, "(refCount added)", (void *)NULL);
Tcl_DecrRefCount(tmpPtr);
break;
default:
- Tcl_AppendResult(interp, "(more than one refCount added!)", NULL);
+ Tcl_AppendResult(interp, "(more than one refCount added!)", (void *)NULL);
Tcl_Panic("extremely unsafe behaviour by Tcl_ConcatObj()");
}
tmpPtr = Tcl_DuplicateObj(list1Ptr);
@@ -7675,20 +8309,20 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (e) concatObj does not have refCount 0", NULL);
+ "\n\t* (e) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (e) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
- Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL);
break;
default:
- Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL);
}
if (Tcl_IsShared(tmpPtr)) {
Tcl_DecrRefCount(tmpPtr);
@@ -7705,20 +8339,20 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (f) concatObj does not have refCount 0", NULL);
+ "\n\t* (f) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (f) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
- Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL);
break;
default:
- Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL);
}
if (Tcl_IsShared(tmpPtr)) {
Tcl_DecrRefCount(tmpPtr);
@@ -7736,20 +8370,20 @@ TestconcatobjCmd(
if (concatPtr->refCount != 0) {
result = TCL_ERROR;
Tcl_AppendResult(interp,
- "\n\t* (g) concatObj does not have refCount 0", NULL);
+ "\n\t* (g) concatObj does not have refCount 0", (void *)NULL);
}
if (concatPtr == tmpPtr) {
result = TCL_ERROR;
Tcl_AppendResult(interp, "\n\t* (g) concatObj is not a new obj ",
- NULL);
+ (void *)NULL);
(void) Tcl_ListObjLength(NULL, concatPtr, &len);
switch (tmpPtr->refCount) {
case 3:
- Tcl_AppendResult(interp, "(failed to concat)", NULL);
+ Tcl_AppendResult(interp, "(failed to concat)", (void *)NULL);
break;
default:
- Tcl_AppendResult(interp, "(corrupted input!)", NULL);
+ Tcl_AppendResult(interp, "(corrupted input!)", (void *)NULL);
}
Tcl_DecrRefCount(tmpPtr);
if (Tcl_IsShared(tmpPtr)) {
@@ -7783,6 +8417,72 @@ TestconcatobjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestgetencpathObjCmd --
+ *
+ * This function implements the "testgetencpath" command. It is used to
+ * test Tcl_GetEncodingSearchPath().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestgetencpathObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument strings. */
+{
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsetencpathCmd --
+ *
+ * This function implements the "testsetencpath" command. It is used to
+ * test Tcl_SetDefaultEncodingDir().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetencpathObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Argument strings. */
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "defaultDir");
+ return TCL_ERROR;
+ }
+
+ Tcl_SetEncodingSearchPath(objv[1]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
@@ -7800,13 +8500,13 @@ TestconcatobjCmd(
static int
TestparseargsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Arguments. */
{
static int foo = 0;
- int count = objc;
+ Tcl_Size count = objc;
Tcl_Obj **remObjv, *result[3];
Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
@@ -7817,8 +8517,8 @@ TestparseargsCmd(
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
- result[0] = Tcl_NewIntObj(foo);
- result[1] = Tcl_NewIntObj(count);
+ result[0] = Tcl_NewWideIntObj(foo);
+ result[1] = Tcl_NewWideIntObj(count);
result[2] = Tcl_NewListObj(count, remObjv);
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
ckfree(remObjv);
@@ -7833,8 +8533,8 @@ static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
- Tcl_Namespace *dummy,
- int flags,
+ TCL_UNUSED(Tcl_Namespace *),
+ TCL_UNUSED(int) /* flags */,
Tcl_Command *rPtr)
{
Interp *iPtr = (Interp *) interp;
@@ -7843,8 +8543,6 @@ InterpCmdResolver(
varFramePtr->procPtr : NULL;
Namespace *callerNsPtr = varFramePtr->nsPtr;
Tcl_Command resolvedCmdPtr = NULL;
- (void)dummy;
- (void)flags;
/*
* Just do something special on a cmd literal "z" in two cases:
@@ -7926,11 +8624,11 @@ InterpCmdResolver(
static int
InterpVarResolver(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *context,
- int flags,
- Tcl_Var *rPtr)
+ TCL_UNUSED(Tcl_Interp *),
+ TCL_UNUSED(const char *),
+ TCL_UNUSED(Tcl_Namespace *),
+ TCL_UNUSED(int),
+ TCL_UNUSED(Tcl_Var *))
{
/*
* Don't resolve the variable; use standard rules.
@@ -7970,7 +8668,7 @@ MyCompiledVarFree(
}
#define TclVarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
@@ -8000,7 +8698,7 @@ MyCompiledVarFetch(
}
hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
- (char *) resVarInfo->nameObj, &isNewVar);
+ (char *)resVarInfo->nameObj, &isNewVar);
if (hPtr) {
var = (Tcl_Var) TclVarHashGetValue(hPtr);
} else {
@@ -8019,10 +8717,10 @@ MyCompiledVarFetch(
static int
InterpCompiledVarResolver(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *name,
- int length,
- Tcl_Namespace *context,
+ TCL_UNUSED(Tcl_Size) /* length */,
+ TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
@@ -8041,7 +8739,7 @@ InterpCompiledVarResolver(
static int
TestInterpResolverCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -8059,7 +8757,7 @@ TestInterpResolverCmd(
if (objc == 3) {
interp = Tcl_GetChild(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
- Tcl_AppendResult(interp, "provided interpreter not found", NULL);
+ Tcl_AppendResult(interp, "provided interpreter not found", (void *)NULL);
return TCL_ERROR;
}
}
@@ -8075,7 +8773,7 @@ TestInterpResolverCmd(
case 0: /*down*/
if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
Tcl_AppendResult(interp, "could not remove the resolver scheme",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
}
@@ -8103,10 +8801,10 @@ TestInterpResolverCmd(
*------------------------------------------------------------------------
*/
int TestApplyLambdaObjCmd (
- ClientData notUsed,
+ TCL_UNUSED(void*),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ TCL_UNUSED(int), /* objc. */
+ TCL_UNUSED(Tcl_Obj *const *)) /* objv. */
{
Tcl_Obj *lambdaObjs[2];
Tcl_Obj *evalObjs[2];
@@ -8169,4 +8867,3 @@ int TestApplyLambdaObjCmd (
* indent-tabs-mode: nil
* End:
*/
-
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 914c6f0..9f31cff 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -6,59 +6,61 @@
* These commands are not normally included in Tcl applications; they're
* only used for testing.
*
- * Copyright (c) 1995-1998 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1995-1998 Sun Microsystems, Inc.
+ * Copyright © 1999 Scriptics Corporation.
+ * Copyright © 2005 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-
+#undef BUILD_tcl
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
-#include "tommath.h"
+#ifdef TCL_WITH_EXTERNAL_TOMMATH
+# include "tommath.h"
+#else
+# include "tclTomMath.h"
+#endif
#include "tclStringRep.h"
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
/*
* Forward declarations for functions defined later in this file:
*/
-static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex);
+static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, Tcl_Size varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
- const char *string, int *indexPtr);
-static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr);
-static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestbooleanobjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
+ Tcl_Obj *obj, Tcl_Size *indexPtr);
+static void SetVarToObj(Tcl_Obj **varPtr, Tcl_Size varIndex, Tcl_Obj *objPtr);
+static Tcl_ObjCmdProc TestbignumobjCmd;
+static Tcl_ObjCmdProc TestbooleanobjCmd;
+static Tcl_ObjCmdProc TestdoubleobjCmd;
+static Tcl_ObjCmdProc TestindexobjCmd;
+static Tcl_ObjCmdProc TestintobjCmd;
+static Tcl_ObjCmdProc TestlistobjCmd;
+static Tcl_ObjCmdProc TestobjCmd;
+static Tcl_ObjCmdProc TeststringobjCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
-static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp)
+static void VarPtrDeleteProc(void *clientData, TCL_UNUSED(Tcl_Interp *))
{
int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
}
- Tcl_DeleteAssocData(interp, VARPTR_KEY);
ckfree(varPtr);
}
@@ -99,7 +101,7 @@ TclObjTest_Init(
*/
Tcl_Obj **varPtr;
- varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
+ varPtr = (Tcl_Obj **)ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
if (!varPtr) {
return TCL_ERROR;
}
@@ -146,7 +148,7 @@ TclObjTest_Init(
static int
TestbignumobjCmd(
- ClientData clientData, /* unused */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
@@ -158,7 +160,8 @@ TestbignumobjCmd(
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
BIGNUM_RADIXSIZE
};
- int index, varIndex;
+ int index;
+ Tcl_Size varIndex;
const char *string;
mp_int bignumValue;
Tcl_Obj **varPtr;
@@ -171,13 +174,12 @@ TestbignumobjCmd(
&index) != TCL_OK) {
return TCL_ERROR;
}
- string = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
- switch (index) {
+ switch ((enum options)index) {
case BIGNUM_SET:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "var value");
@@ -290,9 +292,9 @@ TestbignumobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue));
+ Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue));
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue)));
+ SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue)));
}
mp_clear(&bignumValue);
break;
@@ -313,9 +315,9 @@ TestbignumobjCmd(
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], index);
+ Tcl_SetWideIntObj(varPtr[varIndex], index);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(index));
}
mp_clear(&bignumValue);
break;
@@ -345,13 +347,14 @@ TestbignumobjCmd(
static int
TestbooleanobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex, boolValue;
- const char *index, *subCmd;
+ Tcl_Size varIndex;
+ int boolValue;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -360,8 +363,7 @@ TestbooleanobjCmd(
return TCL_ERROR;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -418,7 +420,7 @@ TestbooleanobjCmd(
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, or not", NULL);
+ "\": must be set, get, or not", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -445,14 +447,14 @@ TestbooleanobjCmd(
static int
TestdoubleobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex;
+ Tcl_Size varIndex;
double doubleValue;
- const char *index, *subCmd, *string;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -463,8 +465,7 @@ TestdoubleobjCmd(
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -473,8 +474,7 @@ TestdoubleobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
+ if (Tcl_GetDouble(interp, Tcl_GetString(objv[3]), &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
@@ -537,7 +537,7 @@ TestdoubleobjCmd(
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, mult10, or div10", NULL);
+ "\": must be set, get, mult10, or div10", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -563,23 +563,24 @@ TestdoubleobjCmd(
static int
TestindexobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int allowAbbrev, index, index2, setError, i, result;
+ int allowAbbrev, index, setError, i, result;
+ Tcl_Size index2;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
+
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
- int offset; /* Offset between table entries. */
- int index; /* Selected index into table. */
- };
- struct IndexRep *indexRep;
+ Tcl_Size offset; /* Offset between table entries. */
+ Tcl_Size index; /* Selected index into table. */
+ } *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
@@ -589,17 +590,17 @@ TestindexobjCmd(
* lookups.
*/
- if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[2], TCL_INDEX_NONE, &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
+ indexRep = (struct IndexRep *)objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -616,32 +617,18 @@ TestindexobjCmd(
return TCL_ERROR;
}
- argv = ckalloc((objc-3) * sizeof(char *));
+ argv = (const char **)ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
- /*
- * Tcl_GetIndexFromObj assumes that the table is statically-allocated so
- * that its address is different for each index object. If we accidentally
- * allocate a table at the same address as that cached in the index
- * object, clear out the object's cached state.
- */
-
- if (objv[3]->typePtr != NULL
- && !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
- if (indexRep->tablePtr == (void *) argv) {
- TclFreeIntRep(objv[3]);
- }
- }
-
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
- argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
+ argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
+ &index);
ckfree(argv);
if (result == TCL_OK) {
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
@@ -666,14 +653,17 @@ TestindexobjCmd(
static int
TestintobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int intValue, varIndex, i;
- long longValue;
- const char *index, *subCmd, *string;
+ Tcl_Size varIndex;
+#if (INT_MAX != LONG_MAX) /* int is not the same size as long */
+ int i;
+#endif
+ Tcl_WideInt wideValue;
+ const char *subCmd;
Tcl_Obj **varPtr;
if (objc < 3) {
@@ -683,8 +673,7 @@ TestintobjCmd(
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -693,11 +682,9 @@ TestintobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
/*
* If the object currently bound to the variable with index varIndex
@@ -708,62 +695,58 @@ TestintobjCmd(
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
- } else if (strcmp(subCmd, "setlong") == 0) {
+ } else if (strcmp(subCmd, "setint") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
- intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], intValue);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "setmaxlong") == 0) {
- long maxLong = LONG_MAX;
+ } else if (strcmp(subCmd, "setmax") == 0) {
+ Tcl_WideInt maxWide = WIDE_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], maxLong);
+ Tcl_SetWideIntObj(varPtr[varIndex], maxWide);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide));
}
- } else if (strcmp(subCmd, "ismaxlong") == 0) {
+ } else if (strcmp(subCmd, "ismax") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ((longValue == LONG_MAX)? "1" : "0"), -1);
+ ((wideValue == WIDE_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -779,8 +762,7 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetString(varPtr[varIndex]);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
@@ -796,9 +778,9 @@ TestintobjCmd(
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
+ Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
@@ -814,14 +796,14 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
+ &wideValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue * 10);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
@@ -831,20 +813,20 @@ TestintobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
- &intValue) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex],
+ &wideValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
+ Tcl_SetWideIntObj(varPtr[varIndex], wideValue / 10);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10));
+ SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
- "\": must be set, get, get2, mult10, or div10", NULL);
+ "\": must be set, get, get2, mult10, or div10", (void *)NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -859,6 +841,35 @@ TestintobjCmd(
* test a few possible corner cases in list object manipulation from
* C code that cannot occur at the Tcl level.
*
+ * Following new commands are added for 8.7 as regression tests for
+ * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal
+ * representations for lists. It has to be ensured that corresponding
+ * implementations obey the invariants of the C list API. The script
+ * level tests do not suffice as Tcl list commands do not execute
+ * the same exact code path as the exported C API.
+ *
+ * Note these new commands are only useful when Tcl is compiled with
+ * TCL_MEM_DEBUG defined.
+ *
+ * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This
+ * is to test that abstract lists returning elements do not depend
+ * on caller to free them. The test case should check allocated counts
+ * with the following sequence:
+ * set before <get memory counts>
+ * testobj set VARINDEX [list a b c] (or lseq etc.)
+ * testlistobj indexnoop VARINDEX
+ * testobj unset VARINDEX
+ * set after <get memory counts>
+ * after calling this command AND freeing the passed list. The targeted
+ * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference
+ * resulting in a memory leak. Conversely, the command also checks
+ * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference
+ * count since it is supposed to have at least one reference held
+ * by the list implementation. Returns a message in interp otherwise.
+ *
+ * getelementsmemcheck - as above but for Tcl_ListObjGetElements
+
+ *
* Results:
* A standard Tcl object result.
*
@@ -870,37 +881,42 @@ TestintobjCmd(
static int
TestlistobjCmd(
- ClientData clientData, /* Not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
- static const char *const subcommands[] = {
+ static const char* const subcommands[] = {
"set",
"get",
- "replace"
+ "replace",
+ "indexmemcheck",
+ "getelementsmemcheck",
+ "index",
+ NULL
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
- LISTOBJ_REPLACE
- };
-
- const char* index; /* Argument giving the variable number */
- int varIndex; /* Variable number converted to binary */
- int cmdIndex; /* Ordinal number of the subcommand */
- int first; /* First index in the list */
- int count; /* Count of elements in a list */
+ LISTOBJ_REPLACE,
+ LISTOBJ_INDEXMEMCHECK,
+ LISTOBJ_GETELEMENTSMEMCHECK,
+ LISTOBJ_INDEX,
+ } cmdIndex;
+
+ Tcl_Size varIndex; /* Variable number converted to binary */
+ Tcl_Size first; /* First index in the list */
+ Tcl_Size count; /* Count of elements in a list */
Tcl_Obj **varPtr;
+ Tcl_Size i, len;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
@@ -934,8 +950,8 @@ TestlistobjCmd(
"varIndex start count ?element...?");
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK
+ || Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
@@ -944,6 +960,76 @@ TestlistobjCmd(
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
+
+ case LISTOBJ_INDEXMEMCHECK:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < len; ++i) {
+ Tcl_Obj *objP;
+ if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objP->refCount <= 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Tcl_ListObjIndex returned object with ref count <= 0",
+ TCL_INDEX_NONE));
+ /* Keep looping since we are also looping for leaks */
+ }
+ }
+ break;
+
+ case LISTOBJ_GETELEMENTSMEMCHECK:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **elems;
+ if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < len; ++i) {
+ if (elems[i]->refCount <= 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "Tcl_ListObjGetElements element has ref count <= 0",
+ TCL_INDEX_NONE));
+ break;
+ }
+ }
+ }
+ break;
+ case LISTOBJ_INDEX:
+ /*
+ * Tcl_ListObjIndex semantics differ from lindex for out of bounds.
+ * Hence this explicit test.
+ */
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "varIndex listIndex");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK) {
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj *objP;
+ if (Tcl_ListObjIndex(interp, varPtr[varIndex], first, &objP) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objP ? objP : Tcl_NewStringObj("null", -1));
+ }
+ break;
}
return TCL_OK;
}
@@ -967,15 +1053,28 @@ TestlistobjCmd(
static int
TestobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int varIndex, destIndex, i;
- const char *index, *subCmd, *string;
+ Tcl_Size varIndex, destIndex;
+ int i;
const Tcl_ObjType *targetType;
Tcl_Obj **varPtr;
+ static const char *const subcommands[] = {
+ "freeallvars", "bug3598580",
+ "types", "objtype", "newobj", "set",
+ "assign", "convert", "duplicate",
+ "invalidateStringRep", "refcount", "type",
+ NULL
+ };
+ enum testobjCmdIndex {
+ TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580,
+ TESTOBJ_TYPES, TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET,
+ TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE,
+ TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE,
+ } cmdIndex;
if (objc < 2) {
wrongNumArgs:
@@ -984,170 +1083,174 @@ TestobjCmd(
}
varPtr = GetVarPtr(interp);
- subCmd = Tcl_GetString(objv[1]);
- if (strcmp(subCmd, "assign") == 0) {
- if (objc != 4) {
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case TESTOBJ_FREEALLVARS:
+ if (objc != 2) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
+ for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
+ if (varPtr[i] != NULL) {
+ Tcl_DecrRefCount(varPtr[i]);
+ varPtr[i] = NULL;
+ }
}
- string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_OK;
+ case TESTOBJ_BUG3598580:
+ if (objc != 2) {
+ goto wrongNumArgs;
+ } else {
+ Tcl_Obj *listObjPtr, *elemObjPtr;
+ elemObjPtr = Tcl_NewWideIntObj(123);
+ listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
+ /* Replace the single list element through itself, nonsense but
+ * legal. */
+ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
+ Tcl_SetObjResult(interp, listObjPtr);
}
- SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
- Tcl_SetObjResult(interp, varPtr[destIndex]);
- } else if (strcmp(subCmd, "bug3598580") == 0) {
- Tcl_Obj *listObjPtr, *elemObjPtr;
+ return TCL_OK;
+ case TESTOBJ_TYPES:
if (objc != 2) {
goto wrongNumArgs;
+ } else {
+ Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL);
+ Tcl_AppendAllObjTypes(interp, typesObj);
+ Tcl_SetObjResult(interp, typesObj);
}
- elemObjPtr = Tcl_NewIntObj(123);
- listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
- /* Replace the single list element through itself, nonsense but legal. */
- Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
- Tcl_SetObjResult(interp, listObjPtr);
return TCL_OK;
- } else if (strcmp(subCmd, "convert") == 0) {
- const char *typeName;
+ case TESTOBJ_OBJTYPE:
+ /*
+ * Return an object containing the name of the argument's type of
+ * internal rep. If none exists, return "none".
+ */
- if (objc != 4) {
+ if (objc != 3) {
goto wrongNumArgs;
+ } else {
+ const char *typeName;
+
+ if (objv[2]->typePtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
+ } else {
+ typeName = objv[2]->typePtr->name;
+ if (!strcmp(typeName, "utf32string"))
+ typeName = "string";
+#ifndef TCL_WIDE_INT_IS_LONG
+ else if (!strcmp(typeName, "wideInt")) typeName = "int";
+#endif
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
+ }
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
- typeName = Tcl_GetString(objv[3]);
- if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no type ", typeName, " found", NULL);
- return TCL_ERROR;
+ return TCL_OK;
+ case TESTOBJ_NEWOBJ:
+ if (objc != 3) {
+ goto wrongNumArgs;
}
- if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
- != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
+ SetVarToObj(varPtr, varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "duplicate") == 0) {
+ return TCL_OK;
+ case TESTOBJ_SET:
if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
+ SetVarToObj(varPtr, varIndex, objv[3]);
+ return TCL_OK;
+
+ default:
+ break;
+ }
+
+ /* All further commands expect an occupied varindex argument */
+ if (objc < 3) {
+ goto wrongNumArgs;
+ }
+
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr, varIndex)) {
+ return TCL_ERROR;
+ }
+
+ switch (cmdIndex) {
+ case TESTOBJ_ASSIGN:
+ if (objc != 4) {
+ goto wrongNumArgs;
}
- string = Tcl_GetString(objv[3]);
- if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
- } else if (strcmp(subCmd, "freeallvars") == 0) {
- if (objc != 2) {
- goto wrongNumArgs;
- }
- for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
- if (varPtr[i] != NULL) {
- Tcl_DecrRefCount(varPtr[i]);
- varPtr[i] = NULL;
- }
- }
- } else if (strcmp(subCmd, "invalidateStringRep") == 0) {
- if (objc != 3) {
+ break;
+ case TESTOBJ_CONVERT:
+ if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "no type ", Tcl_GetString(objv[3]), " found", (void *)NULL);
return TCL_ERROR;
}
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
+ != TCL_OK) {
return TCL_ERROR;
}
- Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "newobj") == 0) {
- if (objc != 3) {
+ break;
+ case TESTOBJ_DUPLICATE:
+ if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) {
return TCL_ERROR;
}
- SetVarToObj(varPtr, varIndex, Tcl_NewObj());
- Tcl_SetObjResult(interp, varPtr[varIndex]);
- } else if (strcmp(subCmd, "objtype") == 0) {
- const char *typeName;
-
- /*
- * Return an object containing the name of the argument's type of
- * internal rep. If none exists, return "none".
- */
-
+ SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+ Tcl_SetObjResult(interp, varPtr[destIndex]);
+ break;
+ case TESTOBJ_INVALIDATESTRINGREP:
if (objc != 3) {
goto wrongNumArgs;
}
- if (objv[2]->typePtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
- } else {
- typeName = objv[2]->typePtr->name;
- Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
- }
- } else if (strcmp(subCmd, "refcount") == 0) {
+ Tcl_InvalidateStringRep(varPtr[varIndex]);
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ break;
+ case TESTOBJ_REFCOUNT:
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
- } else if (strcmp(subCmd, "type") == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
+ break;
+ case TESTOBJ_TYPE:
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (CheckIfVarUnset(interp, varPtr,varIndex)) {
- return TCL_ERROR;
- }
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "int", -1);
+#endif
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
- } else if (strcmp(subCmd, "types") == 0) {
- if (objc != 2) {
- goto wrongNumArgs;
- }
- if (Tcl_AppendAllObjTypes(interp,
- Tcl_GetObjResult(interp)) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetString(objv[1]),
- "\": must be assign, convert, duplicate, freeallvars, "
- "newobj, objcount, objtype, refcount, type, or types", NULL);
- return TCL_ERROR;
+ break;
+ default:
+ break;
}
+
return TCL_OK;
}
@@ -1171,21 +1274,23 @@ TestobjCmd(
static int
TeststringobjCmd(
- ClientData clientData, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *unicode;
- int varIndex, option, i, length;
+ unsigned short *unicode;
+ Tcl_Size size, varIndex;
+ int option, i;
+ Tcl_Size length;
#define MAX_STRINGS 11
- const char *index, *string, *strings[MAX_STRINGS+1];
+ 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", "getunicode",
- "appendself", "appendself2", NULL
+ "set", "set2", "setlength", "maxchars", "range", "appendself",
+ "appendself2", "newunicode", NULL
};
if (objc < 3) {
@@ -1195,8 +1300,7 @@ TeststringobjCmd(
}
varPtr = GetVarPtr(interp);
- index = Tcl_GetString(objv[2]);
- if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
+ if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -1209,7 +1313,7 @@ TeststringobjCmd(
if (objc != 5) {
goto wrongNumArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
@@ -1224,8 +1328,7 @@ TeststringobjCmd(
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetString(objv[3]);
- Tcl_AppendToObj(varPtr[varIndex], string, length);
+ Tcl_AppendToObj(varPtr[varIndex], Tcl_GetString(objv[3]), length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
@@ -1253,7 +1356,7 @@ TeststringobjCmd(
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
- strings[10], strings[11]);
+ strings[10], strings[11], (void *)NULL);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
@@ -1272,14 +1375,13 @@ TeststringobjCmd(
if (CheckIfVarUnset(interp, varPtr, varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetString(varPtr[varIndex]);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
@@ -1287,14 +1389,18 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = (int) strPtr->allocated;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex], objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = (int) strPtr->allocated;
+ } else {
+ length = TCL_INDEX_NONE;
+ }
} else {
- length = -1;
+ length = TCL_INDEX_NONE;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
@@ -1310,12 +1416,12 @@ TeststringobjCmd(
* is "copy on write".
*/
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetStringFromObj(objv[3], &size);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetStringObj(varPtr[varIndex], string, length);
+ Tcl_SetStringObj(varPtr[varIndex], string, size);
} else {
- SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length));
+ SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, size));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
@@ -1329,7 +1435,7 @@ TeststringobjCmd(
if (objc != 4) {
goto wrongNumArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
@@ -1341,34 +1447,32 @@ TeststringobjCmd(
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
- Tcl_ConvertToType(NULL, varPtr[varIndex],
- Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
- length = strPtr->maxChars;
+ const Tcl_ObjType *objType = Tcl_GetObjType("string");
+ if (objType != NULL) {
+ Tcl_ConvertToType(NULL, varPtr[varIndex],objType);
+ strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
+ length = strPtr->maxChars;
+ } else {
+ length = TCL_INDEX_NONE;
+ }
} else {
- length = -1;
+ length = TCL_INDEX_NONE;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: { /* range */
- int first, last;
+ Tcl_Size first, last;
if (objc != 5) {
goto wrongNumArgs;
}
- if ((Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK)
- || (Tcl_GetIntFromObj(interp, objv[4], &last) != TCL_OK)) {
+ if ((Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK)
+ || (Tcl_GetIntForIndex(interp, objv[4], TCL_INDEX_NONE, &last) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last));
break;
}
- case 11: /* getunicode */
- if (objc != 3) {
- goto wrongNumArgs;
- }
- Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
- break;
- case 12: /* appendself */
+ case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1385,21 +1489,21 @@ TeststringobjCmd(
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
+ string = Tcl_GetStringFromObj(varPtr[varIndex], &size);
- if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
return TCL_ERROR;
}
- if ((i < 0) || (i > length)) {
+ if (length == TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
+ Tcl_AppendToObj(varPtr[varIndex], string + length, size - length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 13: /* appendself2 */
+ case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1416,20 +1520,37 @@ TeststringobjCmd(
SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
+ unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size);
- if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[3], size-1, &length) != TCL_OK) {
return TCL_ERROR;
}
- if ((i < 0) || (i > length)) {
+ if (length == TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
- Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
+ Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
+ case 13: /* newunicode*/
+ unicode = (unsigned short *)ckalloc(((unsigned)objc - 3) * sizeof(unsigned short));
+ for (i = 0; i < (objc - 3); ++i) {
+ int val;
+ if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) {
+ break;
+ }
+ unicode[i] = (unsigned short)val;
+ }
+ if (i < (objc-3)) {
+ ckfree(unicode);
+ return TCL_ERROR;
+ }
+ SetVarToObj(varPtr, varIndex, Tcl_NewUnicodeObj(unicode, objc - 3));
+ Tcl_SetObjResult(interp, varPtr[varIndex]);
+ ckfree(unicode);
+ break;
}
return TCL_OK;
@@ -1457,7 +1578,7 @@ TeststringobjCmd(
static void
SetVarToObj(
Tcl_Obj **varPtr,
- int varIndex, /* Designates the assignment variable. */
+ Tcl_Size varIndex, /* Designates the assignment variable. */
Tcl_Obj *objPtr) /* Points to object to assign to var. */
{
if (varPtr[varIndex] != NULL) {
@@ -1488,17 +1609,17 @@ SetVarToObj(
static int
GetVariableIndex(
Tcl_Interp *interp, /* Interpreter for error reporting. */
- const char *string, /* String containing a variable index
+ Tcl_Obj *obj, /* The variable index
* specified as a nonnegative number less than
* NUMBER_OF_OBJECT_VARS. */
- int *indexPtr) /* Place to store converted result. */
+ Tcl_Size *indexPtr) /* Place to store converted result. */
{
- int index;
+ Tcl_Size index;
- if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, obj, NUMBER_OF_OBJECT_VARS - 1, &index) != TCL_OK) {
return TCL_ERROR;
}
- if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
+ if (index == TCL_INDEX_NONE) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
return TCL_ERROR;
@@ -1530,12 +1651,12 @@ static int
CheckIfVarUnset(
Tcl_Interp *interp, /* Interpreter for error reporting. */
Tcl_Obj ** varPtr,
- int varIndex) /* Index of the test variable to check. */
+ Tcl_Size varIndex) /* Index of the test variable to check. */
{
- if (varPtr[varIndex] == NULL) {
+ if (varIndex < 0 || varPtr[varIndex] == NULL) {
char buf[32 + TCL_INTEGER_SPACE];
- snprintf(buf, sizeof(buf), "variable %d is unset (NULL)", varIndex);
+ snprintf(buf, sizeof(buf), "variable %" TCL_SIZE_MODIFIER "d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
return 1;
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 45dea21..2139b81 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -5,7 +5,7 @@
* creation of Tcl procedures whose body argument is a Tcl_Obj of type
* "procbody" rather than a string.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -20,7 +20,7 @@
* name and version of this package
*/
-static const char packageName[] = "procbodytest";
+static const char packageName[] = "tcl::procbodytest";
static const char packageVersion[] = "1.1";
/*
@@ -35,7 +35,7 @@ static const char checkCommand[] = "check";
* procs
*/
-typedef struct CmdTable {
+typedef struct {
const char *cmdName; /* command name */
Tcl_ObjCmdProc *proc; /* command proc */
int exportIt; /* if 1, export the command */
@@ -45,13 +45,11 @@ typedef struct CmdTable {
* Declarations for functions defined in this file.
*/
-static int ProcBodyTestProcObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
-static int ProcBodyTestCheckObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ProcBodyTestProcObjCmd;
+static Tcl_ObjCmdProc ProcBodyTestCheckObjCmd;
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
- const char *namespace, const CmdTable *cmdTablePtr);
+ const char *namesp, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
@@ -75,7 +73,7 @@ static const CmdTable safeCommands[] = {
*
* Procbodytest_Init --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "tcl::procbodytest" package.
*
* Results:
* A standard Tcl result.
@@ -99,7 +97,7 @@ Procbodytest_Init(
*
* Procbodytest_SafeInit --
*
- * This function initializes the "procbodytest" package.
+ * This function initializes the "tcl::procbodytest" package.
*
* Results:
* A standard Tcl result.
@@ -139,7 +137,7 @@ static int
RegisterCommand(
Tcl_Interp* interp, /* the Tcl interpreter for which the operation
* is performed */
- const char *namespace, /* the namespace in which the command is
+ const char *namesp, /* the namespace in which the command is
* registered */
const CmdTable *cmdTablePtr)/* the command to register */
{
@@ -147,13 +145,13 @@ RegisterCommand(
if (cmdTablePtr->exportIt) {
snprintf(buf, sizeof(buf), "namespace eval %s { namespace export %s }",
- namespace, cmdTablePtr->cmdName);
+ namesp, cmdTablePtr->cmdName);
if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
}
- snprintf(buf, sizeof(buf), "%s::%s", namespace, cmdTablePtr->cmdName);
+ snprintf(buf, sizeof(buf), "%s::%s", namesp, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
return TCL_OK;
}
@@ -190,7 +188,7 @@ ProcBodyTestInitInternal(
}
}
- return Tcl_PkgProvide(interp, packageName, packageVersion);
+ return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL);
}
/*
@@ -228,7 +226,7 @@ ProcBodyTestInitInternal(
static int
ProcBodyTestProcObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
@@ -265,7 +263,7 @@ ProcBodyTestProcObjCmd(
if (cmdPtr->objClientData != TclIsProc(cmdPtr)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "command \"", fullName, "\" is not a Tcl procedure", NULL);
+ "command \"", fullName, "\" is not a Tcl procedure", (void *)NULL);
return TCL_ERROR;
}
@@ -276,7 +274,7 @@ ProcBodyTestProcObjCmd(
procPtr = (Proc *) cmdPtr->objClientData;
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "procedure \"",
- fullName, "\" does not have a Proc struct!", NULL);
+ fullName, "\" does not have a Proc struct!", (void *)NULL);
return TCL_ERROR;
}
@@ -288,7 +286,7 @@ ProcBodyTestProcObjCmd(
if (bodyObjPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"failed to create a procbody object for procedure \"",
- fullName, "\"", NULL);
+ fullName, "\"", (void *)NULL);
return TCL_ERROR;
}
Tcl_IncrRefCount(bodyObjPtr);
@@ -315,7 +313,7 @@ ProcBodyTestProcObjCmd(
* procbodytest::check
*
* Performs an internal check that the Tcl_PkgPresent() command returns
- * the same version number as was registered when the procbodytest package
+ * the same version number as was registered when the tcl::procbodytest package
* was provided. Places a boolean in the interp result indicating the
* test outcome.
*
@@ -327,7 +325,7 @@ ProcBodyTestProcObjCmd(
static int
ProcBodyTestCheckObjCmd(
- ClientData dummy, /* context; not used */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
@@ -339,7 +337,7 @@ ProcBodyTestCheckObjCmd(
return TCL_ERROR;
}
- version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
+ version = Tcl_PkgPresentEx(interp, packageName, packageVersion, 1, NULL);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
strcmp(version, packageVersion) == 0));
return TCL_OK;
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 03937de..de9fac9 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -4,8 +4,8 @@
* This file implements Platform independent thread operations. Most of
* the real work is done in the platform dependent files.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 2008 by George Peter Staplin
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 2008 George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -41,21 +41,6 @@ static void RememberSyncObject(void *objPtr,
SyncObjRecord *recPtr);
/*
- * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not
- * specified. Here we undo that so the functions are defined in the stubs
- * table.
- */
-
-#ifndef TCL_THREADS
-#undef Tcl_MutexLock
-#undef Tcl_MutexUnlock
-#undef Tcl_MutexFinalize
-#undef Tcl_ConditionNotify
-#undef Tcl_ConditionWait
-#undef Tcl_ConditionFinalize
-#endif
-
-/*
*----------------------------------------------------------------------
*
* Tcl_GetThreadData --
@@ -79,7 +64,7 @@ Tcl_GetThreadData(
int size) /* Size of storage block */
{
void *result;
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Initialize the key for this thread.
*/
@@ -95,7 +80,7 @@ Tcl_GetThreadData(
if (*keyPtr == NULL) {
result = ckalloc(size);
memset(result, 0, size);
- *keyPtr = result;
+ *keyPtr = (Tcl_ThreadDataKey)result;
RememberSyncObject(keyPtr, &keyRecord);
} else {
result = *keyPtr;
@@ -126,7 +111,7 @@ TclThreadDataKeyGet(
Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
return TclThreadStorageKeyGet(keyPtr);
#else /* TCL_THREADS */
return *keyPtr;
@@ -179,7 +164,7 @@ RememberSyncObject(
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
- newList = ckalloc(recPtr->max * sizeof(void *));
+ newList = (void **)ckalloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
@@ -269,11 +254,12 @@ TclRememberMutex(
*----------------------------------------------------------------------
*/
+#undef Tcl_MutexFinalize
void
Tcl_MutexFinalize(
Tcl_Mutex *mutexPtr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
TclpFinalizeMutex(mutexPtr);
#endif
TclpGlobalLock();
@@ -322,11 +308,12 @@ TclRememberCondition(
*----------------------------------------------------------------------
*/
+#undef Tcl_ConditionFinalize
void
Tcl_ConditionFinalize(
Tcl_Condition *condPtr)
{
-#ifdef TCL_THREADS
+#if TCL_THREADS
TclpFinalizeCondition(condPtr);
#endif
TclpGlobalLock();
@@ -356,13 +343,15 @@ void
TclFinalizeThreadData(int quick)
{
TclFinalizeThreadDataThread();
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
+#else
+ (void)quick;
#endif
}
@@ -389,7 +378,7 @@ TclFinalizeSynchronization(void)
int i;
void *blockPtr;
Tcl_ThreadDataKey *keyPtr;
-#ifdef TCL_THREADS
+#if TCL_THREADS
Tcl_Mutex *mutexPtr;
Tcl_Condition *condPtr;
@@ -413,7 +402,7 @@ TclFinalizeSynchronization(void)
keyRecord.max = 0;
keyRecord.num = 0;
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Call thread storage global cleanup.
*/
@@ -473,12 +462,10 @@ Tcl_ExitThread(
int status)
{
Tcl_FinalizeThread();
-#ifdef TCL_THREADS
TclpThreadExit(status);
-#endif
}
-#ifndef TCL_THREADS
+#if !TCL_THREADS
/*
*----------------------------------------------------------------------
@@ -501,30 +488,30 @@ Tcl_ExitThread(
#undef Tcl_ConditionWait
void
Tcl_ConditionWait(
- Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */
- Tcl_Mutex *mutexPtr, /* Really (pthread_mutex_t **) */
- const Tcl_Time *timePtr) /* Timeout on waiting period */
+ TCL_UNUSED(Tcl_Condition *), /* Really (pthread_cond_t **) */
+ TCL_UNUSED(Tcl_Mutex *), /* Really (pthread_mutex_t **) */
+ TCL_UNUSED(const Tcl_Time *)) /* Timeout on waiting period */
{
}
#undef Tcl_ConditionNotify
void
Tcl_ConditionNotify(
- Tcl_Condition *condPtr)
+ TCL_UNUSED(Tcl_Condition *))
{
}
#undef Tcl_MutexLock
void
Tcl_MutexLock(
- Tcl_Mutex *mutexPtr)
+ TCL_UNUSED(Tcl_Mutex *))
{
}
#undef Tcl_MutexUnlock
void
Tcl_MutexUnlock(
- Tcl_Mutex *mutexPtr)
+ TCL_UNUSED(Tcl_Mutex *))
{
}
#endif /* !TCL_THREADS */
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 1bcd404..df4d2e3 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -6,14 +6,14 @@
* fixed size blocks from block caches.
*
* The Initial Developer of the Original Code is America Online, Inc.
- * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
+ * Portions created by AOL are Copyright © 1999 America Online, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+#if TCL_THREADS && defined(USE_THREAD_ALLOC)
/*
* If range checking is enabled, an additional byte will be allocated to store
@@ -82,18 +82,17 @@ typedef union Block {
* and statistics information.
*/
-typedef struct Bucket {
+typedef struct {
Block *firstPtr; /* First block available */
Block *lastPtr; /* End of block list */
- long numFree; /* Number of blocks available */
+ size_t numFree; /* Number of blocks available */
/* All fields below for accounting only */
- long numRemoves; /* Number of removes from bucket */
- long numInserts; /* Number of inserts into bucket */
- long numWaits; /* Number of waits to acquire a lock */
- long numLocks; /* Number of locks acquired */
- long totalAssigned; /* Total space assigned to bucket */
+ size_t numRemoves; /* Number of removes from bucket */
+ size_t numInserts; /* Number of inserts into bucket */
+ size_t numLocks; /* Number of locks acquired */
+ size_t totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
@@ -107,9 +106,9 @@ typedef struct Cache {
struct Cache *nextPtr; /* Linked list of cache entries */
Tcl_ThreadId owner; /* Which thread's cache is this? */
Tcl_Obj *firstObjPtr; /* List of free objects for thread */
- int numObjects; /* Number of objects for thread */
+ size_t numObjects; /* Number of objects for thread */
Tcl_Obj *lastPtr; /* Last object in this cache */
- int totalAssigned; /* Total space assigned to thread */
+ size_t totalAssigned; /* Total space assigned to thread */
Bucket buckets[NBUCKETS]; /* The buckets for this thread */
} Cache;
@@ -120,8 +119,8 @@ typedef struct Cache {
static struct {
size_t blockSize; /* Bucket blocksize. */
- int maxBlocks; /* Max blocks before move to share. */
- int numMove; /* Num blocks to move to share. */
+ size_t maxBlocks; /* Max blocks before move to share. */
+ size_t numMove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS];
@@ -132,12 +131,12 @@ static struct {
static Cache * GetCache(void);
static void LockBucket(Cache *cachePtr, int bucket);
static void UnlockBucket(Cache *cachePtr, int bucket);
-static void PutBlocks(Cache *cachePtr, int bucket, int numMove);
+static void PutBlocks(Cache *cachePtr, int bucket, size_t numMove);
static int GetBlocks(Cache *cachePtr, int bucket);
-static Block * Ptr2Block(char *ptr);
-static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
-static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);
-static void PutObjs(Cache *fromPtr, int numMove);
+static Block * Ptr2Block(void *ptr);
+static void * Block2Ptr(Block *blockPtr, int bucket, size_t reqSize);
+static void MoveObjs(Cache *fromPtr, Cache *toPtr, size_t numMove);
+static void PutObjs(Cache *fromPtr, size_t numMove);
/*
* Local variables defined in this file and initialized at startup.
@@ -162,7 +161,7 @@ static __thread Cache *tcachePtr;
#else
# define GETCACHE(cachePtr) \
do { \
- (cachePtr) = TclpGetAllocCache(); \
+ (cachePtr) = (Cache*)TclpGetAllocCache(); \
if ((cachePtr) == NULL) { \
(cachePtr) = GetCache(); \
} \
@@ -196,20 +195,11 @@ GetCache(void)
if (listLockPtr == NULL) {
Tcl_Mutex *initLockPtr;
- unsigned int i;
initLockPtr = Tcl_GetAllocMutex();
Tcl_MutexLock(initLockPtr);
if (listLockPtr == NULL) {
- listLockPtr = TclpNewAllocMutex();
- objLockPtr = TclpNewAllocMutex();
- for (i = 0; i < NBUCKETS; ++i) {
- bucketInfo[i].blockSize = MINALLOC << i;
- bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
- bucketInfo[i].numMove = i < NBUCKETS - 1 ?
- 1 << (NBUCKETS - 2 - i) : 1;
- bucketInfo[i].lockPtr = TclpNewAllocMutex();
- }
+ TclInitThreadAlloc();
}
Tcl_MutexUnlock(initLockPtr);
}
@@ -218,9 +208,9 @@ GetCache(void)
* Get this thread's cache, allocating if necessary.
*/
- cachePtr = TclpGetAllocCache();
+ cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
- cachePtr = TclpSysAlloc(sizeof(Cache), 0);
+ cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0);
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
@@ -255,7 +245,7 @@ void
TclFreeAllocCache(
void *arg)
{
- Cache *cachePtr = arg;
+ Cache *cachePtr = (Cache*)arg;
Cache **nextPtrPtr;
unsigned int bucket;
@@ -308,7 +298,7 @@ TclFreeAllocCache(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpAlloc(
unsigned int reqSize)
{
@@ -346,7 +336,7 @@ TclpAlloc(
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
- blockPtr = TclpSysAlloc(size, 0);
+ blockPtr = (Block *)TclpSysAlloc(size, 0);
if (blockPtr != NULL) {
cachePtr->totalAssigned += reqSize;
}
@@ -387,7 +377,7 @@ TclpAlloc(
void
TclpFree(
- char *ptr)
+ void *ptr)
{
Cache *cachePtr;
Block *blockPtr;
@@ -444,9 +434,9 @@ TclpFree(
*----------------------------------------------------------------------
*/
-char *
+void *
TclpRealloc(
- char *ptr,
+ void *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
@@ -500,7 +490,7 @@ TclpRealloc(
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
- blockPtr = TclpSysRealloc(blockPtr, size);
+ blockPtr = (Block*)TclpSysRealloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
@@ -557,7 +547,7 @@ TclThreadAllocObj(void)
*/
if (cachePtr->numObjects == 0) {
- int numMove;
+ size_t numMove;
Tcl_MutexLock(objLockPtr);
numMove = sharedPtr->numObjects;
@@ -572,13 +562,13 @@ TclThreadAllocObj(void)
Tcl_Obj *newObjsPtr;
cachePtr->numObjects = numMove = NOBJALLOC;
- newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
+ newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
if (newObjsPtr == NULL) {
- Tcl_Panic("alloc: could not allocate %d new objects", numMove);
+ Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove);
}
cachePtr->lastPtr = newObjsPtr + numMove - 1;
objPtr = cachePtr->firstObjPtr; /* NULL */
- while (--numMove >= 0) {
+ while (numMove-- > 0) {
newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr;
objPtr = newObjsPtr + numMove;
}
@@ -591,7 +581,7 @@ TclThreadAllocObj(void)
*/
objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
@@ -680,14 +670,14 @@ Tcl_GetMemoryInfo(
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
- snprintf(buf, sizeof(buf), "%lu %ld %ld %ld %ld %ld %ld",
- (unsigned long) bucketInfo[n].blockSize,
+ snprintf(buf, sizeof(buf), "%" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %"
+ TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u %" TCL_Z_MODIFIER "u",
+ bucketInfo[n].blockSize,
cachePtr->buckets[n].numFree,
cachePtr->buckets[n].numRemoves,
cachePtr->buckets[n].numInserts,
cachePtr->buckets[n].totalAssigned,
- cachePtr->buckets[n].numLocks,
- cachePtr->buckets[n].numWaits);
+ cachePtr->buckets[n].numLocks);
Tcl_DStringAppendElement(dsPtr, buf);
}
Tcl_DStringEndSublist(dsPtr);
@@ -716,7 +706,7 @@ static void
MoveObjs(
Cache *fromPtr,
Cache *toPtr,
- int numMove)
+ size_t numMove)
{
Tcl_Obj *objPtr = fromPtr->firstObjPtr;
Tcl_Obj *fromFirstObjPtr = objPtr;
@@ -729,10 +719,10 @@ MoveObjs(
* to be moved) as the first object in the 'from' cache.
*/
- while (--numMove) {
- objPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ while (numMove-- > 1) {
+ objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
}
- fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
@@ -763,9 +753,9 @@ MoveObjs(
static void
PutObjs(
Cache *fromPtr,
- int numMove)
+ size_t numMove)
{
- int keep = fromPtr->numObjects - numMove;
+ size_t keep = fromPtr->numObjects - numMove;
Tcl_Obj *firstPtr, *lastPtr = NULL;
fromPtr->numObjects = keep;
@@ -775,8 +765,8 @@ PutObjs(
} else {
do {
lastPtr = firstPtr;
- firstPtr = firstPtr->internalRep.twoPtrValue.ptr1;
- } while (--keep > 0);
+ firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1;
+ } while (keep-- > 1);
lastPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
@@ -813,11 +803,11 @@ PutObjs(
*----------------------------------------------------------------------
*/
-static char *
+static void *
Block2Ptr(
Block *blockPtr,
int bucket,
- unsigned int reqSize)
+ size_t reqSize)
{
void *ptr;
@@ -828,12 +818,12 @@ Block2Ptr(
#if RCHECK
((unsigned char *)(ptr))[reqSize] = MAGIC;
#endif
- return (char *) ptr;
+ return ptr;
}
static Block *
Ptr2Block(
- char *ptr)
+ void *ptr)
{
Block *blockPtr;
@@ -881,7 +871,7 @@ LockBucket(
static void
UnlockBucket(
- Cache *cachePtr,
+ TCL_UNUSED(Cache *),
int bucket)
{
Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
@@ -907,14 +897,14 @@ static void
PutBlocks(
Cache *cachePtr,
int bucket,
- int numMove)
+ size_t numMove)
{
/*
* We have numFree. Want to shed numMove. So compute how many
* Blocks to keep.
*/
- int keep = cachePtr->buckets[bucket].numFree - numMove;
+ size_t keep = cachePtr->buckets[bucket].numFree - numMove;
Block *lastPtr = NULL, *firstPtr;
cachePtr->buckets[bucket].numFree = keep;
@@ -925,7 +915,7 @@ PutBlocks(
do {
lastPtr = firstPtr;
firstPtr = firstPtr->nextBlock;
- } while (--keep > 0);
+ } while (keep-- > 1);
lastPtr->nextBlock = NULL;
}
@@ -970,7 +960,7 @@ GetBlocks(
int bucket)
{
Block *blockPtr;
- int n;
+ size_t n;
/*
* First, attempt to move blocks from the shared cache. Note the
@@ -1003,7 +993,7 @@ GetBlocks(
cachePtr->buckets[bucket].firstPtr = blockPtr;
sharedPtr->buckets[bucket].numFree -= n;
cachePtr->buckets[bucket].numFree = n;
- while (--n > 0) {
+ while (n-- > 1) {
blockPtr = blockPtr->nextBlock;
}
sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
@@ -1024,8 +1014,8 @@ GetBlocks(
blockPtr = NULL;
n = NBUCKETS;
- size = 0; /* lint */
- while (--n > bucket) {
+ size = 0;
+ while (n-- > (size_t)bucket + 1) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
@@ -1041,7 +1031,7 @@ GetBlocks(
if (blockPtr == NULL) {
size = MAXALLOC;
- blockPtr = TclpSysAlloc(size, 0);
+ blockPtr = (Block*)TclpSysAlloc(size, 0);
if (blockPtr == NULL) {
return 0;
}
@@ -1054,7 +1044,7 @@ GetBlocks(
n = size / bucketInfo[bucket].blockSize;
cachePtr->buckets[bucket].numFree = n;
cachePtr->buckets[bucket].firstPtr = blockPtr;
- while (--n > 0) {
+ while (n-- > 1) {
blockPtr->nextBlock = (Block *)
((char *) blockPtr + bucketInfo[bucket].blockSize);
blockPtr = blockPtr->nextBlock;
@@ -1064,6 +1054,40 @@ GetBlocks(
}
return 1;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitThreadAlloc --
+ *
+ * Initializes the allocator cache-maintenance structures.
+ * It is done early and protected during the Tcl_InitSubsystems().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitThreadAlloc(void)
+{
+ unsigned int i;
+
+ listLockPtr = TclpNewAllocMutex();
+ objLockPtr = TclpNewAllocMutex();
+ for (i = 0; i < NBUCKETS; ++i) {
+ bucketInfo[i].blockSize = MINALLOC << i;
+ bucketInfo[i].maxBlocks = ((size_t)1) << (NBUCKETS - 1 - i);
+ bucketInfo[i].numMove = i < NBUCKETS - 1 ?
+ (size_t)1 << (NBUCKETS - 2 - i) : 1;
+ bucketInfo[i].lockPtr = TclpNewAllocMutex();
+ }
+ TclpInitAllocCache();
+}
/*
*----------------------------------------------------------------------
@@ -1122,7 +1146,7 @@ TclFinalizeThreadAlloc(void)
void
TclFinalizeThreadAllocThread(void)
{
- Cache *cachePtr = TclpGetAllocCache();
+ Cache *cachePtr = (Cache *)TclpGetAllocCache();
if (cachePtr != NULL) {
TclpFreeAllocCache(cachePtr);
}
@@ -1147,7 +1171,7 @@ TclFinalizeThreadAllocThread(void)
void
Tcl_GetMemoryInfo(
- Tcl_DString *dsPtr)
+ TCL_UNUSED(Tcl_DString *))
{
Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
}
diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c
index 5c4d969..af4bc13 100644
--- a/generic/tclThreadJoin.c
+++ b/generic/tclThreadJoin.c
@@ -6,7 +6,7 @@
* provide the functionality of joining threads. This code is currently
* not necessary on Unix.
*
- * Copyright (c) 2000 Scriptics Corporation
+ * Copyright © 2000 Scriptics Corporation
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c
index ad8c50f..b2de9b4 100644
--- a/generic/tclThreadStorage.c
+++ b/generic/tclThreadStorage.c
@@ -4,8 +4,8 @@
* This file implements platform independent thread storage operations to
* work around system limits on the number of thread-specific variables.
*
- * Copyright (c) 2003-2004 by Joe Mistachkin
- * Copyright (c) 2008 by George Peter Staplin
+ * Copyright © 2003-2004 Joe Mistachkin
+ * Copyright © 2008 George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -13,7 +13,7 @@
#include "tclInt.h"
-#ifdef TCL_THREADS
+#if TCL_THREADS
#include <signal.h>
/*
@@ -85,14 +85,14 @@ TSDTableCreate(void)
TSDTable *tsdTablePtr;
sig_atomic_t i;
- tsdTablePtr = TclpSysAlloc(sizeof(TSDTable), 0);
+ tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0);
if (tsdTablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
tsdTablePtr->allocated = 8;
tsdTablePtr->tablePtr =
- TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
+ (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
if (tsdTablePtr->tablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
@@ -148,15 +148,15 @@ TSDTableGrow(
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
- ClientData *newTablePtr;
+ void **newTablePtr;
sig_atomic_t i;
if (newAllocated <= atLeast) {
newAllocated = atLeast + 10;
}
- newTablePtr = TclpSysRealloc(tsdTablePtr->tablePtr,
- sizeof(ClientData) * newAllocated);
+ newTablePtr = (void **)TclpSysRealloc(tsdTablePtr->tablePtr,
+ sizeof(void *) * newAllocated);
if (newTablePtr == NULL) {
Tcl_Panic("unable to reallocate TSDTable");
}
@@ -189,7 +189,7 @@ void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
ClientData resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
@@ -223,7 +223,7 @@ TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
@@ -288,7 +288,7 @@ TclThreadStorageKeySet(
void
TclFinalizeThreadDataThread(void)
{
- TSDTable *tsdTablePtr = TclpThreadGetGlobalTSD(tsdGlobal.key);
+ TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 1302b4e..cd74071 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -6,8 +6,8 @@
* Some of this code is based on work done by Richard Hipp on behalf of
* Conservation Through Innovation, Limited, with their permission.
*
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright © 1998 Sun Microsystems, Inc.
+ * Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,7 +18,7 @@
#endif
#include "tclInt.h"
-#ifdef TCL_THREADS
+#if TCL_THREADS
/*
* Each thread has an single instance of the following structure. There is one
* instance of this structure per thread even if that thread contains multiple
@@ -119,9 +119,7 @@ static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
-static int ThreadObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static Tcl_ObjCmdProc ThreadObjCmd;
static int ThreadCreate(Tcl_Interp *interp, const char *script,
int joinable);
static int ThreadList(Tcl_Interp *interp);
@@ -130,15 +128,15 @@ static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
const char *result, int flags);
-static Tcl_ThreadCreateType NewTestThread(ClientData clientData);
+static Tcl_ThreadCreateType NewTestThread(void *clientData);
static void ListRemove(ThreadSpecificData *tsdPtr);
static void ListUpdateInner(ThreadSpecificData *tsdPtr);
static int ThreadEventProc(Tcl_Event *evPtr, int mask);
static void ThreadErrorProc(Tcl_Interp *interp);
-static void ThreadFreeProc(ClientData clientData);
+static void ThreadFreeProc(void *clientData);
static int ThreadDeleteEvent(Tcl_Event *eventPtr,
- ClientData clientData);
-static void ThreadExitProc(ClientData clientData);
+ void *clientData);
+static void ThreadExitProc(void *clientData);
extern int Tcltest_Init(Tcl_Interp *interp);
/*
@@ -203,10 +201,9 @@ TclThread_Init(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -272,11 +269,12 @@ ThreadObjCmd(
} else {
result = NULL;
}
- return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
+ return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags);
}
case THREAD_CREATE: {
const char *script;
- int joinable, len;
+ int joinable;
+ Tcl_Size len;
if (objc == 2) {
/*
@@ -336,11 +334,11 @@ ThreadObjCmd(
*/
if (objc == 2) {
- idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(Tcl_GetCurrentThread()));
} else if (objc == 3
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
Tcl_MutexLock(&threadMutex);
- idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(mainThreadId));
Tcl_MutexUnlock(&threadMutex);
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -365,14 +363,14 @@ ThreadObjCmd(
return TCL_ERROR;
}
- result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
+ result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
- char buf[20];
+ char buf[TCL_INTEGER_SPACE];
- snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", id);
- Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
+ snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (long long)id);
+ Tcl_AppendResult(interp, "cannot join thread ", buf, (void *)NULL);
}
return result;
}
@@ -407,14 +405,14 @@ ThreadObjCmd(
}
arg++;
script = Tcl_GetString(objv[arg]);
- return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
+ return ThreadSend(interp, (Tcl_ThreadId)INT2PTR(id), script, wait);
}
case THREAD_EVENT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
return TCL_OK;
}
@@ -435,7 +433,7 @@ ThreadObjCmd(
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
- errorProcString = ckalloc(strlen(proc) + 1);
+ errorProcString = (char *)ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
@@ -491,7 +489,6 @@ ThreadObjCmd(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
@@ -508,10 +505,10 @@ ThreadCreate(
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
- if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
+ if (Tcl_CreateThread(&id, NewTestThread, &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
- Tcl_AppendResult(interp, "can't create a new thread", NULL);
+ Tcl_AppendResult(interp, "can't create a new thread", (void *)NULL);
return TCL_ERROR;
}
@@ -556,9 +553,9 @@ ThreadCreate(
Tcl_ThreadCreateType
NewTestThread(
- ClientData clientData)
+ void *clientData)
{
- ThreadCtrl *ctrlPtr = clientData;
+ ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
@@ -595,7 +592,7 @@ NewTestThread(
* eval'ing, for the case that we exit during evaluation
*/
- threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
+ threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
@@ -612,7 +609,7 @@ NewTestThread(
*/
Tcl_Preserve(tsdPtr->interp);
- result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
+ result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, TCL_INDEX_NONE, 0);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
@@ -654,9 +651,9 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- snprintf(buf, sizeof(buf), "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ snprintf(buf, sizeof(buf), "%p", Tcl_GetCurrentThread());
- errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
@@ -822,7 +819,7 @@ ThreadSend(
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
- Tcl_AppendResult(interp, "invalid thread id", NULL);
+ Tcl_AppendResult(interp, "invalid thread id", (void *)NULL);
return TCL_ERROR;
}
@@ -840,13 +837,13 @@ ThreadSend(
* Create the event for its event queue.
*/
- threadEventPtr = ckalloc(sizeof(ThreadEvent));
- threadEventPtr->script = ckalloc(strlen(script) + 1);
+ threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
+ threadEventPtr->script = (char *)ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
- resultPtr = ckalloc(sizeof(ThreadEventResult));
+ resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
@@ -880,8 +877,7 @@ ThreadSend(
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
- TCL_QUEUE_TAIL);
- Tcl_ThreadAlert(threadId);
+ TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
@@ -917,7 +913,7 @@ ThreadSend(
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
- Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
+ Tcl_SetErrorCode(interp, resultPtr->errorCode, (void *)NULL);
ckfree(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
@@ -925,7 +921,7 @@ ThreadSend(
ckfree(resultPtr->errorInfo);
}
}
- Tcl_AppendResult(interp, resultPtr->result, NULL);
+ Tcl_AppendResult(interp, resultPtr->result, (void *)NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
@@ -976,7 +972,7 @@ ThreadCancel(
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
- Tcl_AppendResult(interp, "invalid thread id", NULL);
+ Tcl_AppendResult(interp, "invalid thread id", (void *)NULL);
return TCL_ERROR;
}
@@ -1010,7 +1006,7 @@ ThreadCancel(
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
- int mask)
+ TCL_UNUSED(int) /*mask*/)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
@@ -1031,8 +1027,8 @@ ThreadEventProc(
code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
- errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
- errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
@@ -1042,14 +1038,14 @@ ThreadEventProc(
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
- resultPtr->result = ckalloc(strlen(result) + 1);
+ resultPtr->result = (char *)ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
- resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
+ resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
- resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
+ resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
@@ -1073,15 +1069,14 @@ ThreadEventProc(
* None.
*
* Side effects:
- * Clears up mem specified in ClientData
+ * Clears up mem specified in clientData
*
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
ThreadFreeProc(
- ClientData clientData)
+ void *clientData)
{
if (clientData) {
ckfree(clientData);
@@ -1105,11 +1100,10 @@ ThreadFreeProc(
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
- ClientData clientData) /* dummy */
+ TCL_UNUSED(void *))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
@@ -1141,12 +1135,11 @@ ThreadDeleteEvent(
*------------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
ThreadExitProc(
- ClientData clientData)
+ void *clientData)
{
- char *threadEvalScript = clientData;
+ char *threadEvalScript = (char *)clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -1199,7 +1192,7 @@ ThreadExitProc(
const char *msg = "target thread died";
- resultPtr->result = ckalloc(strlen(msg) + 1);
+ resultPtr->result = (char *)ckalloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 500a75e..954e38f 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -4,7 +4,7 @@
* This file provides timer event management facilities for Tcl,
* including the "after" command.
*
- * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright © 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.
@@ -91,7 +91,7 @@ typedef struct IdleHandler {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
int lastTimerId; /* Timer identifier of most recently created
* timer. */
@@ -182,7 +182,7 @@ static void TimerSetupProc(ClientData clientData, int flags);
static ThreadSpecificData *
InitTimer(void)
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -211,9 +211,9 @@ InitTimer(void)
static void
TimerExitProc(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
- ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
@@ -297,7 +297,7 @@ TclCreateAbsoluteTimerHandler(
TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
- timerHandlerPtr = ckalloc(sizeof(TimerHandler));
+ timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
@@ -398,7 +398,7 @@ Tcl_DeleteTimerHandler(
static void
TimerSetupProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
@@ -456,7 +456,7 @@ TimerSetupProc(
static void
TimerCheckProc(
- ClientData data, /* Not used. */
+ TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
@@ -488,7 +488,7 @@ TimerCheckProc(
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
- timerEvPtr = ckalloc(sizeof(Tcl_Event));
+ timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
@@ -518,7 +518,7 @@ TimerCheckProc(
static int
TimerHandlerEventProc(
- Tcl_Event *evPtr, /* Event to service. */
+ TCL_UNUSED(Tcl_Event *),
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
@@ -625,7 +625,7 @@ Tcl_DoWhenIdle(
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
- idlePtr = ckalloc(sizeof(IdleHandler));
+ idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
@@ -776,10 +776,9 @@ TclServiceIdle(void)
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
int
Tcl_AfterObjCmd(
- ClientData clientData, /* Unused */
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -789,11 +788,11 @@ Tcl_AfterObjCmd(
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
- int index;
+ int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
- enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
+ enum afterSubCmdsEnum {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
@@ -806,9 +805,9 @@ Tcl_AfterObjCmd(
* doesn't already exist.
*/
- assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
+ assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
- assocPtr = ckalloc(sizeof(AfterAssocData));
+ assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
@@ -818,22 +817,16 @@ Tcl_AfterObjCmd(
* First lets see if the command was passed a number as the first argument.
*/
- if (objv[1]->typePtr == &tclIntType
-#ifndef TCL_WIDE_INT_IS_LONG
- || objv[1]->typePtr == &tclWideIntType
-#endif
- || objv[1]->typePtr == &tclBignumType
- || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
- &index) != TCL_OK)) {
- index = -1;
- if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
+ != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
- arg, NULL);
+ arg, (void *)NULL);
return TCL_ERROR;
}
}
@@ -851,7 +844,7 @@ Tcl_AfterObjCmd(
if (objc == 2) {
return AfterDelay(interp, ms);
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+ afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
@@ -900,10 +893,10 @@ Tcl_AfterObjCmd(
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
- command = Tcl_GetStringFromObj(commandPtr, &length);
+ command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
- tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
+ tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
@@ -931,7 +924,7 @@ Tcl_AfterObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
- afterPtr = ckalloc(sizeof(AfterInfo));
+ afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
@@ -972,7 +965,7 @@ Tcl_AfterObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
- Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
+ Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr;
@@ -1047,11 +1040,6 @@ AfterDelay(
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
@@ -1068,16 +1056,11 @@ AfterDelay(
}
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
- Tcl_Sleep((long) diff);
+ Tcl_Sleep((int) diff);
}
if (Tcl_AsyncReady()) {
if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
@@ -1091,7 +1074,7 @@ AfterDelay(
return TCL_ERROR;
}
}
- Tcl_GetTime(&now);
+ Tcl_GetTime(&now);
} while (TCL_TIME_BEFORE(now, endTime));
return TCL_OK;
}
@@ -1168,7 +1151,7 @@ static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
- AfterInfo *afterPtr = clientData;
+ AfterInfo *afterPtr = (AfterInfo *)clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
@@ -1266,14 +1249,13 @@ FreeAfterPtr(
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
static void
AfterCleanupProc(
ClientData clientData, /* Points to AfterAssocData for the
* interpreter. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
+ TCL_UNUSED(Tcl_Interp *))
{
- AfterAssocData *assocPtr = clientData;
+ AfterAssocData *assocPtr = (AfterAssocData *)clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 27afefd..27c4f98 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -22,20 +22,20 @@ scspec EXTERN
# Declare each of the functions in the Tcl tommath interface
declare 0 {
- int TclBN_epoch(void)
+ int MP_WUR TclBN_epoch(void)
}
declare 1 {
- int TclBN_revision(void)
+ int MP_WUR TclBN_revision(void)
}
declare 2 {
- mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 3 {
- mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c)
}
declare 4 {
- mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 5 {
void TclBN_mp_clamp(mp_int *a)
@@ -47,128 +47,128 @@ declare 7 {
void TclBN_mp_clear_multi(mp_int *a, ...)
}
declare 8 {
- mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b)
+ mp_ord MP_WUR TclBN_mp_cmp(const mp_int *a, const mp_int *b)
}
declare 9 {
- mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b)
+ mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, unsigned int b)
}
declare 10 {
- mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
+ mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
}
declare 11 {
- mp_err TclBN_mp_copy(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_copy(const mp_int *a, mp_int *b)
}
declare 12 {
- int TclBN_mp_count_bits(const mp_int *a)
+ int MP_WUR TclBN_mp_count_bits(const mp_int *a)
}
declare 13 {
- mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r)
+ mp_err MP_WUR TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r)
}
declare 14 {
- mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r)
+ mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *q, unsigned int *r)
}
declare 15 {
- mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q)
+ mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
- mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
+ mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
-declare 17 {
- mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r)
+declare 17 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r)
}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
- mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)
}
declare 20 {
- mp_err TclBN_mp_grow(mp_int *a, int size)
+ mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size)
}
declare 21 {
- mp_err TclBN_mp_init(mp_int *a)
+ mp_err MP_WUR TclBN_mp_init(mp_int *a)
}
declare 22 {
- mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b)
+ mp_err MP_WUR TclBN_mp_init_copy(mp_int *a, const mp_int *b)
}
declare 23 {
- mp_err TclBN_mp_init_multi(mp_int *a, ...)
+ mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...)
}
declare 24 {
- mp_err TclBN_mp_init_set(mp_int *a, mp_digit b)
+ mp_err MP_WUR TclBN_mp_init_set(mp_int *a, unsigned int b)
}
declare 25 {
- mp_err TclBN_mp_init_size(mp_int *a, int size)
+ mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size)
}
declare 26 {
- mp_err TclBN_mp_lshd(mp_int *a, int shift)
+ mp_err MP_WUR TclBN_mp_lshd(mp_int *a, int shift)
}
declare 27 {
- mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r)
+ mp_err MP_WUR TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r)
}
declare 28 {
- mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
+ mp_err MP_WUR TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
}
declare 29 {
- mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p)
}
declare 30 {
- mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p)
}
declare 31 {
- mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p)
}
declare 32 {
- mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
+ mp_err MP_WUR TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
}
declare 33 {
- mp_err TclBN_mp_neg(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_neg(const mp_int *a, mp_int *b)
}
declare 34 {
- mp_err TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 35 {
- mp_err TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
+ mp_err MP_WUR TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
}
declare 36 {
- mp_err TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
+ mp_err MP_WUR TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
- mp_err TclBN_mp_shrink(mp_int *a)
+ mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
-declare 39 {
- void TclBN_mp_set(mp_int *a, mp_digit b)
+declare 39 {deprecated {macro calling mp_set_u64}} {
+ void TclBN_mp_set(mp_int *a, unsigned int b)
}
-declare 40 {
+declare 40 {nostub {is private function in libtommath}} {
mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b)
}
declare 41 {
- mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b)
+ mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
- mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
- mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c)
}
-declare 44 {
+declare 44 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
}
-declare 45 {
+declare 45 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b,
unsigned long *outlen)
}
-declare 46 {
+declare 46 {deprecated {Use mp_to_radix}} {
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
}
declare 47 {
- size_t TclBN_mp_unsigned_bin_size(const mp_int *a)
+ size_t TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
- mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
@@ -177,107 +177,107 @@ declare 49 {
# internal routines to libtommath - should not be called but must be
# exported to accommodate the "tommath" extension
-declare 50 {
+declare 50 {deprecated {is private function in libtommath}} {
void TclBN_reverse(unsigned char *s, int len)
}
-declare 51 {
- mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
+declare 51 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
-declare 52 {
- mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b)
+declare 52 {deprecated {is private function in libtommath}} {
+ mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b)
}
-declare 53 {
+declare 53 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 54 {
+declare 54 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b)
}
-declare 55 {
+declare 55 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 56 {
+declare 56 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b)
}
-declare 57 {
+declare 57 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 58 {
+declare 58 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
-declare 59 {
+declare 59 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b)
}
-declare 60 {
+declare 60 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 61 {
- mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i)
+declare 61 {deprecated {macro calling mp_init_u64}} {
+ mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i)
}
-declare 62 {
- mp_err TclBN_mp_set_int(mp_int *a, unsigned long i)
+declare 62 {deprecated {macro calling mp_set_u64}} {
+ void TclBN_mp_set_ul(mp_int *a, unsigned long i)
}
declare 63 {
- int TclBN_mp_cnt_lsb(const mp_int *a)
+ int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
-declare 64 {
- int TclBNInitBignumFromLong(mp_int *bignum, long initVal)
+declare 64 {deprecated {macro calling mp_init_i64}} {
+ int TclBN_mp_init_l(mp_int *bignum, long initVal)
}
declare 65 {
- int TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal)
+ int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
- int TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal)
+ int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
# Added in libtommath 1.0
-declare 67 {
- mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
+declare 67 {deprecated {Use mp_expt_u32}} {
+ mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast)
}
# Added in libtommath 1.0.1
declare 68 {
- void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i)
+ void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
- Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a)
+ uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
- void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i)
+ void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
declare 71 {
- mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
+ mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
}
declare 72 {
- mp_err TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
+ mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
size_t size, mp_endian endian, size_t nails, const mp_int *op)
}
# Added in libtommath 1.1.0
-declare 73 {
+declare 73 {deprecated {merged with mp_and}} {
mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 74 {
+declare 74 {deprecated {merged with mp_or}} {
mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
}
-declare 75 {
+declare 75 {deprecated {merged with mp_xor}} {
mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 76 {
- mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
+ mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
- size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
+ size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
}
# Added in libtommath 1.2.0
declare 78 {
- int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
+ int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
declare 79 {
- mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r)
+ mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *q, uint64_t *r)
}
declare 80 {
- int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
+ int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index 79899e7..41e5b1d 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -1,1131 +1,49 @@
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
-
-#ifndef BN_H_
-#define BN_H_
-
-#ifndef MODULE_SCOPE
-#define MODULE_SCOPE extern
-#endif
-
-
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
-#if (defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT)
-# define MP_32BIT
-#endif
-
-/* detect 64-bit mode if possible */
-#if defined(NEVER)
-# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
-# if defined(__GNUC__)
-/* we support 128bit integers only via: __attribute__((mode(TI))) */
-# define MP_64BIT
-# else
-/* otherwise we fall back to MP_32BIT even on 64bit platforms */
-# define MP_32BIT
-# endif
-# endif
-#endif
-
-#ifdef MP_DIGIT_BIT
-# error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT
-#endif
-
-/* some default configurations.
- *
- * A "mp_digit" must be able to hold MP_DIGIT_BIT + 1 bits
- * A "mp_word" must be able to hold 2*MP_DIGIT_BIT + 1 bits
- *
- * At the very least a mp_digit must be able to hold 7 bits
- * [any size beyond that is ok provided it doesn't overflow the data type]
- */
-
-#ifdef MP_8BIT
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned char mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-typedef unsigned short private_mp_word;
-#define MP_WORD_DECLARED
-#endif
-# define MP_SIZEOF_MP_DIGIT 1
-# ifdef MP_DIGIT_BIT
-# error You must not define MP_DIGIT_BIT when using MP_8BIT
-# endif
-#elif defined(MP_16BIT)
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned short mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-typedef unsigned int private_mp_word;
-#define MP_WORD_DECLARED
-#endif
-# define MP_SIZEOF_MP_DIGIT 2
-# ifdef MP_DIGIT_BIT
-# error You must not define MP_DIGIT_BIT when using MP_16BIT
-# endif
-#elif defined(MP_64BIT)
-/* for GCC only on supported platforms */
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned long long mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-typedef unsigned long private_mp_word __attribute__((mode(TI)));
-# define MP_DIGIT_BIT 60
-#else
-/* this is the default case, 28-bit digits */
-
-/* this is to make porting into LibTomCrypt easier :-) */
-#ifndef MP_DIGIT_DECLARED
-typedef unsigned int mp_digit;
-#define MP_DIGIT_DECLARED
-#endif
-#ifndef MP_WORD_DECLARED
-#ifdef _WIN32
-typedef unsigned __int64 private_mp_word;
-#else
-typedef unsigned long long private_mp_word;
-#endif
-#define MP_WORD_DECLARED
-#endif
-
-# ifdef MP_31BIT
-/*
- * This is an extension that uses 31-bit digits.
- * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast
- * will be reduced to work on small numbers only:
- * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT.
- */
-# define MP_DIGIT_BIT 31
-# else
-/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-# define MP_DIGIT_BIT 28
-# define MP_28BIT
-# endif
-#endif
-
-/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
-#ifndef MP_DIGIT_BIT
-# define MP_DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */
-#endif
-
-#define MP_MASK ((((mp_digit)1)<<((mp_digit)MP_DIGIT_BIT))-((mp_digit)1))
-#define MP_DIGIT_MAX MP_MASK
-
-/* Primality generation flags */
-#define MP_PRIME_BBS 0x0001 /* BBS style prime */
-#define MP_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */
-#define MP_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */
-
-#define LTM_PRIME_BBS (MP_DEPRECATED_PRAGMA("LTM_PRIME_BBS has been deprecated, use MP_PRIME_BBS") MP_PRIME_BBS)
-#define LTM_PRIME_SAFE (MP_DEPRECATED_PRAGMA("LTM_PRIME_SAFE has been deprecated, use MP_PRIME_SAFE") MP_PRIME_SAFE)
-#define LTM_PRIME_2MSB_ON (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON)
-
-#ifdef MP_USE_ENUMS
-typedef enum {
- MP_ZPOS = 0, /* positive */
- MP_NEG = 1 /* negative */
-} mp_sign;
-typedef enum {
- MP_LT = -1, /* less than */
- MP_EQ = 0, /* equal */
- MP_GT = 1 /* greater than */
-} mp_ord;
-typedef enum {
- MP_NO = 0,
- MP_YES = 1
-} mp_bool;
-typedef enum {
- MP_OKAY = 0, /* no error */
- MP_ERR = -1, /* unknown error */
- MP_MEM = -2, /* out of mem */
- MP_VAL = -3, /* invalid input */
- MP_ITER = -4, /* maximum iterations reached */
- MP_BUF = -5 /* buffer overflow, supplied buffer too small */
-} mp_err;
-typedef enum {
- MP_LSB_FIRST = -1,
- MP_MSB_FIRST = 1
-} mp_order;
-typedef enum {
- MP_LITTLE_ENDIAN = -1,
- MP_NATIVE_ENDIAN = 0,
- MP_BIG_ENDIAN = 1
-} mp_endian;
-#else
-typedef int mp_sign;
-#define MP_ZPOS 0 /* positive integer */
-#define MP_NEG 1 /* negative */
-typedef int mp_ord;
-#define MP_LT -1 /* less than */
-#define MP_EQ 0 /* equal to */
-#define MP_GT 1 /* greater than */
-typedef int mp_bool;
-#define MP_YES 1
-#define MP_NO 0
-typedef int mp_err;
-#define MP_OKAY 0 /* no error */
-#define MP_ERR -1 /* unknown error */
-#define MP_MEM -2 /* out of mem */
-#define MP_VAL -3 /* invalid input */
-#define MP_RANGE (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL)
-#define MP_ITER -4 /* maximum iterations reached */
-#define MP_BUF -5 /* buffer overflow, supplied buffer too small */
-typedef int mp_order;
-#define MP_LSB_FIRST -1
-#define MP_MSB_FIRST 1
-typedef int mp_endian;
-#define MP_LITTLE_ENDIAN -1
-#define MP_NATIVE_ENDIAN 0
-#define MP_BIG_ENDIAN 1
-#endif
-
-/* tunable cutoffs */
-
-#ifndef MP_FIXED_CUTOFFS
-extern int
-KARATSUBA_MUL_CUTOFF,
-KARATSUBA_SQR_CUTOFF,
-TOOM_MUL_CUTOFF,
-TOOM_SQR_CUTOFF;
-#endif
-
-/* define this to use lower memory usage routines (exptmods mostly) */
-/* #define MP_LOW_MEM */
-
-/* default precision */
-#ifndef MP_PREC
-# ifndef MP_LOW_MEM
-# define MP_PREC 32 /* default digits of precision */
-# elif defined(MP_8BIT)
-# define MP_PREC 16 /* default digits of precision */
-# else
-# define MP_PREC 8 /* default digits of precision */
+#ifndef BN_TCL_H_
+#define BN_TCL_H_
+
+#include <stdint.h>
+#if defined(TCL_NO_TOMMATH_H)
+ typedef size_t mp_digit;
+ typedef int mp_sign;
+# define MP_ZPOS 0 /* positive integer */
+# define MP_NEG 1 /* negative */
+ typedef int mp_ord;
+# define MP_LT -1 /* less than */
+# define MP_EQ 0 /* equal to */
+# define MP_GT 1 /* greater than */
+ typedef int mp_err;
+# define MP_OKAY 0 /* no error */
+# define MP_ERR -1 /* unknown error */
+# define MP_MEM -2 /* out of mem */
+# define MP_VAL -3 /* invalid input */
+# define MP_ITER -4 /* maximum iterations reached */
+# define MP_BUF -5 /* buffer overflow, supplied buffer too small */
+ typedef int mp_order;
+# define MP_LSB_FIRST -1
+# define MP_MSB_FIRST 1
+ typedef int mp_endian;
+# define MP_LITTLE_ENDIAN -1
+# define MP_NATIVE_ENDIAN 0
+# define MP_BIG_ENDIAN 1
+# define MP_DEPRECATED_PRAGMA(s) /* nothing */
+# define MP_WUR /* nothing */
+# define mp_iszero(a) ((a)->used == 0)
+# define mp_isneg(a) ((a)->sign != 0)
+
+ /* the infamous mp_int structure */
+# ifndef MP_INT_DECLARED
+# define MP_INT_DECLARED
+ typedef struct mp_int mp_int;
# endif
-#endif
-
-/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
-#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1))
-
-#if defined(__GNUC__) && __GNUC__ >= 4
-# define MP_NULL_TERMINATED __attribute__((sentinel))
-#else
-# define MP_NULL_TERMINATED
-#endif
-
-/*
- * MP_WUR - warn unused result
- * ---------------------------
- *
- * The result of functions annotated with MP_WUR must be
- * checked and cannot be ignored.
- *
- * Most functions in libtommath return an error code.
- * This error code must be checked in order to prevent crashes or invalid
- * results.
- *
- * If you still want to avoid the error checks for quick and dirty programs
- * without robustness guarantees, you can `#define MP_WUR` before including
- * tommath.h, disabling the warnings.
- */
-#ifndef MP_WUR
-# if defined(__GNUC__) && __GNUC__ >= 4
-# define MP_WUR __attribute__((warn_unused_result))
-# else
-# define MP_WUR
-# endif
-#endif
-
-#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
-# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
-#elif defined(_MSC_VER) && _MSC_VER >= 1500
-# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
-#else
-# define MP_DEPRECATED(x)
-#endif
-
-#ifndef MP_NO_DEPRECATED_PRAGMA
-#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
-# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
-# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
-#elif defined(_MSC_VER) && _MSC_VER >= 1500
-# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
-#endif
-#endif
-
-#ifndef MP_DEPRECATED_PRAGMA
-# define MP_DEPRECATED_PRAGMA(s)
-#endif
-
-#define DIGIT_BIT MP_DIGIT_BIT
-#define USED(m) ((m)->used)
-#define DIGIT(m,k) ((m)->dp[(k)])
-#define SIGN(m) ((m)->sign)
-
-/* the infamous mp_int structure */
-#ifndef MP_INT_DECLARED
-#define MP_INT_DECLARED
-typedef struct mp_int mp_int;
-#endif
-struct mp_int {
- int used, alloc;
- mp_sign sign;
- mp_digit *dp;
+ struct mp_int {
+ int used, alloc;
+ mp_sign sign;
+ mp_digit *dp;
};
-/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
-typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
-typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback;
-
-/* error code to char* string */
-/*
-const char *mp_error_to_string(mp_err code) MP_WUR;
-*/
-
-/* ---> init and deinit bignum functions <--- */
-/* init a bignum */
-/*
-mp_err mp_init(mp_int *a) MP_WUR;
-*/
-
-/* free a bignum */
-/*
-void mp_clear(mp_int *a);
-*/
-
-/* init a null terminated series of arguments */
-/*
-mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR;
-*/
-
-/* clear a null terminated series of arguments */
-/*
-void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED;
-*/
-
-/* exchange two ints */
-/*
-void mp_exch(mp_int *a, mp_int *b);
-*/
-
-/* shrink ram required for a bignum */
-/*
-mp_err mp_shrink(mp_int *a) MP_WUR;
-*/
-
-/* grow an int to a given size */
-/*
-mp_err mp_grow(mp_int *a, int size) MP_WUR;
-*/
-
-/* init to a given number of digits */
-/*
-mp_err mp_init_size(mp_int *a, int size) MP_WUR;
-*/
-
-/* ---> Basic Manipulations <--- */
-#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
-#define mp_isodd(a) (((a)->used != 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
-#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
-#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)
-
-/* set to zero */
-/*
-void mp_zero(mp_int *a);
-*/
-
-/* get and set doubles */
-/*
-double mp_get_double(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_set_double(mp_int *a, double b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (int32_t) */
-#ifndef MP_NO_STDINT
-/*
-int32_t mp_get_i32(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_i32(mp_int *a, int32_t b);
-*/
-/*
-mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */
-#define mp_get_u32(a) ((uint32_t)mp_get_i32(a))
-/*
-void mp_set_u32(mp_int *a, uint32_t b);
-*/
-/*
-mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (int64_t) */
-/*
-int64_t mp_get_i64(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_i64(mp_int *a, int64_t b);
-*/
-/*
-mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */
-#define mp_get_u64(a) ((uint64_t)mp_get_i64(a))
-/*
-void mp_set_u64(mp_int *a, uint64_t b);
-*/
-/*
-mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
-*/
-
-/* get magnitude */
-/*
-uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
-*/
-/*
-uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
-*/
-#endif
-/*
-unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
-*/
-/*
-Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR;
-*/
-
-/* get integer, set integer (long) */
-/*
-long mp_get_l(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_l(mp_int *a, long b);
-*/
-/*
-mp_err mp_init_l(mp_int *a, long b) MP_WUR;
-*/
-
-/* get integer, set integer (unsigned long) */
-#define mp_get_ul(a) ((unsigned long)mp_get_l(a))
-/*
-void mp_set_ul(mp_int *a, unsigned long b);
-*/
-/*
-mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideInt) */
-/*
-Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR;
-*/
-/*
-void mp_set_ll(mp_int *a, Tcl_WideInt b);
-*/
-/*
-mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR;
-*/
-
-/* get integer, set integer (Tcl_WideUInt) */
-#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a))
-/*
-void mp_set_ull(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR;
-*/
-
-/* set to single unsigned digit, up to MP_DIGIT_MAX */
-/*
-void mp_set(mp_int *a, mp_digit b);
-*/
-/*
-mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* get integer, set integer and init with integer (deprecated) */
-/*
-MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
-*/
-/*
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b);
-*/
-/*
-MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
-*/
-
-/* copy, b = a */
-/*
-mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* inits and copies, a = b */
-/*
-mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* trim unused digits */
-/*
-void mp_clamp(mp_int *a);
-*/
-
-/* export binary data */
-/*
-MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
- int endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* import binary data */
-/*
-MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
- size_t size, int endian, size_t nails,
- const void *op) MP_WUR;
-*/
-
-/* unpack binary data */
-/*
-mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
- size_t nails, const void *op) MP_WUR;
-*/
-
-/* pack binary data */
-/*
-size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
- mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
-*/
-
-/* ---> digit manipulation <--- */
-
-/* right shift by "b" digits */
-/*
-void mp_rshd(mp_int *a, int b);
-*/
-
-/* left shift by "b" digits */
-/*
-mp_err mp_lshd(mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a / 2**b, implemented as c = a >> b */
-/*
-mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* b = a/2 */
-/*
-mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/3 => 3c + d == a */
-/*
-mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a * 2**b, implemented as c = a << b */
-/*
-mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*2 */
-/*
-mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* c = a mod 2**b */
-/*
-mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* computes a = 2**b */
-/*
-mp_err mp_2expt(mp_int *a, int b) MP_WUR;
-*/
-
-/* Counts the number of lsbs which are zero before the first zero bit */
-/*
-int mp_cnt_lsb(const mp_int *a) MP_WUR;
-*/
-
-/* I Love Earth! */
-
-/* makes a pseudo-random mp_int of a given size */
-/*
-mp_err mp_rand(mp_int *a, int digits) MP_WUR;
-*/
-/* makes a pseudo-random small int of a given size */
-/*
-MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR;
-*/
-/* use custom random data source instead of source provided the platform */
-/*
-void mp_rand_source(mp_err(*source)(void *out, size_t size));
-*/
-
-#ifdef MP_PRNG_ENABLE_LTM_RNG
-/* A last resort to provide random data on systems without any of the other
- * implemented ways to gather entropy.
- * It is compatible with `rng_get_bytes()` from libtomcrypt so you could
- * provide that one and then set `ltm_rng = rng_get_bytes;` */
-extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
-extern void (*ltm_rng_callback)(void);
-#endif
-
-/* ---> binary operations <--- */
-
-/* Checks the bit at position b and returns MP_YES
- * if the bit is 1, MP_NO if it is 0 and MP_VAL
- * in case of error
- */
-/*
-MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR;
-*/
-
-/* c = a XOR b (two complement) */
-/*
-MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a OR b (two complement) */
-/*
-MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a AND b (two complement) */
-/*
-MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = ~a (bitwise not, two complement) */
-/*
-mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* right shift with sign extension */
-/*
-MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-/*
-mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR;
-*/
-
-/* ---> Basic arithmetic <--- */
-
-/* b = -a */
-/*
-mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* b = |a| */
-/*
-mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* compare a to b */
-/*
-mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* compare |a| to |b| */
-/*
-mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* b = a*a */
-/*
-mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* Increment "a" by one like "a++". Changes input! */
-/*
-mp_err mp_incr(mp_int *a) MP_WUR;
-*/
-
-/* Decrement "a" by one like "a--". Changes input! */
-/*
-mp_err mp_decr(mp_int *a) MP_WUR;
-*/
-
-/* ---> single digit functions <--- */
-
-/* compare against a single digit */
-/*
-mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR;
-*/
-
-/* c = a + b */
-/*
-mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a - b */
-/*
-mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* c = a * b */
-/*
-mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-
-/* a/b => cb + d == a */
-/*
-mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
-*/
-
-/* c = a mod b, 0 <= c < b */
-/*
-mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
-*/
-
-/* ---> number theory <--- */
-
-/* d = a + b (mod c) */
-/*
-mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a - b (mod c) */
-/*
-mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* d = a * b (mod c) */
-/*
-mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
-*/
-
-/* c = a * a (mod b) */
-/*
-mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = 1/a (mod b) */
-/*
-mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* c = (a, b) */
-/*
-mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* produces value such that U1*a + U2*b = U3 */
-/*
-mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
-*/
-
-/* c = [a, b] or (a*b)/(a, b) */
-/*
-mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
-*/
-
-/* finds one of the b'th root of a, such that |c|**b <= |a|
- *
- * returns error if a < 0 and b is even
- */
-/*
-mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* special sqrt algo */
-/*
-mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR;
-*/
-
-/* special sqrt (mod prime) */
-/*
-mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
-*/
-
-/* is number a square? */
-/*
-mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR;
-*/
-
-/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
-/*
-MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
-*/
-
-/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
-/*
-mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR;
-*/
-
-/* used to setup the Barrett reduction for a given modulus b */
-/*
-mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* Barrett Reduction, computes a (mod b) with a precomputed value c
- *
- * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
- * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
- */
-/*
-mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR;
-*/
-
-/* setups the montgomery reduction */
-/*
-mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
-*/
-
-/* computes a = B**n mod b without division or multiplication useful for
- * normalizing numbers in a Montgomery system.
- */
-/*
-mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR;
-*/
-
-/* computes x/R == x (mod N) via Montgomery Reduction */
-/*
-mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
-*/
-
-/* returns 1 if a is a valid DR modulus */
-/*
-mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR;
-*/
-
-/* sets the value of "d" required for mp_dr_reduce */
-/*
-void mp_dr_setup(const mp_int *a, mp_digit *d);
-*/
-
-/* reduces a modulo n using the Diminished Radix method */
-/*
-mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k */
-/*
-mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR;
-*/
-
-/* returns true if a can be reduced with mp_reduce_2k_l */
-/*
-mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR;
-*/
-
-/* determines k value for 2k reduction */
-/*
-mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
-*/
-
-/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-/*
-mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR;
-*/
-
-/* Y = G**X (mod P) */
-/*
-mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
-*/
-
-/* ---> Primes <--- */
-
-/* number of primes */
-#ifdef MP_8BIT
-# define PRIVATE_MP_PRIME_TAB_SIZE 31
-#else
-# define PRIVATE_MP_PRIME_TAB_SIZE 256
-#endif
-#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
-
-/* table of first PRIME_SIZE primes */
-#if defined(BUILD_tcl) || !defined(_WIN32)
-MODULE_SCOPE const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
-#endif
-
-/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
-/*
-MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Fermat test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Miller-Rabin test of "a" using base "b".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
-*/
-
-/* This gives [for a given bit size] the number of trials required
- * such that Miller-Rabin gives a prob of failure lower than 2^-96
- */
-/*
-int mp_prime_rabin_miller_trials(int size) MP_WUR;
-*/
-
-/* performs one strong Lucas-Selfridge test of "a".
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
-*/
-
-/* performs one Frobenius test of "a" as described by Paul Underwood.
- * Sets result to 0 if composite or 1 if probable prime
- */
-/*
-mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
-*/
-
-/* performs t random rounds of Miller-Rabin on "a" additional to
- * bases 2 and 3. Also performs an initial sieve of trial
- * division. Determines if "a" is prime with probability
- * of error no more than (1/4)**t.
- * Both a strong Lucas-Selfridge to complete the BPSW test
- * and a separate Frobenius test are available at compile time.
- * With t<0 a deterministic test is run for primes up to
- * 318665857834031151167461. With t<13 (abs(t)-13) additional
- * tests with sequential small primes are run starting at 43.
- * Is Fips 186.4 compliant if called with t as computed by
- * mp_prime_rabin_miller_trials();
- *
- * Sets result to 1 if probably prime, 0 otherwise
- */
-/*
-mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR;
-*/
-
-/* finds the next prime after the number "a" using "t" trials
- * of Miller-Rabin.
- *
- * bbs_style = 1 means the prime must be congruent to 3 mod 4
- */
-/*
-mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
-*/
-
-/* makes a truly random prime of a given size (bytes),
- * call with bbs = 1 if you want it to be congruent to 3 mod 4
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- * The prime generated will be larger than 2^(8*size).
- */
-#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat))
-
-/* makes a truly random prime of a given size (bits),
- *
- * Flags are as follows:
- *
- * MP_PRIME_BBS - make prime congruent to 3 mod 4
- * MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS)
- * MP_PRIME_2MSB_ON - make the 2nd highest bit one
- *
- * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
- * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
- * so it can be NULL
- *
- */
-/*
-MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
- private_mp_prime_callback cb, void *dat) MP_WUR;
-*/
-/*
-mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
-*/
-
-/* Integer logarithm to integer base */
-/*
-mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR;
-*/
-
-/* c = a**b */
-/*
-mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
-*/
-
-/* ---> radix conversion <--- */
-/*
-int mp_count_bits(const mp_int *a) MP_WUR;
-*/
-
-
-/*
-MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
-*/
-
-/*
-size_t mp_ubin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-size_t mp_sbin_size(const mp_int *a) MP_WUR;
-*/
-/*
-mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
-*/
-/*
-mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
-*/
-
-/*
-mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
-*/
-/*
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
-*/
-/*
-mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
-*/
-/*
-mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR;
-*/
-
-#ifndef MP_NO_FILE
-/*
-mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
-/*
-mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
-*/
+#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
+# include "tommath.h"
#endif
-
-#define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len)))
-#define mp_raw_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_signed_bin_size") mp_signed_bin_size(mp))
-#define mp_toraw(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_signed_bin") mp_to_signed_bin((mp), (str)))
-#define mp_read_mag(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_unsigned_bin") mp_read_unsigned_bin((mp), (str), (len))
-#define mp_mag_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_unsigned_bin_size") mp_unsigned_bin_size(mp))
-#define mp_tomag(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_unsigned_bin") mp_to_unsigned_bin((mp), (str)))
-
-#define mp_tobinary(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_binary") mp_toradix((M), (S), 2))
-#define mp_tooctal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_octal") mp_toradix((M), (S), 8))
-#define mp_todecimal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_decimal") mp_toradix((M), (S), 10))
-#define mp_tohex(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_hex") mp_toradix((M), (S), 16))
-
-#define mp_to_binary(M, S, N) mp_to_radix((M), (S), (N), NULL, 2)
-#define mp_to_octal(M, S, N) mp_to_radix((M), (S), (N), NULL, 8)
-#define mp_to_decimal(M, S, N) mp_to_radix((M), (S), (N), NULL, 10)
-#define mp_to_hex(M, S, N) mp_to_radix((M), (S), (N), NULL, 16)
-
-#ifdef __cplusplus
-}
-#endif
-
#include "tclTomMathDecls.h"
#endif
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index e6f23aa..b4ab607 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -16,6 +16,7 @@
#define _TCLTOMMATHDECLS
#include "tcl.h"
+#include <string.h>
#ifndef BN_H_
#include "tclTomMath.h"
#endif
@@ -34,59 +35,94 @@
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
-#define TclBNAlloc(s) ((void*)ckalloc((size_t)(s)))
+#define TclBNAlloc(s) ((void*)attemptckalloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */
-#define TclBNCalloc(m,s) memset(ckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s))
+#define TclBNCalloc(m,s) memset(attemptckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
-#define TclBNRealloc(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s)))
+#define TclBNRealloc(x,s) ((void*)attemptckrealloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (ckfree((char*)(x)))
+#undef MP_MALLOC
+#undef MP_CALLOC
+#undef MP_REALLOC
+#undef MP_FREE
#define MP_MALLOC(size) TclBNAlloc(size)
-#define MP_CALLOC(nmemb, size) TclBNCalloc(nmemb, size)
-#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
-#define MP_FREE(mem, size) TclBNFree(mem)
+#define MP_CALLOC(nmemb, size) TclBNCalloc((nmemb), (size))
+#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc((mem), ((void)(oldsize), (newsize)))
+#define MP_FREE(mem, size) TclBNFree(((void)(size), (mem)))
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
+MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b);
+MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c);
+MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
+MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b);
+MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c);
+MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c);
+MODULE_SCOPE const char *const TclBN_mp_s_rmap;
+MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[];
+MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz;
+MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b);
+#ifdef __cplusplus
+}
+#endif
/* Rename the global symbols in libtommath to avoid linkage conflicts */
+#ifndef TCL_WITH_EXTERNAL_TOMMATH
#define bn_reverse TclBN_reverse
#define mp_add TclBN_mp_add
-#define mp_add_d TclBN_mp_add_d
+#define mp_add_d TclBN_s_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
-#define mp_cmp_d TclBN_mp_cmp_d
+#define mp_cmp_d TclBN_s_mp_cmp_d
#define mp_cmp_mag TclBN_mp_cmp_mag
#define mp_cnt_lsb TclBN_mp_cnt_lsb
#define mp_copy TclBN_mp_copy
#define mp_count_bits TclBN_mp_count_bits
#define mp_div TclBN_mp_div
+#define mp_div_d TclBN_s_mp_div_d
#define mp_div_2 TclBN_mp_div_2
+#define mp_div_3 TclBN_s_mp_div_3
#define mp_div_2d TclBN_mp_div_2d
-#define mp_div_3 TclBN_mp_div_3
-#define mp_div_d TclBN_mp_div_d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_expt_d_ex TclBN_mp_expt_d_ex
-#define mp_expt_u32 TclBN_mp_expt_d
-#define mp_get_mag_ull TclBN_mp_get_mag_ull
+#define mp_expt_u32 TclBN_s_mp_expt_u32
+#define mp_get_mag_u64 TclBN_mp_get_mag_u64
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
+#define mp_init_i64 TclBN_mp_init_i64
#define mp_init_multi TclBN_mp_init_multi
-#define mp_init_set TclBN_mp_init_set
-#define mp_init_set_int TclBN_mp_init_set_int
+#define mp_init_set TclBN_s_mp_init_set
#define mp_init_size TclBN_mp_init_size
+#define mp_init_u64 TclBN_mp_init_u64
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
+#define mp_mul_d TclBN_s_mp_mul_d
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
-#define mp_mul_d TclBN_mp_mul_d
#define mp_neg TclBN_mp_neg
#define mp_or TclBN_mp_or
#define mp_pack TclBN_mp_pack
@@ -94,18 +130,17 @@
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
-#define mp_set TclBN_mp_set
-#define mp_set_int(a,b) (TclBN_mp_set_int(a,(unsigned int)(b)),MP_OKAY)
-#define mp_set_ll TclBN_mp_set_ll
-#define mp_set_long(a,b) (TclBN_mp_set_int(a,b),MP_OKAY)
-#define mp_set_ul(a,b) (void)TclBN_mp_set_int(a,b)
-#define mp_set_ull TclBN_mp_set_ull
-#define mp_set_u64 TclBN_mp_set_ull
+#define mp_s_rmap TclBN_mp_s_rmap
+#define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse
+#define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz
+#define mp_set TclBN_s_mp_set
+#define mp_set_i64 TclBN_mp_set_i64
+#define mp_set_u64 TclBN_mp_set_u64
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
-#define mp_sub_d TclBN_mp_sub_d
+#define mp_sub_d TclBN_s_mp_sub_d
#define mp_signed_rsh TclBN_mp_signed_rsh
#define mp_tc_and TclBN_mp_and
#define mp_tc_div_2d TclBN_mp_signed_rsh
@@ -116,23 +151,29 @@
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_to_radix TclBN_mp_to_radix
#define mp_to_ubin TclBN_mp_to_ubin
+#define mp_ubin_size TclBN_mp_ubin_size
#define mp_unpack TclBN_mp_unpack
-#define mp_ubin_size TclBN_mp_unsigned_bin_size
-#define mp_unsigned_bin_size(a) ((int)TclBN_mp_unsigned_bin_size(a))
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
-#define s_mp_balance_mul TclBN_mp_balance_mul
+#define s_mp_balance_mul TclBN_s_mp_balance_mul
#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define s_mp_mul_digs TclBN_s_mp_mul_digs
-#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs
+#define s_mp_mul_digs_fast TclBN_s_mp_mul_digs_fast
#define s_mp_reverse TclBN_s_mp_reverse
#define s_mp_sqr TclBN_s_mp_sqr
-#define s_mp_sqr_fast TclBN_fast_s_mp_sqr
+#define s_mp_sqr_fast TclBN_s_mp_sqr_fast
#define s_mp_sub TclBN_s_mp_sub
#define s_mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_sqr TclBN_mp_toom_sqr
+#endif /* !TCL_WITH_EXTERNAL_TOMMATH */
+
+#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b)))
+#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY))
+#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY))
+#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY))
+#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp))
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
@@ -162,18 +203,18 @@ extern "C" {
*/
/* 0 */
-EXTERN int TclBN_epoch(void);
+EXTERN int TclBN_epoch(void) MP_WUR;
/* 1 */
-EXTERN int TclBN_revision(void);
+EXTERN int TclBN_revision(void) MP_WUR;
/* 2 */
EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 3 */
-EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 4 */
EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 5 */
EXTERN void TclBN_mp_clamp(mp_int *a);
/* 6 */
@@ -181,277 +222,298 @@ EXTERN void TclBN_mp_clear(mp_int *a);
/* 7 */
EXTERN void TclBN_mp_clear_multi(mp_int *a, ...);
/* 8 */
-EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b);
+EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
/* 9 */
-EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b);
+EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, unsigned int b) MP_WUR;
/* 10 */
-EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b);
+EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
/* 11 */
-EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b) MP_WUR;
/* 12 */
-EXTERN int TclBN_mp_count_bits(const mp_int *a);
+EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR;
/* 13 */
EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b,
- mp_int *q, mp_int *r);
+ mp_int *q, mp_int *r) MP_WUR;
/* 14 */
-EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b,
- mp_int *q, mp_digit *r);
+EXTERN mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b,
+ mp_int *q, unsigned int *r) MP_WUR;
/* 15 */
-EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q);
+EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR;
/* 16 */
EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
- mp_int *r);
+ mp_int *r) MP_WUR;
/* 17 */
-EXTERN mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q,
- mp_digit *r);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q,
+ unsigned int *r);
/* 18 */
EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b);
/* 19 */
-EXTERN mp_err TclBN_mp_expt_d(const mp_int *a, unsigned int b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 20 */
-EXTERN mp_err TclBN_mp_grow(mp_int *a, int size);
+EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR;
/* 21 */
-EXTERN mp_err TclBN_mp_init(mp_int *a);
+EXTERN mp_err TclBN_mp_init(mp_int *a) MP_WUR;
/* 22 */
-EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b);
+EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
/* 23 */
-EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...);
+EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR;
/* 24 */
-EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b);
+EXTERN mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) MP_WUR;
/* 25 */
-EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size);
+EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR;
/* 26 */
-EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift);
+EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift) MP_WUR;
/* 27 */
EXTERN mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b,
- mp_int *r);
+ mp_int *r) MP_WUR;
/* 28 */
-EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r);
+EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR;
/* 29 */
EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b,
- mp_int *p);
+ mp_int *p) MP_WUR;
/* 30 */
-EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b,
- mp_int *p);
+EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b,
+ mp_int *p) MP_WUR;
/* 31 */
-EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p);
+EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR;
/* 32 */
-EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p);
+EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) MP_WUR;
/* 33 */
-EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b) MP_WUR;
/* 34 */
EXTERN mp_err TclBN_mp_or(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 35 */
EXTERN mp_err TclBN_mp_radix_size(const mp_int *a, int radix,
- int *size);
+ int *size) MP_WUR;
/* 36 */
EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str,
- int radix);
+ int radix) MP_WUR;
/* 37 */
EXTERN void TclBN_mp_rshd(mp_int *a, int shift);
/* 38 */
-EXTERN mp_err TclBN_mp_shrink(mp_int *a);
+EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR;
/* 39 */
-EXTERN void TclBN_mp_set(mp_int *a, mp_digit b);
+TCL_DEPRECATED("macro calling mp_set_u64")
+void TclBN_mp_set(mp_int *a, unsigned int b);
/* 40 */
EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b);
/* 41 */
-EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b);
+EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR;
/* 42 */
EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 43 */
-EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b,
- mp_int *c);
+EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b,
+ mp_int *c) MP_WUR;
/* 44 */
-EXTERN mp_err TclBN_mp_to_unsigned_bin(const mp_int *a,
+TCL_DEPRECATED("Use mp_to_ubin")
+mp_err TclBN_mp_to_unsigned_bin(const mp_int *a,
unsigned char *b);
/* 45 */
-EXTERN mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a,
+TCL_DEPRECATED("Use mp_to_ubin")
+mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a,
unsigned char *b, unsigned long *outlen);
/* 46 */
-EXTERN mp_err TclBN_mp_toradix_n(const mp_int *a, char *str,
+TCL_DEPRECATED("Use mp_to_radix")
+mp_err TclBN_mp_toradix_n(const mp_int *a, char *str,
int radix, int maxlen);
/* 47 */
-EXTERN size_t TclBN_mp_unsigned_bin_size(const mp_int *a);
+EXTERN size_t TclBN_mp_ubin_size(const mp_int *a);
/* 48 */
EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 49 */
EXTERN void TclBN_mp_zero(mp_int *a);
/* 50 */
-EXTERN void TclBN_reverse(unsigned char *s, int len);
+TCL_DEPRECATED("is private function in libtommath")
+void TclBN_reverse(unsigned char *s, int len);
/* 51 */
-EXTERN mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a,
const mp_int *b, mp_int *c, int digs);
/* 52 */
-EXTERN mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b);
/* 53 */
-EXTERN mp_err TclBN_mp_karatsuba_mul(const mp_int *a,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_karatsuba_mul(const mp_int *a,
const mp_int *b, mp_int *c);
/* 54 */
-EXTERN mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
/* 55 */
-EXTERN mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b,
mp_int *c);
/* 56 */
-EXTERN mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
/* 57 */
-EXTERN mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b,
mp_int *c);
/* 58 */
-EXTERN mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b,
mp_int *c, int digs);
/* 59 */
-EXTERN mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
/* 60 */
-EXTERN mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("is private function in libtommath")
+mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b,
mp_int *c);
/* 61 */
-EXTERN mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i);
+TCL_DEPRECATED("macro calling mp_init_u64")
+mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i);
/* 62 */
-EXTERN mp_err TclBN_mp_set_int(mp_int *a, unsigned long i);
+TCL_DEPRECATED("macro calling mp_set_u64")
+void TclBN_mp_set_ul(mp_int *a, unsigned long i);
/* 63 */
-EXTERN int TclBN_mp_cnt_lsb(const mp_int *a);
+EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR;
/* 64 */
-EXTERN int TclBNInitBignumFromLong(mp_int *bignum, long initVal);
+TCL_DEPRECATED("macro calling mp_init_i64")
+int TclBN_mp_init_l(mp_int *bignum, long initVal);
/* 65 */
-EXTERN int TclBNInitBignumFromWideInt(mp_int *bignum,
- Tcl_WideInt initVal);
+EXTERN int TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) MP_WUR;
/* 66 */
-EXTERN int TclBNInitBignumFromWideUInt(mp_int *bignum,
- Tcl_WideUInt initVal);
+EXTERN int TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) MP_WUR;
/* 67 */
-EXTERN mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b,
+TCL_DEPRECATED("Use mp_expt_u32")
+mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b,
mp_int *c, int fast);
/* 68 */
-EXTERN void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i);
+EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i);
/* 69 */
-EXTERN Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a);
+EXTERN uint64_t TclBN_mp_get_mag_u64(const mp_int *a) MP_WUR;
/* 70 */
-EXTERN void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i);
+EXTERN void TclBN_mp_set_i64(mp_int *a, int64_t i);
/* 71 */
EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count,
mp_order order, size_t size,
mp_endian endian, size_t nails,
- const void *op);
+ const void *op) MP_WUR;
/* 72 */
EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount,
size_t *written, mp_order order, size_t size,
mp_endian endian, size_t nails,
- const mp_int *op);
+ const mp_int *op) MP_WUR;
/* 73 */
-EXTERN mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_and")
+mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
mp_int *c);
/* 74 */
-EXTERN mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_or")
+mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
mp_int *c);
/* 75 */
-EXTERN mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
+TCL_DEPRECATED("merged with mp_xor")
+mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
mp_int *c);
/* 76 */
EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b,
- mp_int *c);
+ mp_int *c) MP_WUR;
/* 77 */
EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails,
- size_t size);
+ size_t size) MP_WUR;
/* 78 */
EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf,
- size_t maxlen, size_t *written);
+ size_t maxlen, size_t *written) MP_WUR;
/* 79 */
-EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, Tcl_WideUInt b,
- mp_int *q, Tcl_WideUInt *r);
+EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b,
+ mp_int *q, uint64_t *r) MP_WUR;
/* 80 */
EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str,
- size_t maxlen, size_t *written, int radix);
+ size_t maxlen, size_t *written, int radix) MP_WUR;
typedef struct TclTomMathStubs {
int magic;
void *hooks;
- int (*tclBN_epoch) (void); /* 0 */
- int (*tclBN_revision) (void); /* 1 */
- mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */
- mp_err (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */
- mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */
+ int (*tclBN_epoch) (void) MP_WUR; /* 0 */
+ int (*tclBN_revision) (void) MP_WUR; /* 1 */
+ mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 2 */
+ mp_err (*tclBN_mp_add_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 3 */
+ mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 4 */
void (*tclBN_mp_clamp) (mp_int *a); /* 5 */
void (*tclBN_mp_clear) (mp_int *a); /* 6 */
void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */
- mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b); /* 8 */
- mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b); /* 9 */
- mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */
- mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */
- int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */
- mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */
- mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */
- mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */
- mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */
- mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */
+ mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b) MP_WUR; /* 8 */
+ mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, unsigned int b) MP_WUR; /* 9 */
+ mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */
+ mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */
+ int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
+ mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
+ mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */
+ mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
+ mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r); /* 17 */
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
- mp_err (*tclBN_mp_expt_d) (const mp_int *a, unsigned int b, mp_int *c); /* 19 */
- mp_err (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */
- mp_err (*tclBN_mp_init) (mp_int *a); /* 21 */
- mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */
- mp_err (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */
- mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */
- mp_err (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */
- mp_err (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */
- mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */
- mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */
- mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */
- mp_err (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */
- mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */
- mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */
- mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */
- mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */
- mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */
- mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */
+ mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */
+ mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
+ mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
+ mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
+ mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
+ mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */
+ mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */
+ mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */
+ mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r) MP_WUR; /* 27 */
+ mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r) MP_WUR; /* 28 */
+ mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 29 */
+ mp_err (*tclBN_mp_mul_d) (const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 30 */
+ mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p) MP_WUR; /* 31 */
+ mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p) MP_WUR; /* 32 */
+ mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */
+ mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 34 */
+ mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size) MP_WUR; /* 35 */
+ mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */
void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
- mp_err (*tclBN_mp_shrink) (mp_int *a); /* 38 */
- void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */
- mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */
- mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */
- mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */
- mp_err (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */
- mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
- mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
- mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
- size_t (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */
- mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */
+ mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */
+ TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */
+ mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */
+ mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */
+ mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */
+ TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
+ TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
+ TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
+ size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */
+ mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */
void (*tclBN_mp_zero) (mp_int *a); /* 49 */
- void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */
- mp_err (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */
- mp_err (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */
- mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */
- mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */
- mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */
- mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */
- mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */
- mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */
- mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */
- mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */
- mp_err (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */
- mp_err (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */
- int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */
- int (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */
- int (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */
- int (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */
- mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
- void (*tclBN_mp_set_ull) (mp_int *a, Tcl_WideUInt i); /* 68 */
- Tcl_WideUInt (*tclBN_mp_get_mag_ull) (const mp_int *a); /* 69 */
- void (*tclBN_mp_set_ll) (mp_int *a, Tcl_WideInt i); /* 70 */
- mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op); /* 71 */
- mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op); /* 72 */
- mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
- mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
- mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
- mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */
- size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size); /* 77 */
- int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); /* 78 */
- mp_err (*tclBN_mp_div_ld) (const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r); /* 79 */
- int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); /* 80 */
+ TCL_DEPRECATED_API("is private function in libtommath") void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs_fast) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr_fast) (const mp_int *a, mp_int *b); /* 52 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */
+ TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */
+ TCL_DEPRECATED_API("macro calling mp_init_u64") mp_err (*tclBN_mp_init_ul) (mp_int *a, unsigned long i); /* 61 */
+ TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set_ul) (mp_int *a, unsigned long i); /* 62 */
+ int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */
+ TCL_DEPRECATED_API("macro calling mp_init_i64") int (*tclBN_mp_init_l) (mp_int *bignum, long initVal); /* 64 */
+ int (*tclBN_mp_init_i64) (mp_int *bignum, int64_t initVal) MP_WUR; /* 65 */
+ int (*tclBN_mp_init_u64) (mp_int *bignum, uint64_t initVal) MP_WUR; /* 66 */
+ TCL_DEPRECATED_API("Use mp_expt_u32") mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, unsigned int b, mp_int *c, int fast); /* 67 */
+ void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */
+ uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */
+ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */
+ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */
+ mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */
+ TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
+ TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
+ TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
+ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */
+ size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */
+ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */
+ mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */
+ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -504,8 +566,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */
#define TclBN_mp_exch \
(tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */
-#define TclBN_mp_expt_d \
- (tclTomMathStubsPtr->tclBN_mp_expt_d) /* 19 */
+#define TclBN_mp_expt_u32 \
+ (tclTomMathStubsPtr->tclBN_mp_expt_u32) /* 19 */
#define TclBN_mp_grow \
(tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */
#define TclBN_mp_init \
@@ -560,18 +622,18 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */
#define TclBN_mp_toradix_n \
(tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */
-#define TclBN_mp_unsigned_bin_size \
- (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */
+#define TclBN_mp_ubin_size \
+ (tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */
#define TclBN_mp_xor \
(tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */
#define TclBN_mp_zero \
(tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */
#define TclBN_reverse \
(tclTomMathStubsPtr->tclBN_reverse) /* 50 */
-#define TclBN_fast_s_mp_mul_digs \
- (tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */
-#define TclBN_fast_s_mp_sqr \
- (tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */
+#define TclBN_s_mp_mul_digs_fast \
+ (tclTomMathStubsPtr->tclBN_s_mp_mul_digs_fast) /* 51 */
+#define TclBN_s_mp_sqr_fast \
+ (tclTomMathStubsPtr->tclBN_s_mp_sqr_fast) /* 52 */
#define TclBN_mp_karatsuba_mul \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */
#define TclBN_mp_karatsuba_sqr \
@@ -588,26 +650,26 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */
#define TclBN_s_mp_sub \
(tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */
-#define TclBN_mp_init_set_int \
- (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */
-#define TclBN_mp_set_int \
- (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */
+#define TclBN_mp_init_ul \
+ (tclTomMathStubsPtr->tclBN_mp_init_ul) /* 61 */
+#define TclBN_mp_set_ul \
+ (tclTomMathStubsPtr->tclBN_mp_set_ul) /* 62 */
#define TclBN_mp_cnt_lsb \
(tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */
-#define TclBNInitBignumFromLong \
- (tclTomMathStubsPtr->tclBNInitBignumFromLong) /* 64 */
-#define TclBNInitBignumFromWideInt \
- (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */
-#define TclBNInitBignumFromWideUInt \
- (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */
+#define TclBN_mp_init_l \
+ (tclTomMathStubsPtr->tclBN_mp_init_l) /* 64 */
+#define TclBN_mp_init_i64 \
+ (tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */
+#define TclBN_mp_init_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */
#define TclBN_mp_expt_d_ex \
(tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */
-#define TclBN_mp_set_ull \
- (tclTomMathStubsPtr->tclBN_mp_set_ull) /* 68 */
-#define TclBN_mp_get_mag_ull \
- (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */
-#define TclBN_mp_set_ll \
- (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */
+#define TclBN_mp_set_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_set_u64) /* 68 */
+#define TclBN_mp_get_mag_u64 \
+ (tclTomMathStubsPtr->tclBN_mp_get_mag_u64) /* 69 */
+#define TclBN_mp_set_i64 \
+ (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */
#define TclBN_mp_unpack \
(tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */
#define TclBN_mp_pack \
@@ -633,15 +695,33 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
/* !END!: Do not edit above this line. */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
+#if defined(USE_TCL_STUBS)
+#undef mp_add_d
+#define mp_add_d TclBN_mp_add_d
+#undef mp_cmp_d
+#define mp_cmp_d TclBN_mp_cmp_d
+#undef mp_div_d
+#ifdef MP_64BIT
+#define mp_div_d TclBN_mp_div_ld
+#else
+#define mp_div_d TclBN_mp_div_d
+#endif
+#undef mp_sub_d
+#define mp_sub_d TclBN_mp_sub_d
+#undef mp_init_set
+#define mp_init_set TclBN_mp_init_set
+#undef mp_mul_d
+#define mp_mul_d TclBN_mp_mul_d
+#undef mp_set
+#define mp_set TclBN_mp_set
+#undef mp_expt_u32
+#define mp_expt_u32 TclBN_mp_expt_u32
+#endif /* USE_TCL_STUBS */
-#ifdef USE_TCL_STUBS
-#undef TclBNInitBignumFromLong
#define TclBNInitBignumFromLong(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)); \
+ (void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \
} \
@@ -650,7 +730,7 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
#define TclBNInitBignumFromWideInt(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)); \
+ (void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \
} \
@@ -659,27 +739,41 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
#define TclBNInitBignumFromWideUInt(a,b) \
do { \
(a)->dp = NULL; \
- (void)tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)); \
+ (void)mp_init_u64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \
} \
} while (0)
-#define mp_init_i32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_l(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromLong((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ll(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_i64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u32(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ul(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ull(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u64(a,b) (((a)->dp=NULL,tclTomMathStubsPtr->tclBNInitBignumFromWideUInt((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#else
-#define mp_init_i32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(int32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_l(a,b) (((a)->dp=NULL,(TclBNInitBignumFromLong)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ll(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_i64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u32(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(uint32_t)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ul(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(unsigned long)(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_ull(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#define mp_init_u64(a,b) (((a)->dp=NULL,(TclBNInitBignumFromWideUInt)((a),(b)),(a)->dp)?MP_OKAY:MP_ERR)
-#endif /* USE_TCL_STUBS */
+#undef mp_get_ll
+#define mp_get_ll(a) ((long long)mp_get_i64(a))
+#undef mp_set_ll
+#define mp_set_ll(a,b) mp_set_i64(a,b)
+#undef mp_init_ll
+#define mp_init_ll(a,b) mp_init_i64(a,b)
+#undef mp_get_ull
+#define mp_get_ull(a) ((unsigned long long)mp_get_i64(a))
+#undef mp_set_ull
+#define mp_set_ull(a,b) mp_set_u64(a,b)
+#undef mp_init_ull
+#define mp_init_ull(a,b) mp_init_u64(a,b)
+#undef mp_set
+#define mp_set(a,b) mp_set_i64((a),(int32_t)(b))
+#define mp_set_i32(a,b) mp_set_i64((a),(int32_t)(b))
+#define mp_set_l(a,b) mp_set_i64((a),(long)(b))
+#define mp_set_u32(a,b) mp_set_u64((a),(uint32_t)(b))
+#define mp_set_ul(a,b) mp_set_u64((a),(unsigned long)(b))
+#define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b))
+#define mp_init_l(a,b) mp_init_i64((a),(long)(b))
+#define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b))
+#define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b))
+#undef mp_iseven
+#undef mp_isodd
+#define mp_iseven(a) (!mp_isodd(a))
+#define mp_isodd(a) (((a)->used != 0) && (((a)->dp[0] & 1) != 0))
+#undef mp_sqr
+#define mp_sqr(a,b) mp_mul(a,a,b)
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
#endif /* _TCLINTDECLS */
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 21fd238..149ee34 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -6,14 +6,14 @@
* This file contains procedures that are used as a 'glue' layer between
* Tcl and libtommath.
*
- * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 2005 Kevin B. Kenny. 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 "tommath.h"
+#include "tclTomMath.h"
MODULE_SCOPE const TclTomMathStubs tclTomMathStubs;
@@ -91,138 +91,6 @@ TclBN_revision(void)
}
/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromLong --
- *
- * Allocate and initialize a 'bignum' from a native 'long'.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromLong(
- mp_int *a,
- long initVal)
-{
- unsigned long v;
- mp_digit *p;
-
- /*
- * Allocate enough memory to hold the largest possible long
- */
-
- if (mp_init(a) != MP_OKAY) {
- Tcl_Panic("initialization failure in TclBNInitBignumFromLong");
- }
-
- /*
- * Convert arg to sign and magnitude.
- */
-
- if (initVal < 0) {
- a->sign = MP_NEG;
- v = -(unsigned long)initVal;
- } else {
- a->sign = MP_ZPOS;
- v = initVal;
- }
-
- /*
- * Store the magnitude in the bignum.
- */
-
- p = a->dp;
- while (v) {
- *p++ = (mp_digit) (v & MP_MASK);
- v >>= MP_DIGIT_BIT;
- }
- a->used = p - a->dp;
- return MP_OKAY;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromWideInt --
- *
- * Allocate and initialize a 'bignum' from a Tcl_WideInt
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromWideInt(
- mp_int *a, /* Bignum to initialize */
- Tcl_WideInt v) /* Initial value */
-{
- if (v < 0) {
- (void)TclBNInitBignumFromWideUInt(a, -(Tcl_WideUInt)v);
- return mp_neg(a, a);
- }
- (void)TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v);
- return MP_OKAY;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclBNInitBignumFromWideUInt --
- *
- * Allocate and initialize a 'bignum' from a Tcl_WideUInt
- *
- * Results:
- * None.
- *
- * Side effects:
- * The 'bignum' is constructed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclBNInitBignumFromWideUInt(
- mp_int *a, /* Bignum to initialize */
- Tcl_WideUInt v) /* Initial value */
-{
- mp_digit *p;
-
- /*
- * Allocate enough memory to hold the largest possible Tcl_WideUInt.
- */
-
- if (mp_init(a) != MP_OKAY) {
- Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt");
- }
-
- a->sign = 0;
-
- /*
- * Store the magnitude in the bignum.
- */
-
- p = a->dp;
- while (v) {
- *p++ = (mp_digit) (v & MP_MASK);
- v >>= MP_DIGIT_BIT;
- }
- a->used = p - a->dp;
- return MP_OKAY;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index 324f2a3..c0786c9 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -4,14 +4,15 @@
* Stub object that will be statically linked into extensions that want
* to access Tcl.
*
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 1998 Paul Duffin.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 1998 Paul Duffin.
*
* 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 "tclTomMath.h"
MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr;
@@ -55,9 +56,9 @@ TclTomMathInitializeStubs(
}
if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
- } else if(stubsPtr->tclBN_epoch() != epoch) {
+ } else if (stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
- } else if(stubsPtr->tclBN_revision() != revision) {
+ } else if (stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index dc90024..6adc724 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -3,10 +3,10 @@
*
* This file contains code to handle most trace management.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-2000 Scriptics Corporation.
- * Copyright (c) 2002 ActiveState Corporation.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-2000 Scriptics Corporation.
+ * Copyright © 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -21,8 +21,8 @@
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
- size_t length; /* Number of non-NUL chars. in command. */
- char command[1]; /* Space for Tcl command to invoke. Actual
+ Tcl_Size length; /* Number of non-NUL chars. in command. */
+ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
* structure, so that it can be larger than 1
@@ -41,10 +41,10 @@ typedef struct {
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
- size_t length; /* Number of non-NUL chars. in command. */
+ Tcl_Size length; /* Number of non-NUL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
- int startLevel; /* Used for bookkeeping with step execution
+ Tcl_Size startLevel; /* Used for bookkeeping with step execution
* traces, store the level at which the step
* trace was invoked */
char *startCmd; /* Used for bookkeeping with step execution
@@ -52,11 +52,11 @@ typedef struct {
* invoked step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
- int refCount; /* Used to ensure this structure is not
+ 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. */
- char command[1]; /* Space for Tcl command to invoke. Actual
+ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
* structure, so that it can be larger than 1
@@ -79,8 +79,7 @@ typedef struct {
* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
* by the command being traced, not because of
* an internal trace.
- * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also be used
- * in command execution traces.
+ * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces.
*/
#define TCL_TRACE_ENTER_DURING_EXEC 4
@@ -93,8 +92,15 @@ typedef struct {
* Forward declarations for functions defined in this file:
*/
-typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex,
- int objc, Tcl_Obj *const objv[]);
+/* 'OLD' options are pre-Tcl-8.4 style */
+enum traceOptionsEnum {
+ TRACE_ADD, TRACE_INFO, TRACE_REMOVE
+#ifndef TCL_NO_DEPRECATED
+ ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
+#endif
+};
+typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
static Tcl_TraceTypeObjCmd TraceVariableObjCmd;
static Tcl_TraceTypeObjCmd TraceCommandObjCmd;
@@ -121,19 +127,19 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
*/
static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr,
- Command *cmdPtr, const char *command, int numChars,
- int objc, Tcl_Obj *const objv[]);
-static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp,
+ Command *cmdPtr, const char *command, Tcl_Size numChars,
+ Tcl_Size objc, Tcl_Obj *const objv[]);
+static char * TraceVarProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
-static void TraceCommandProc(ClientData clientData,
+static void TraceCommandProc(void *clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static Tcl_CmdObjTraceProc TraceExecutionProc;
-static int StringTraceProc(ClientData clientData,
- Tcl_Interp *interp, int level,
+static int StringTraceProc(void *clientData,
+ Tcl_Interp *interp, Tcl_Size level,
const char *command, Tcl_Command commandInfo,
- int objc, Tcl_Obj *const objv[]);
-static void StringTraceDeleteProc(ClientData clientData);
+ Tcl_Size 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);
@@ -143,8 +149,8 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1,
* trace procs
*/
-typedef struct StringTraceData {
- ClientData clientData; /* Client data from Tcl_CreateTrace */
+typedef struct {
+ void *clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
@@ -184,42 +190,49 @@ typedef struct StringTraceData {
int
Tcl_TraceObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int optionIndex;
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
const char *name;
const char *flagOps, *p;
#endif
/* Main sub commands to 'trace' */
static const char *const traceOptions[] = {
"add", "info", "remove",
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
"variable", "vdelete", "vinfo",
#endif
NULL
};
- /* 'OLD' options are pre-Tcl-8.4 style */
- enum traceOptions {
- TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
- TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
-#endif
+ int optionIndex;
+#ifndef TCL_NO_DEPRECATED
+ static const char *const traceShortOptions[] = {
+ "add", "info", "remove", NULL
};
+#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
+#ifdef TCL_NO_DEPRECATED
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- switch ((enum traceOptions) optionIndex) {
+#else
+ if (Tcl_GetIndexFromObj(NULL, objv[1], traceOptions, "option", 0,
+ &optionIndex) != TCL_OK) {
+ Tcl_GetIndexFromObj(interp, objv[1], traceShortOptions, "option", 0,
+ &optionIndex);
+ return TCL_ERROR;
+ }
+#endif
+ switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
/*
@@ -238,7 +251,7 @@ Tcl_TraceObjCmd(
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv);
}
case TRACE_INFO: {
/*
@@ -261,17 +274,16 @@ Tcl_TraceObjCmd(
0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
- return traceSubCmds[typeIndex](interp, optionIndex, objc, objv);
+ return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv);
break;
}
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
- int code;
- int numFlags;
+ int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
@@ -280,7 +292,7 @@ Tcl_TraceObjCmd(
TclNewObj(opsList);
Tcl_IncrRefCount(opsList);
- flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
+ flagOps = TclGetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
@@ -314,7 +326,7 @@ Tcl_TraceObjCmd(
return code;
}
case TRACE_OLD_VINFO: {
- ClientData clientData;
+ void *clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
@@ -363,16 +375,16 @@ Tcl_TraceObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
-#endif /* TCL_REMOVE_OBSOLETE_TRACES */
+#endif /* TCL_NO_DEPRECATED */
}
return TCL_OK;
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
badVarOps:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad operations \"%s\": should be one or more of rwua",
flagOps));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", (void *)NULL);
return TCL_ERROR;
#endif
}
@@ -399,16 +411,12 @@ Tcl_TraceObjCmd(
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- enum traceOptions {
- TRACE_ADD, TRACE_INFO, TRACE_REMOVE
- };
+ Tcl_Size length;
static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
@@ -416,12 +424,13 @@ TraceExecutionObjCmd(
TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP
};
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
- int flags = 0;
- int i, listLen, result;
+ int flags = 0, result;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -434,7 +443,7 @@ TraceExecutionObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -443,9 +452,13 @@ TraceExecutionObjCmd(
"bad operation list \"\": must be one or more of"
" enter, leave, enterstep, or leavestep", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -466,11 +479,10 @@ TraceExecutionObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -497,7 +509,7 @@ TraceExecutionObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -556,7 +568,7 @@ TraceExecutionObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -576,7 +588,7 @@ TraceExecutionObjCmd(
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- int numOps = 0;
+ Tcl_Size numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -604,7 +616,7 @@ TraceExecutionObjCmd(
TclNewLiteralStringObj(opObj, "leavestep");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
- TclListObjLength(NULL, elemObjPtr, &numOps);
+ TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
@@ -621,6 +633,10 @@ TraceExecutionObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_NO_DEPRECATED
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -647,22 +663,21 @@ TraceExecutionObjCmd(
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ Tcl_Size length;
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch (optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
- int i, listLen;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -675,7 +690,7 @@ TraceCommandObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -684,10 +699,13 @@ TraceCommandObjCmd(
"bad operation list \"\": must be one or more of"
" delete or rename", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
-
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -703,11 +721,10 @@ TraceCommandObjCmd(
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
- TclOffset(TraceCommandInfo, command) + 1 + length);
+ offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -730,7 +747,7 @@ TraceCommandObjCmd(
* first one that matches.
*/
- ClientData clientData;
+ void *clientData;
/*
* First ensure the name given is valid.
@@ -760,7 +777,7 @@ TraceCommandObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
+ void *clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -779,7 +796,7 @@ TraceCommandObjCmd(
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
- int numOps = 0;
+ Tcl_Size numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -799,7 +816,7 @@ TraceCommandObjCmd(
TclNewLiteralStringObj(opObj, "delete");
Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj);
}
- TclListObjLength(NULL, elemObjPtr, &numOps);
+ TclListObjLengthM(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
@@ -815,6 +832,10 @@ TraceCommandObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_NO_DEPRECATED
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -841,27 +862,26 @@ TraceCommandObjCmd(
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
- int optionIndex, /* Add, info or remove */
- int objc, /* Number of arguments. */
+ enum traceOptionsEnum optionIndex, /* Add, info or remove */
+ Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int commandLength, index;
const char *name, *command;
- size_t length;
- ClientData clientData;
- enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ Tcl_Size 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
};
+ int index;
- switch ((enum traceOptions) optionIndex) {
+ switch ((enum traceOptionsEnum) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0, result;
- int i, listLen;
+ Tcl_Size i, listLen;
Tcl_Obj **elemPtrs;
if (objc != 6) {
@@ -874,7 +894,7 @@ TraceVariableObjCmd(
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs);
+ result = TclListObjLengthM(interp, objv[4], &listLen);
if (result != TCL_OK) {
return result;
}
@@ -883,9 +903,13 @@ TraceVariableObjCmd(
"bad operation list \"\": must be one or more of"
" array, read, unset, or write", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
+ result = TclListObjGetElementsM(interp, objv[4], &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
for (i = 0; i < listLen ; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
@@ -906,15 +930,14 @@ TraceVariableObjCmd(
break;
}
}
- command = Tcl_GetStringFromObj(objv[5], &commandLength);
- length = commandLength;
- if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ command = TclGetStringFromObj(objv[5], &length);
+ if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc(
- TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+ offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
}
@@ -944,7 +967,7 @@ TraceVariableObjCmd(
if ((tvarPtr->length == length)
&& ((tvarPtr->flags
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
& ~TCL_TRACE_OLD_STYLE
#endif
)==flags)
@@ -1007,6 +1030,10 @@ TraceVariableObjCmd(
Tcl_SetObjResult(interp, resultListPtr);
break;
}
+#ifndef TCL_NO_DEPRECATED
+ default:
+ break;
+#endif
}
return TCL_OK;
}
@@ -1036,14 +1063,13 @@ TraceVariableObjCmd(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
- int flags, /* OR-ed combo or TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY (can be 0). */
+ TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
- ClientData prevClientData) /* If non-NULL, gives last value returned by
+ 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. */
@@ -1111,7 +1137,7 @@ Tcl_TraceCommand(
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
@@ -1175,7 +1201,7 @@ Tcl_UntraceCommand(
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
@@ -1280,7 +1306,7 @@ Tcl_UntraceCommand(
static void
TraceCommandProc(
- ClientData clientData, /* Information about the command trace. */
+ 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
@@ -1421,18 +1447,17 @@ TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
- int numChars, /* The number of characters in 'command' which
- * are part of the command string. */
+ TCL_UNUSED(Tcl_Size) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
- int curLevel;
+ Tcl_Size curLevel;
int traceCode = TCL_OK;
Tcl_InterpState state = NULL;
@@ -1527,18 +1552,18 @@ TclCheckInterpTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
- int numChars, /* The number of characters in 'command' which
+ Tcl_Size numChars, /* The number of characters in 'command' which
* are part of the command string. */
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
- int curLevel;
+ Tcl_Size curLevel;
int traceCode = TCL_OK;
Tcl_InterpState state = NULL;
@@ -1674,9 +1699,9 @@ CallTraceFunction(
Command *cmdPtr, /* Points to command's Command struct. */
const char *command, /* Points to the first character of the
* command's source before substitutions. */
- int numChars, /* The number of characters in the command's
+ Tcl_Size numChars, /* The number of characters in the command's
* source. */
- int objc, /* Number of arguments for the command. */
+ Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
@@ -1721,7 +1746,7 @@ CallTraceFunction(
static void
CommandObjTraceDeleted(
- ClientData clientData)
+ void *clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
@@ -1757,12 +1782,12 @@ CommandObjTraceDeleted(
static int
TraceExecutionProc(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
- int level,
+ Tcl_Size level,
const char *command,
- Tcl_Command cmdInfo,
- int objc,
+ TCL_UNUSED(Tcl_Command),
+ Tcl_Size objc,
Tcl_Obj *const objv[])
{
int call = 0;
@@ -1817,7 +1842,8 @@ TraceExecutionProc(
if (call) {
Tcl_DString cmd, sub;
- int i, saveInterpFlags;
+ Tcl_Size i;
+ int saveInterpFlags;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length);
@@ -1964,7 +1990,7 @@ TraceExecutionProc(
static char *
TraceVarProc(
- ClientData clientData, /* Information about the variable trace. */
+ 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
@@ -1998,7 +2024,7 @@ TraceVarProc(
Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
TclDStringAppendLiteral(&cmd, " a");
@@ -2020,7 +2046,7 @@ TraceVarProc(
} else if (flags & TCL_TRACE_UNSETS) {
TclDStringAppendLiteral(&cmd, " unset");
}
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
}
#endif
@@ -2073,7 +2099,7 @@ TraceVarProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateObjTrace --
+ * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 --
*
* Arrange for a function to be called to trace command execution.
*
@@ -2086,7 +2112,7 @@ TraceVarProc(
* called to execute a Tcl command. Calls to proc will have the following
* form:
*
- * void proc(ClientData clientData,
+ * void proc(void * clientData,
* Tcl_Interp * interp,
* int level,
* const char * command,
@@ -2128,10 +2154,10 @@ TraceVarProc(
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
- int level, /* Maximum nesting level */
+ Tcl_Size level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
- ClientData clientData, /* Client data for the callback */
+ void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
@@ -2191,12 +2217,12 @@ Tcl_CreateObjTrace(
* void
* proc(clientData, interp, level, command, cmdProc, cmdClientData,
* argc, argv)
- * ClientData clientData;
+ * void *clientData;
* Tcl_Interp *interp;
* int level;
* char *command;
* int (*cmdProc)();
- * ClientData cmdClientData;
+ * void *cmdClientData;
* int argc;
* char **argv;
* {
@@ -2217,11 +2243,11 @@ Tcl_CreateObjTrace(
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
- int level, /* Only call proc for commands at nesting
+ Tcl_Size level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
- ClientData clientData) /* Arbitrary value word to pass to proc. */
+ void *clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData));
@@ -2249,18 +2275,18 @@ Tcl_CreateTrace(
static int
StringTraceProc(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
- int level,
+ Tcl_Size level,
const char *command,
Tcl_Command commandInfo,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const *objv)
{
StringTraceData *data = (StringTraceData *)clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
- int i;
+ Tcl_Size i;
/*
* This is a bit messy because we have to emulate the old trace interface,
@@ -2305,7 +2331,7 @@ StringTraceProc(
static void
StringTraceDeleteProc(
- ClientData clientData)
+ void *clientData)
{
ckfree(clientData);
}
@@ -2558,6 +2584,9 @@ TclObjCallVarTraces(
leaveErrMsg);
}
+#undef TCL_INTERP_DESTROYED
+#define TCL_INTERP_DESTROYED 0x100
+
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
@@ -2855,6 +2884,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
@@ -2870,6 +2900,7 @@ Tcl_UntraceVar(
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2929,7 +2960,7 @@ Tcl_UntraceVar2(
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
@@ -3024,6 +3055,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
@@ -3041,6 +3073,7 @@ Tcl_VarTraceInfo(
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3133,6 +3166,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
@@ -3150,6 +3184,7 @@ Tcl_TraceVar(
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3186,7 +3221,7 @@ Tcl_TraceVar2(
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
- ClientData clientData) /* Arbitrary argument to pass to proc. */
+ void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
@@ -3276,7 +3311,7 @@ TraceVarEx(
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
-#ifndef TCL_REMOVE_OBSOLETE_TRACES
+#ifndef TCL_NO_DEPRECATED
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr->flags = tracePtr->flags & flagMask;
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index eb45735..76a8235 100644
--- a/generic/tclUniData.c
+++ b/generic/tclUniData.c
@@ -5,7 +5,7 @@
* automatically generated by the tools/uniParse.tcl script. Do not
* modify this file by hand.
*
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright © 1998 Scriptics Corporation.
* All rights reserved.
*/
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 9f32fcf..1ac7475 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -3,7 +3,7 @@
*
* Routines for manipulating UTF-8 strings.
*
- * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright © 1997-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.
@@ -55,7 +55,7 @@
#define UNICODE_SELF 0x80
/*
- * The following structures are used when mapping between Unicode (UCS-2) and
+ * The following structures are used when mapping between Unicode and
* UTF-8.
*/
@@ -67,13 +67,7 @@ static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
- 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
- 4,4,4,4,4,
-#else
- 1,1,1,1,1,
-#endif
- 1,1,1,1,1,1,1,1,1,1,1
+ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};
static const unsigned char complete[256] = {
@@ -86,30 +80,19 @@ static const unsigned char complete[256] = {
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
- 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
- 4,4,4,4,4,
-#else
- /* Tcl_UtfToUniChar() accesses src[1] and src[2] to check whether
- * the UTF-8 sequence is valid, so we cannot use 1 here. */
- 3,3,3,3,3,
-#endif
- 1,1,1,1,1,1,1,1,1,1,1
+ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1
};
-
+
/*
* Functions used only in this module.
*/
-static int UtfCount(int ch);
static int Invalid(const char *src);
-static int UCS4ToUpper(int ch);
-static int UCS4ToTitle(int ch);
/*
*---------------------------------------------------------------------------
*
- * UtfCount --
+ * TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
@@ -122,8 +105,8 @@ static int UCS4ToTitle(int ch);
*---------------------------------------------------------------------------
*/
-static inline int
-UtfCount(
+int
+TclUtfCount(
int ch) /* The Unicode character whose size is returned. */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
@@ -132,11 +115,9 @@ UtfCount(
if (ch <= 0x7FF) {
return 2;
}
-#if TCL_UTF_MAX > 3
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
-#endif
return 3;
}
@@ -174,13 +155,8 @@ static const unsigned char bounds[28] = {
0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */
0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
-#if TCL_UTF_MAX > 3
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
-#else
- 0xC0, 0xBF, /* Not used, but reject all again for safety. */
- 0xC0, 0xBF /* Not used, but reject all again for safety. */
-#endif
};
static int
@@ -209,6 +185,17 @@ Invalid(
* Stores the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
*
+ * Surrogate pairs are handled as follows: When ch is a high surrogate,
+ * the first byte of the 4-byte UTF-8 sequence is stored in the buffer and
+ * the function returns 1. If the function is called again with a low
+ * surrogate and the same buffer, the remaining 3 bytes of the 4-byte
+ * UTF-8 sequence are produced.
+ *
+ * If no low surrogate follows the high surrogate (which is actually
+ * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf
+ * again with ch = -1. This produces a 3-byte UTF-8 sequence
+ * representing the high surrogate.
+ *
* Results:
* Returns the number of bytes stored into the buffer.
*
@@ -225,7 +212,7 @@ Tcl_UniCharToUtf(
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 TCL_UTF_MAX bytes). */
+ * (at most 4 bytes). */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
@@ -238,7 +225,6 @@ Tcl_UniCharToUtf(
return 2;
}
if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX > 3
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x0400) {
/* Low surrogate */
@@ -261,11 +247,8 @@ Tcl_UniCharToUtf(
return 1;
}
}
-#endif
goto three;
}
-
-#if TCL_UTF_MAX > 3
if (ch <= 0x10FFFF) {
buf[3] = (char) (0x80 | (0x3F & ch));
buf[2] = (char) (0x80 | (0x3F & (ch >> 6)));
@@ -286,7 +269,6 @@ Tcl_UniCharToUtf(
buf[-1] = (char) (0xE0 | (ch >> 12));
return 2;
}
-#endif
}
ch = 0xFFFD;
@@ -315,25 +297,35 @@ three:
*---------------------------------------------------------------------------
*/
+#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
- const Tcl_UniChar *uniStr, /* Unicode string to convert to UTF-8. */
- int uniLength, /* Length of Unicode string in Tcl_UniChars
- * (must be >= 0). */
+ const int *uniStr, /* Unicode string to convert to UTF-8. */
+ int uniLength, /* Length of Unicode string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
- const Tcl_UniChar *w, *wEnd;
+ const int *w, *wEnd;
char *p, *string;
int oldLength;
/*
- * UTF-8 string length in bytes will be <= Unicode string length *
- * TCL_UTF_MAX.
+ * UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
+ if (uniStr == NULL) {
+ return NULL;
+ }
+ if (uniLength < 0) {
+ uniLength = 0;
+ w = uniStr;
+ while (*w != '\0') {
+ uniLength++;
+ w++;
+ }
+ }
oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * TCL_UTF_MAX);
+ Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
@@ -347,6 +339,59 @@ Tcl_UniCharToUtfDString(
return string;
}
+char *
+Tcl_Char16ToUtfDString(
+ const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
+ int uniLength, /* Length of Utf-16 string. */
+ Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
+ * to this previously initialized DString. */
+{
+ const unsigned short *w, *wEnd;
+ char *p, *string;
+ int oldLength, len = 1;
+
+ /*
+ * UTF-8 string length in bytes will be <= Utf16 string length * 3.
+ */
+
+ if (uniStr == NULL) {
+ return NULL;
+ }
+ if (uniLength < 0) {
+
+ uniLength = 0;
+ w = uniStr;
+ while (*w != '\0') {
+ uniLength++;
+ w++;
+ }
+ }
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3);
+ string = Tcl_DStringValue(dsPtr) + oldLength;
+
+ 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, p);
+ p += len;
+ if ((*w >= 0xD800) && (len < 3)) {
+ len = 0; /* Indication that high surrogate was found */
+ }
+ w++;
+ }
+ if (!len) {
+ /* Special case for handling high surrogates. */
+ p += Tcl_UniCharToUtf(-1, p);
+ }
+ Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
+
+ return string;
+}
/*
*---------------------------------------------------------------------------
*
@@ -363,7 +408,7 @@ Tcl_UniCharToUtfDString(
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
- * If TCL_UTF_MAX <= 4, special handling of Surrogate pairs is done:
+ * Special handling of Surrogate pairs is done:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
@@ -382,27 +427,119 @@ Tcl_UniCharToUtfDString(
*---------------------------------------------------------------------------
*/
+static const unsigned short cp1252[32] = {
+ 0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
+ 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
+ 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
+ 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
+};
+
+#undef Tcl_UtfToUniChar
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
- Tcl_UniChar *chPtr)/* Filled with the Tcl_UniChar represented by
+ int *chPtr)/* Filled with the Unicode character represented by
* the UTF-8 string. */
{
- Tcl_UniChar byte;
+ int byte;
+
+ /*
+ * Unroll 1 to 4 byte UTF-8 sequences.
+ */
+
+ byte = *((unsigned char *) src);
+ if (byte < 0xC0) {
+ /*
+ * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
+ * characters representing themselves.
+ */
+
+ if ((unsigned)(byte-0x80) < (unsigned)0x20) {
+ *chPtr = cp1252[byte-0x80];
+ } else {
+ *chPtr = byte;
+ }
+ return 1;
+ } else if (byte < 0xE0) {
+ if ((byte != 0xC1) && ((src[1] & 0xC0) == 0x80)) {
+ /*
+ * Two-byte-character lead-byte followed by a trail-byte.
+ */
+
+ *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F));
+ if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) {
+ return 2;
+ }
+ }
+
+ /*
+ * A two-byte-character lead-byte not followed by trail-byte
+ * represents itself.
+ */
+ } else if (byte < 0xF0) {
+ if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
+ /*
+ * Three-byte-character lead byte followed by two trail bytes.
+ */
+
+ *chPtr = (((byte & 0x0F) << 12)
+ | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F));
+ if (*chPtr > 0x7FF) {
+ return 3;
+ }
+ }
+
+ /*
+ * 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) {
+ return 4;
+ }
+ }
+
+ /*
+ * A four-byte-character lead-byte not followed by three trail-bytes
+ * represents itself.
+ */
+ }
+
+ *chPtr = byte;
+ return 1;
+}
+
+int
+Tcl_UtfToChar16(
+ const char *src, /* The UTF-8 string. */
+ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
+ * the UTF-8 string. This could be a surrogate too. */
+{
+ unsigned short byte;
/*
- * Unroll 1 to 3 (or 4) byte UTF-8 sequences.
+ * Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
- * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
-#if TCL_UTF_MAX <= 4
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
@@ -415,8 +552,11 @@ Tcl_UtfToUniChar(
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
-#endif
- *chPtr = byte;
+ if ((unsigned)(byte-0x80) < (unsigned)0x20) {
+ *chPtr = cp1252[byte-0x80];
+ } else {
+ *chPtr = byte;
+ }
return 1;
} else if (byte < 0xE0) {
if ((byte != 0xC1) && ((src[1] & 0xC0) == 0x80)) {
@@ -457,7 +597,6 @@ Tcl_UtfToUniChar(
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
-#if TCL_UTF_MAX <= 4
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high < 0x400) {
@@ -466,15 +605,6 @@ Tcl_UtfToUniChar(
return 1;
}
/* out of range, < 0x10000 or > 0x10FFFF */
-#else
- if ((src[3] & 0xC0) == 0x80) {
- *chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
- | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
- if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
- return 4;
- }
- }
-#endif
}
/*
@@ -505,7 +635,8 @@ Tcl_UtfToUniChar(
*---------------------------------------------------------------------------
*/
-Tcl_UniChar *
+#undef Tcl_UtfToUniCharDString
+int *
Tcl_UtfToUniCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
@@ -514,7 +645,7 @@ Tcl_UtfToUniCharDString(
* appended to this previously initialized
* DString. */
{
- Tcl_UniChar ch = 0, *w, *wString;
+ int ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
@@ -522,6 +653,9 @@ Tcl_UtfToUniCharDString(
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
+ if (src == NULL) {
+ return NULL;
+ }
if (length < 0) {
length = strlen(src);
}
@@ -534,20 +668,77 @@ Tcl_UtfToUniCharDString(
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
- oldLength + ((length + 1) * sizeof(Tcl_UniChar)));
- wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
+ oldLength + ((length + 1) * sizeof(int)));
+ wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
- optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3) ;
+ optPtr = endPtr - 4;
while (p <= optPtr) {
- p += TclUtfToUniChar(p, &ch);
+ p += Tcl_UtfToUniChar(p, &ch);
+ *w++ = ch;
+ }
+ while ((p < endPtr) && Tcl_UtfCharComplete(p, endPtr-p)) {
+ p += Tcl_UtfToUniChar(p, &ch);
+ *w++ = ch;
+ }
+ while (p < endPtr) {
+ *w++ = UCHAR(*p++);
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((char *) w - (char *) wString));
+
+ return wString;
+}
+
+unsigned short *
+Tcl_UtfToChar16DString(
+ const char *src, /* UTF-8 string to convert to Unicode. */
+ int length, /* Length of UTF-8 string in bytes, or -1 for
+ * strlen(). */
+ Tcl_DString *dsPtr) /* Unicode representation of string is
+ * appended to this previously initialized
+ * DString. */
+{
+ unsigned short ch = 0, *w, *wString;
+ const char *p;
+ int oldLength;
+ /* Pointer to the end of string. Never read endPtr[0] */
+ const char *endPtr = src + length;
+ /* Pointer to last byte where optimization still can be used */
+ const char *optPtr = endPtr - TCL_UTF_MAX;
+
+ if (src == NULL) {
+ return NULL;
+ }
+ if (length < 0) {
+ length = strlen(src);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
+ * bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+
+ Tcl_DStringSetLength(dsPtr,
+ oldLength + ((length + 1) * sizeof(unsigned short)));
+ wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ p = src;
+ endPtr = src + length;
+ optPtr = endPtr - 3;
+ while (p <= optPtr) {
+ p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
if (Tcl_UtfCharComplete(p, endPtr-p)) {
- p += TclUtfToUniChar(p, &ch);
+ p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
@@ -607,7 +798,7 @@ Tcl_UtfCharComplete(
*/
int
-Tcl_NumUtfChars(
+TclNumUtfChars(
const char *src, /* The UTF-8 string to measure. */
int length) /* The length of the string in bytes, or -1
* for strlen(string). */
@@ -627,7 +818,7 @@ Tcl_NumUtfChars(
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
- const char *optPtr = endPtr - ((TCL_UTF_MAX > 3) ? 4 : 3);
+ const char *optPtr = endPtr - 4;
/*
* Optimize away the call in this loop. Justified because...
@@ -658,6 +849,60 @@ Tcl_NumUtfChars(
return i;
}
+#if !defined(TCL_NO_DEPRECATED)
+int
+Tcl_NumUtfChars(
+ const char *src, /* The UTF-8 string to measure. */
+ int length) /* The length of the string in bytes, or -1
+ * for strlen(string). */
+{
+ unsigned short ch = 0;
+ int i = 0;
+
+ if (length < 0) {
+ /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
+ while ((*src != '\0') && (i < INT_MAX)) {
+ src += Tcl_UtfToChar16(src, &ch);
+ i++;
+ }
+ } else {
+ /* Will return value between 0 and length. No overflow checks. */
+
+ /* Pointer to the end of string. Never read endPtr[0] */
+ const char *endPtr = src + length;
+ /* Pointer to last byte where optimization still can be used */
+ const char *optPtr = endPtr - 4;
+
+ /*
+ * Optimize away the call in this loop. Justified because...
+ * when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr)
+ * By initialization above (endPtr - optPtr) = TCL_UTF_MAX
+ * So (endPtr - src) >= TCL_UTF_MAX, and passing that to
+ * Tcl_UtfCharComplete we know will cause return of 1.
+ */
+ while (src <= optPtr
+ /* && Tcl_UtfCharComplete(src, endPtr - src) */ ) {
+ src += Tcl_UtfToChar16(src, &ch);
+ i++;
+ }
+ /* Loop over the remaining string where call must happen */
+ while (src < endPtr) {
+ if (Tcl_UtfCharComplete(src, endPtr - src)) {
+ src += Tcl_UtfToChar16(src, &ch);
+ } else {
+ /*
+ * src points to incomplete UTF-8 sequence
+ * Treat first byte as character and count it
+ */
+ src++;
+ }
+ i++;
+ }
+ }
+ return i;
+}
+#endif
+
/*
*---------------------------------------------------------------------------
*
@@ -683,7 +928,7 @@ Tcl_UtfFindFirst(
int ch) /* The Unicode character to search for. */
{
while (1) {
- int find, len = TclUtfToUCS4(src, &find);
+ int find, len = Tcl_UtfToUniChar(src, &find);
if (find == ch) {
return src;
@@ -722,7 +967,7 @@ Tcl_UtfFindLast(
const char *last = NULL;
while (1) {
- int find, len = TclUtfToUCS4(src, &find);
+ int find, len = Tcl_UtfToUniChar(src, &find);
if (find == ch) {
last = src;
@@ -763,7 +1008,6 @@ Tcl_UtfNext(
int left;
const char *next;
-#if TCL_UTF_MAX > 3
if (((*src) & 0xC0) == 0x80) {
/* Continuation byte, so we start 'inside' a (possible valid) UTF-8
* sequence. Since we are not allowed to access src[-1], we cannot
@@ -774,7 +1018,6 @@ Tcl_UtfNext(
}
return src;
}
-#endif
left = totalBytes[UCHAR(*src)];
next = src + 1;
@@ -905,10 +1148,10 @@ Tcl_UtfPrev(
/* Continue the search backwards... */
look--;
- } while (trailBytesSeen < (TCL_UTF_MAX < 4 ? 3 : 4));
+ } while (trailBytesSeen < 4);
/*
- * We've seen 3 trail bytes, so we know there will not be a
+ * We've seen 4 trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
* accepting the fallback.
*/
@@ -920,7 +1163,7 @@ Tcl_UtfPrev(
*
* Tcl_UniCharAtIndex --
*
- * Returns the Tcl_UniChar represented at the specified character
+ * Returns the Unicode character represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
@@ -932,17 +1175,27 @@ Tcl_UtfPrev(
*---------------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
int index) /* The position of the desired character. */
{
- Tcl_UniChar ch = 0;
+ unsigned short ch = 0;
+ int i = 0;
- while (index-- >= 0) {
- src += TclUtfToUniChar(src, &ch);
+ if (index < 0) {
+ return -1;
}
- return ch;
+ while (index-- > 0) {
+ i = Tcl_UtfToChar16(src, &ch);
+ src += i;
+ }
+ if ((ch >= 0xD800) && (i < 3)) {
+ /* Index points at character following high Surrogate */
+ return -1;
+ }
+ Tcl_UtfToUniChar(src, &i);
+ return i;
}
/*
@@ -963,26 +1216,43 @@ Tcl_UniCharAtIndex(
*/
const char *
+TclUtfAtIndex(
+ const char *src, /* The UTF-8 string. */
+ int index) /* The position of the desired character. */
+{
+ Tcl_UniChar ch = 0;
+ int len = 0;
+
+ while (index-- > 0) {
+ len = (Tcl_UtfToUniChar)(src, &ch);
+ src += len;
+ }
+ return src;
+}
+
+#if !defined(TCL_NO_DEPRECATED)
+const char *
Tcl_UtfAtIndex(
const char *src, /* The UTF-8 string. */
int index) /* The position of the desired character. */
{
- Tcl_UniChar ch = 0;
+ unsigned short ch = 0;
int len = 0;
while (index-- > 0) {
- len = TclUtfToUniChar(src, &ch);
+ len = Tcl_UtfToChar16(src, &ch);
src += len;
}
-#if TCL_UTF_MAX == 4
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
- src += TclUtfToUniChar(src, &ch);
+ src += Tcl_UtfToChar16(src, &ch);
}
-#endif
return src;
}
-
+
+
+#endif
+
/*
*---------------------------------------------------------------------------
*
@@ -992,7 +1262,7 @@ Tcl_UtfAtIndex(
*
* Results:
* Stores the bytes represented by the backslash sequence in dst and
- * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes
+ * returns the number of bytes written to dst. At most 4 bytes
* are written to dst; dst must have been large enough to accept those
* bytes. If readPtr isn't NULL then it is filled in with a count of the
* number of bytes in the backslash sequence.
@@ -1068,8 +1338,8 @@ Tcl_UtfToUpper(
src = dst = str;
while (*src) {
- len = TclUtfToUCS4(src, &ch);
- upChar = UCS4ToUpper(ch);
+ len = Tcl_UtfToUniChar(src, &ch);
+ upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1077,11 +1347,11 @@ Tcl_UtfToUpper(
* char to dst if its size is <= the original char.
*/
- if (len < UtfCount(upChar)) {
+ if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(upChar, dst);
+ dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
@@ -1121,8 +1391,8 @@ Tcl_UtfToLower(
src = dst = str;
while (*src) {
- len = TclUtfToUCS4(src, &ch);
- lowChar = TclUCS4ToLower(ch);
+ len = Tcl_UtfToUniChar(src, &ch);
+ lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -1130,11 +1400,11 @@ Tcl_UtfToLower(
* char to dst if its size is <= the original char.
*/
- if (len < UtfCount(lowChar)) {
+ if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(lowChar, dst);
+ dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
@@ -1177,30 +1447,30 @@ Tcl_UtfToTitle(
src = dst = str;
if (*src) {
- len = TclUtfToUCS4(src, &ch);
- titleChar = UCS4ToTitle(ch);
+ len = Tcl_UtfToUniChar(src, &ch);
+ titleChar = Tcl_UniCharToTitle(ch);
- if (len < UtfCount(titleChar)) {
+ if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(titleChar, dst);
+ dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
- len = TclUtfToUCS4(src, &ch);
+ len = Tcl_UtfToUniChar(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
- lowChar = TclUCS4ToLower(lowChar);
+ lowChar = Tcl_UniCharToLower(lowChar);
}
- if (len < UtfCount(lowChar)) {
+ if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
- dst += TclUCS4ToUtf(lowChar, dst);
+ dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
@@ -1296,16 +1566,6 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
- /* Surrogates always report higher than non-surrogates */
- if (((ch1 & 0xFC00) == 0xD800)) {
- if ((ch2 & 0xFC00) != 0xD800) {
- return ch1;
- }
- } else if ((ch2 & 0xFC00) == 0xD800) {
- return -ch2;
- }
-#endif
return (ch1 - ch2);
}
}
@@ -1347,16 +1607,6 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
- /* Surrogates always report higher than non-surrogates */
- if (((ch1 & 0xFC00) == 0xD800)) {
- if ((ch2 & 0xFC00) != 0xD800) {
- return ch1;
- }
- } else if ((ch2 & 0xFC00) == 0xD800) {
- return -ch2;
- }
-#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
@@ -1366,6 +1616,42 @@ Tcl_UtfNcasecmp(
}
return 0;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfCmp --
+ *
+ * Compare UTF chars of string cs to string ct case sensitively.
+ * Replacement for strcmp in Tcl core, in places where UTF-8 should
+ * be handled.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCmp(
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct) /* UTF string cs is compared to. */
+{
+ Tcl_UniChar ch1 = 0, ch2 = 0;
+
+ while (*cs && *ct) {
+ cs += TclUtfToUniChar(cs, &ch1);
+ ct += TclUtfToUniChar(ct, &ch2);
+ if (ch1 != ch2) {
+ return ch1 - ch2;
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
/*
*----------------------------------------------------------------------
@@ -1396,16 +1682,6 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
- /* Surrogates always report higher than non-surrogates */
- if (((ch1 & 0xFC00) == 0xD800)) {
- if ((ch2 & 0xFC00) != 0xD800) {
- return ch1;
- }
- } else if ((ch2 & 0xFC00) == 0xD800) {
- return -ch2;
- }
-#endif
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
@@ -1433,8 +1709,8 @@ TclUtfCasecmp(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToUpper(
+int
+Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1447,13 +1723,6 @@ UCS4ToUpper(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
-
-Tcl_UniChar
-Tcl_UniCharToUpper(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) UCS4ToUpper(ch);
-}
/*
*----------------------------------------------------------------------
@@ -1472,7 +1741,7 @@ Tcl_UniCharToUpper(
*/
int
-TclUCS4ToLower(
+Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1487,13 +1756,6 @@ TclUCS4ToLower(
return ch & 0x1FFFFF;
}
-Tcl_UniChar
-Tcl_UniCharToLower(
- int ch) /* Unicode character to convert. */
-{
- return (Tcl_UniChar) TclUCS4ToLower(ch);
-}
-
/*
*----------------------------------------------------------------------
*
@@ -1510,8 +1772,8 @@ Tcl_UniCharToLower(
*----------------------------------------------------------------------
*/
-static int
-UCS4ToTitle(
+int
+Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
if (!UNICODE_OUT_OF_RANGE(ch)) {
@@ -1533,14 +1795,37 @@ UCS4ToTitle(
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Char16Len --
+ *
+ * Find the length of a UniChar string. The str input must be null
+ * terminated.
+ *
+ * Results:
+ * Returns the length of str in UniChars (not bytes).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
-Tcl_UniChar
-Tcl_UniCharToTitle(
- int ch) /* Unicode character to convert. */
+int
+Tcl_Char16Len(
+ const unsigned short *uniStr) /* Unicode string to find length of. */
{
- return (Tcl_UniChar) UCS4ToTitle(ch);
+ int len = 0;
+
+ while (*uniStr != '\0') {
+ len++;
+ uniStr++;
+ }
+ return len;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -1558,9 +1843,10 @@ Tcl_UniCharToTitle(
*----------------------------------------------------------------------
*/
+#undef Tcl_UniCharLen
int
Tcl_UniCharLen(
- const Tcl_UniChar *uniStr) /* Unicode string to find length of. */
+ const int *uniStr) /* Unicode string to find length of. */
{
int len = 0;
@@ -1589,12 +1875,40 @@ Tcl_UniCharLen(
*/
int
-Tcl_UniCharNcmp(
+TclUniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of unichars to compare. */
{
-#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4)
+#if defined(WORDS_BIGENDIAN)
+ /*
+ * We are definitely on a big-endian machine; memcmp() is safe
+ */
+
+ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
+
+#else /* !WORDS_BIGENDIAN */
+ /*
+ * We can't simply call memcmp() because that is not lexically correct.
+ */
+
+ for ( ; numChars != 0; ucs++, uct++, numChars--) {
+ if (*ucs != *uct) {
+ return (*ucs - *uct);
+ }
+ }
+ return 0;
+#endif /* WORDS_BIGENDIAN */
+}
+
+#if !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharNcmp(
+ const unsigned short *ucs, /* Unicode string to compare to uct. */
+ const unsigned short *uct, /* Unicode string ucs is compared to. */
+ unsigned long numChars) /* Number of unichars to compare. */
+{
+#if defined(WORDS_BIGENDIAN)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
@@ -1608,21 +1922,19 @@ Tcl_UniCharNcmp(
for ( ; numChars != 0; ucs++, uct++, numChars--) {
if (*ucs != *uct) {
-#if TCL_UTF_MAX == 4
/* special case for handling upper surrogates */
if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) {
return 1;
} else if (((*uct & 0xFC00) == 0xD800)) {
return -1;
}
-#endif
return (*ucs - *uct);
}
}
return 0;
#endif /* WORDS_BIGENDIAN */
}
-
+#endif
/*
*----------------------------------------------------------------------
*
@@ -1642,31 +1954,51 @@ Tcl_UniCharNcmp(
*/
int
-Tcl_UniCharNcasecmp(
+TclUniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of Unichars to compare. */
{
for ( ; numChars != 0; numChars--, ucs++, uct++) {
if (*ucs != *uct) {
- Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
- Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
+ int lcs = Tcl_UniCharToLower(*ucs);
+ int lct = Tcl_UniCharToLower(*uct);
+
+ if (lcs != lct) {
+ return (lcs - lct);
+ }
+ }
+ }
+ return 0;
+}
+
+#if !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharNcasecmp(
+ const unsigned short *ucs, /* Unicode string to compare to uct. */
+ const unsigned short *uct, /* Unicode string ucs is compared to. */
+ unsigned long numChars) /* Number of unichars to compare. */
+{
+ for ( ; numChars != 0; numChars--, ucs++, uct++) {
+ if (*ucs != *uct) {
+ unsigned short lcs = Tcl_UniCharToLower(*ucs);
+ unsigned short lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
-#if TCL_UTF_MAX == 4
/* special case for handling upper surrogates */
if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) {
return 1;
} else if (((lct & 0xFC00) == 0xD800)) {
return -1;
}
-#endif
return (lcs - lct);
}
}
}
return 0;
}
+#endif
+
/*
*----------------------------------------------------------------------
@@ -1688,11 +2020,9 @@ int
Tcl_UniCharIsAlnum(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
@@ -1716,11 +2046,9 @@ int
Tcl_UniCharIsAlpha(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
@@ -1744,7 +2072,6 @@ int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
/* Clear away extension bits, if any */
ch &= 0x1FFFFF;
@@ -1756,7 +2083,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1780,11 +2106,9 @@ int
Tcl_UniCharIsDigit(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
@@ -1808,11 +2132,9 @@ int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
-#endif
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
@@ -1836,11 +2158,9 @@ int
Tcl_UniCharIsLower(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == LOWERCASE_LETTER);
}
@@ -1864,11 +2184,9 @@ int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
-#endif
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
@@ -1892,11 +2210,9 @@ int
Tcl_UniCharIsPunct(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
@@ -1920,13 +2236,8 @@ int
Tcl_UniCharIsSpace(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
/* Ignore upper 11 bits. */
ch &= 0x1FFFFF;
-#else
- /* Ignore upper 16 bits. */
- ch &= 0xFFFF;
-#endif
/*
* If the character is within the first 127 characters, just use the
@@ -1935,10 +2246,8 @@ Tcl_UniCharIsSpace(
if (ch < 0x80) {
return TclIsSpaceProcM((char) ch);
-#if TCL_UTF_MAX > 3
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
-#endif
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
@@ -1967,17 +2276,45 @@ int
Tcl_UniCharIsUpper(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == UPPERCASE_LETTER);
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_UniCharIsUnicode --
+ *
+ * Test if a character is a Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character belongs to the Unicode set.
+ *
+ * Excluded are:
+ * 1) All characters > U+10FFFF
+ * 2) Surrogates U+D800 - U+DFFF
+ * 3) Last 2 characters of each plane, so U+??FFFE and U+??FFFF
+ * 4) The characters in the range U+FDD0 - U+FDEF
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsUnicode(
+ int ch) /* Unicode character to test. */
+{
+ return ((unsigned int)ch <= 0x10FFFF) && ((ch & 0xFFF800) != 0xD800)
+ && ((ch & 0xFFFE) != 0xFFFE) && ((unsigned int)(ch - 0xFDD0) >= 32);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UniCharIsWordChar --
*
* Test if a character is alphanumeric or a connector punctuation mark.
@@ -1995,11 +2332,9 @@ int
Tcl_UniCharIsWordChar(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((WORD_BITS >> GetCategory(ch)) & 1);
}
@@ -2027,14 +2362,182 @@ Tcl_UniCharIsWordChar(
*/
int
-Tcl_UniCharCaseMatch(
+TclUniCharCaseMatch(
const Tcl_UniChar *uniStr, /* Unicode String. */
const Tcl_UniChar *uniPattern,
/* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
- Tcl_UniChar ch1 = 0, p;
+ int ch1 = 0, p;
+
+ while (1) {
+ p = *uniPattern;
+
+ /*
+ * See if we're at the end of both the pattern and the string. If so,
+ * we succeeded. If we're at the end of the pattern but not at the end
+ * of the string, we failed.
+ */
+
+ if (p == 0) {
+ return (*uniStr == 0);
+ }
+ if ((*uniStr == 0) && (p != '*')) {
+ return 0;
+ }
+
+ /*
+ * Check for a "*" as the next pattern character. It matches any
+ * substring. We handle this by skipping all the characters up to the
+ * next matching one in the pattern, and then calling ourselves
+ * recursively for each postfix of string, until either we match or we
+ * reach the end of the string.
+ */
+
+ if (p == '*') {
+ /*
+ * Skip all successive *'s in the pattern
+ */
+
+ while (*(++uniPattern) == '*') {
+ /* empty body */
+ }
+ p = *uniPattern;
+ if (p == 0) {
+ return 1;
+ }
+ if (nocase) {
+ p = Tcl_UniCharToLower(p);
+ }
+ while (1) {
+ /*
+ * Optimization for matching - cruise through the string
+ * quickly if the next char in the pattern isn't a special
+ * character
+ */
+
+ if ((p != '[') && (p != '?') && (p != '\\')) {
+ if (nocase) {
+ while (*uniStr && (p != *uniStr)
+ && (p != Tcl_UniCharToLower(*uniStr))) {
+ uniStr++;
+ }
+ } else {
+ while (*uniStr && (p != *uniStr)) {
+ uniStr++;
+ }
+ }
+ }
+ if (TclUniCharCaseMatch(uniStr, uniPattern, nocase)) {
+ return 1;
+ }
+ if (*uniStr == 0) {
+ return 0;
+ }
+ uniStr++;
+ }
+ }
+
+ /*
+ * Check for a "?" as the next pattern character. It matches any
+ * single character.
+ */
+
+ if (p == '?') {
+ uniPattern++;
+ uniStr++;
+ continue;
+ }
+
+ /*
+ * Check for a "[" as the next pattern character. It is followed by a
+ * list of characters that are acceptable, or by a range (two
+ * characters separated by "-").
+ */
+
+ if (p == '[') {
+ int startChar, endChar;
+
+ uniPattern++;
+ ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
+ uniStr++;
+ while (1) {
+ if ((*uniPattern == ']') || (*uniPattern == 0)) {
+ return 0;
+ }
+ startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
+ : *uniPattern);
+ uniPattern++;
+ if (*uniPattern == '-') {
+ uniPattern++;
+ if (*uniPattern == 0) {
+ return 0;
+ }
+ endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
+ : *uniPattern);
+ uniPattern++;
+ if (((startChar <= ch1) && (ch1 <= endChar))
+ || ((endChar <= ch1) && (ch1 <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+ break;
+ }
+ } else if (startChar == ch1) {
+ break;
+ }
+ }
+ while (*uniPattern != ']') {
+ if (*uniPattern == 0) {
+ uniPattern--;
+ break;
+ }
+ uniPattern++;
+ }
+ uniPattern++;
+ continue;
+ }
+
+ /*
+ * If the next pattern character is '\', just strip off the '\' so we
+ * do exact matching on the character that follows.
+ */
+
+ if (p == '\\') {
+ if (*(++uniPattern) == '\0') {
+ return 0;
+ }
+ }
+
+ /*
+ * There's no special character. Just make sure that the next bytes of
+ * each string match.
+ */
+
+ if (nocase) {
+ if (Tcl_UniCharToLower(*uniStr) !=
+ Tcl_UniCharToLower(*uniPattern)) {
+ return 0;
+ }
+ } else if (*uniStr != *uniPattern) {
+ return 0;
+ }
+ uniStr++;
+ uniPattern++;
+ }
+}
+
+#if !defined(TCL_NO_DEPRECATED)
+int
+Tcl_UniCharCaseMatch(
+ const unsigned short *uniStr, /* Unicode String. */
+ const unsigned short *uniPattern,
+ /* Pattern, which may contain special
+ * characters. */
+ int nocase) /* 0 for case sensitive, 1 for insensitive */
+{
+ unsigned short ch1 = 0, p;
while (1) {
p = *uniPattern;
@@ -2122,7 +2625,7 @@ Tcl_UniCharCaseMatch(
*/
if (p == '[') {
- Tcl_UniChar startChar, endChar;
+ unsigned short startChar, endChar;
uniPattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
@@ -2192,7 +2695,9 @@ Tcl_UniCharCaseMatch(
uniPattern++;
}
}
+#endif
+
/*
*----------------------------------------------------------------------
*
@@ -2385,119 +2890,6 @@ TclUniCharMatch(
}
/*
- *---------------------------------------------------------------------------
- *
- * TclUtfToUCS4 --
- *
- * Extracts the 4-byte codepoint from the leading bytes of the
- * Modified UTF-8 string "src". This is a utility routine to
- * contain the surrogate gymnastics in one place.
- *
- * The caller must ensure that the source buffer is long enough that this
- * routine does not run off the end and dereference non-existent memory
- * looking for trail bytes. If the source buffer is known to be '\0'
- * terminated, this cannot happen. Otherwise, the caller should call
- * TclUCS4Complete() before calling this routine to ensure that
- * enough bytes remain in the string.
- *
- * Results:
- * Fills *usc4Ptr with the UCS4 code point and returns the number of bytes
- * consumed from the source string.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclUtfToUCS4(
- const char *src, /* The UTF-8 string. */
- int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
- * by the UTF-8 string. */
-{
- Tcl_UniChar ch = 0;
- int len = Tcl_UtfToUniChar(src, &ch);
-
-#if TCL_UTF_MAX <= 4
- if ((ch & ~0x3FF) == 0xD800) {
- Tcl_UniChar low = ch;
- int len2 = Tcl_UtfToUniChar(src+len, &low);
- if ((low & ~0x3FF) == 0xDC00) {
- *ucs4Ptr = (((ch & 0x3FF) << 10) | (low & 0x3FF)) + 0x10000;
- return len + len2;
- }
- }
-#endif
- *ucs4Ptr = (int)ch;
- return len;
-}
-
-#if TCL_UTF_MAX == 4
-int
-TclUniCharToUCS4(
- const Tcl_UniChar *src, /* The Tcl_UniChar string. */
- int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
- * by the Tcl_UniChar string. */
-{
- if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
- *ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000;
- return 2;
- }
- *ucs4Ptr = src[0];
- return 1;
-}
-#endif
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclUCS4ToUtf --
- *
- * Store the given Unicode character as a sequence of UTF-8 bytes in the
- * provided buffer. Might output 6 bytes, if the code point > 0xFFFF.
- *
- * Results:
- * The return values is the number of bytes in the buffer that were
- * consumed. If ch == -1, this function outputs 0 bytes (empty string),
- * since TclGetUCS4 returns -1 for out-of-range indices.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclUCS4ToUtf(
- int ch, /* Unicode character to be stored in the
- * buffer. */
- char *buf) /* Buffer in which the UTF-8 representation of
- * the Unicode character is stored. Buffer must be
- * large enough to hold the UTF-8 character(s)
- * (at most 6 bytes). */
-{
-#if TCL_UTF_MAX <= 4
- if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
- /* Spit out a 4-byte UTF-8 character or 2 x 3-byte UTF-8 characters, depending on Tcl
- * version and/or TCL_UTF_MAX build value */
- int len = Tcl_UniCharToUtf(0xD800 | ((ch - 0x10000) >> 10), buf);
- return len + Tcl_UniCharToUtf(0xDC00 | (ch & 0x7FF), buf + len);
- }
-#endif
- if ((ch & ~0x7FF) == 0xD800) {
- buf[2] = (char) ((ch | 0x80) & 0xBF);
- buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
- buf[0] = (char) ((ch >> 12) | 0xE0);
- return 3;
- }
- if (ch == -1) {
- return 0;
- }
- return Tcl_UniCharToUtf(ch, buf);
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index ddcb254..30fb89d 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -4,9 +4,9 @@
* This file contains utility functions that are used by many Tcl
* commands.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1998 Sun Microsystems, Inc.
- * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright © 1987-1993 The Regents of the University of California.
+ * Copyright © 1994-1998 Sun Microsystems, Inc.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
+#include "tclTomMath.h"
#include <math.h>
/*
@@ -105,32 +106,35 @@ static Tcl_ThreadDataKey precisionKey;
*/
static void ClearHash(Tcl_HashTable *tablePtr);
-static void FreeProcessGlobalValue(ClientData clientData);
-static void FreeThreadHash(ClientData clientData);
-static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue,
- int *indexPtr);
+static void FreeProcessGlobalValue(void *clientData);
+static void FreeThreadHash(void *clientData);
+static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideInt endValue, Tcl_WideInt *indexPtr);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
-static int SetEndOffsetFromAny(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
+static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideInt endValue, Tcl_WideInt *widePtr);
static int FindElement(Tcl_Interp *interp, const char *string,
- int stringLength, const char *typeStr,
+ Tcl_Size stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
- const char **nextPtr, int *sizePtr,
+ const char **nextPtr, Tcl_Size *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 TclGetIntForIndex. The internal rep is an
- * integer, so no memory management is required for it.
+ * performance optimization in Tcl_GetIntForIndex. The internal rep is
+ * stored directly in the wideValue, so no memory management is required
+ * for it. This is a caching internalrep, keeping the result of a parse
+ * around. This type is only created from a pre-existing string, so an
+ * updateStringProc will never be called and need not exist. The type
+ * is unregistered, so has no need of a setFromAnyProc either.
*/
-const Tcl_ObjType tclEndOffsetType = {
+static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfEndOffset, /* updateStringProc */
- SetEndOffsetFromAny
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
};
/*
@@ -371,10 +375,10 @@ const Tcl_ObjType tclEndOffsetType = {
*
* Given 'bytes' pointing to 'numBytes' bytes, scan through them and
* count the number of whitespace runs that could be list element
- * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a
- * full list parser. Typically used to get a quick and dirty overestimate
- * of length size in order to allocate space for an actual list parser to
- * operate with.
+ * separators. If 'numBytes' is TCL_INDEX_NONE, scan to the terminating
+ * '\0'. Not a full list parser. Typically used to get a quick and dirty
+ * overestimate of length size in order to allocate space for an actual
+ * list parser to operate with.
*
* Results:
* Returns the largest number of list elements that could possibly be in
@@ -387,15 +391,15 @@ const Tcl_ObjType tclEndOffsetType = {
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclMaxListLength(
const char *bytes,
- int numBytes,
+ Tcl_Size numBytes,
const char **endPtr)
{
- int count = 0;
+ Tcl_Size count = 0;
- if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
+ if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
@@ -411,7 +415,7 @@ TclMaxListLength(
*/
while (numBytes) {
- if ((numBytes == -1) && (*bytes == '\0')) {
+ if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
@@ -422,9 +426,9 @@ TclMaxListLength(
count++;
do {
bytes++;
- numBytes -= (numBytes != -1);
+ numBytes -= (numBytes != TCL_INDEX_NONE);
} while (numBytes && TclIsSpaceProcM(*bytes));
- if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
+ if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) {
break;
}
@@ -433,7 +437,7 @@ TclMaxListLength(
*/
}
bytes++;
- numBytes -= (numBytes != -1);
+ numBytes -= (numBytes != TCL_INDEX_NONE);
}
/*
@@ -496,13 +500,13 @@ TclFindElement(
const char *list, /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
- int listLength, /* Number of bytes in the list's string. */
+ Tcl_Size 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). */
- int *sizePtr, /* If non-zero, fill in with size of
+ Tcl_Size *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
@@ -524,14 +528,14 @@ TclFindDictElement(
* containing a Tcl dictionary with zero or
* more keys and values (possibly in
* braces). */
- int dictLength, /* Number of bytes in the dict's string. */
+ Tcl_Size 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). */
- int *sizePtr, /* If non-zero, fill in with size of
+ Tcl_Size *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
@@ -553,7 +557,7 @@ FindElement(
* containing a Tcl list or dictionary with
* zero or more elements (possibly in
* braces). */
- int stringLength, /* Number of bytes in the string. */
+ Tcl_Size 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
@@ -563,7 +567,7 @@ FindElement(
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list/dict). */
- int *sizePtr, /* If non-zero, fill in with size of
+ Tcl_Size *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
@@ -575,10 +579,10 @@ FindElement(
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. */
- int openBraces = 0; /* Brace nesting level during parse. */
+ Tcl_Size openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
- int size = 0;
- int numChars;
+ Tcl_Size size = 0;
+ Tcl_Size numChars;
int literal = 1;
const char *p2;
@@ -652,7 +656,7 @@ FindElement(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -704,7 +708,7 @@ FindElement(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -737,7 +741,7 @@ FindElement(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open brace in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
@@ -745,7 +749,7 @@ FindElement(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unmatched open quote in %s", typeStr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -786,21 +790,23 @@ FindElement(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclCopyAndCollapse(
- int count, /* Number of byte to copy from src. */
+ Tcl_Size count, /* Number of byte to copy from src. */
const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
- int newCount = 0;
+ Tcl_Size newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
- int numRead;
- int backslashCount = TclParseBackslash(src, count, &numRead, dst);
+ char buf[4] = "";
+ Tcl_Size numRead;
+ Tcl_Size backslashCount = TclParseBackslash(src, count, &numRead, buf);
+ memcpy(dst, buf, backslashCount);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
@@ -845,19 +851,21 @@ TclCopyAndCollapse(
*----------------------------------------------------------------------
*/
+#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. */
- int *argcPtr, /* Pointer to location to fill in with the
+ Tcl_Size *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 length, size, i, result, elSize;
+ int result;
+ Tcl_Size length, size, i, elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
@@ -867,7 +875,7 @@ Tcl_SplitList(
* string gets re-purposed to hold '\0' characters in the argv array.
*/
- size = TclMaxListLength(list, -1, &end) + 1;
+ size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1;
length = end - list;
argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1);
@@ -892,7 +900,7 @@ Tcl_SplitList(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
- NULL);
+ (void *)NULL);
}
return TCL_ERROR;
}
@@ -934,13 +942,13 @@ Tcl_SplitList(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
- * Tcl_ConvertCountedElement. */
+ * Tcl_ConvertCountedElement. */
{
- return Tcl_ScanCountedElement(src, -1, flagPtr);
+ return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr);
}
/*
@@ -951,8 +959,8 @@ Tcl_ScanElement(
* This function is a companion function to Tcl_ConvertCountedElement. It
* scans a string to see what needs to be done to it (e.g. add
* backslashes or enclosing braces) to make the string into a valid Tcl
- * list element. If length is -1, then the string is scanned from src up
- * to the first null byte.
+ * list element. If length is TCL_INDEX_NONE, then the string is scanned
+ * from src up to the first null byte.
*
* Results:
* The return value is an overestimate of the number of bytes that will
@@ -966,15 +974,15 @@ Tcl_ScanElement(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
- int length, /* Number of bytes in src, or -1. */
+ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
- int numBytes = TclScanElement(src, length, &flags);
+ Tcl_Size numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
return numBytes;
@@ -988,7 +996,7 @@ Tcl_ScanCountedElement(
* This function is a companion function to TclConvertElement. It scans a
* string to see what needs to be done to it (e.g. add backslashes or
* enclosing braces) to make the string into a valid Tcl list element. If
- * length is -1, then the string is scanned from src up to the first null
+ * length is TCL_INDEX_NONE, then the string is scanned from src up to the first null
* byte. A NULL value for src is treated as an empty string. The incoming
* value of *flagPtr is a report from the caller what additional flags it
* will pass to TclConvertElement().
@@ -1010,23 +1018,23 @@ Tcl_ScanCountedElement(
*----------------------------------------------------------------------
*/
-unsigned int
+TCL_HASH_TYPE
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
- int length, /* Number of bytes in src, or -1. */
+ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
- int nestingLevel = 0; /* Brace nesting count */
+ Tcl_Size 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
+ Tcl_Size extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
- unsigned int bytesNeeded; /* Buffer length computed to complete the
+ TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
@@ -1034,7 +1042,7 @@ TclScanElement(
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
- if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
+ if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) {
/*
* Empty string element must be brace quoted.
*/
@@ -1087,8 +1095,7 @@ TclScanElement(
braceCount++;
#endif /* COMPAT */
extra++; /* Escape '}' => '\}' */
- nestingLevel--;
- if (nestingLevel < 0) {
+ if (nestingLevel-- < 1) {
/*
* Unbalanced braces! Cannot format with brace quoting.
*/
@@ -1117,7 +1124,7 @@ TclScanElement(
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
- if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
+ if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
@@ -1148,7 +1155,7 @@ TclScanElement(
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
@@ -1317,13 +1324,13 @@ TclScanElement(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ConvertElement(
const char *src, /* Source information for list element. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
- return Tcl_ConvertCountedElement(src, -1, dst, flags);
+ return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags);
}
/*
@@ -1347,14 +1354,14 @@ Tcl_ConvertElement(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
- int numBytes = TclConvertElement(src, length, dst, flags);
+ Tcl_Size numBytes = TclConvertElement(src, length, dst, flags);
dst[numBytes] = '\0';
return numBytes;
}
@@ -1380,10 +1387,10 @@ Tcl_ConvertCountedElement(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclConvertElement(
const char *src, /* Source information for list element. */
- int length, /* Number of bytes in src, or -1. */
+ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
@@ -1402,10 +1409,10 @@ TclConvertElement(
* No matter what the caller demands, empty string must be braced!
*/
- if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = tclEmptyStringRep;
- length = 0;
- conversion = CONVERT_BRACE;
+ if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) {
+ p[0] = '{';
+ p[1] = '}';
+ return 2;
}
/*
@@ -1429,7 +1436,7 @@ TclConvertElement(
*/
if (conversion == CONVERT_NONE) {
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
@@ -1448,7 +1455,7 @@ TclConvertElement(
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
- if (length == -1) {
+ if (length == TCL_INDEX_NONE) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
@@ -1459,7 +1466,7 @@ TclConvertElement(
}
*p = '}';
p++;
- return p - dst;
+ return (p - dst);
}
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
@@ -1521,8 +1528,8 @@ TclConvertElement(
p++;
continue;
case '\0':
- if (length == -1) {
- return p - dst;
+ if (length == TCL_INDEX_NONE) {
+ return (p - dst);
}
/*
@@ -1538,7 +1545,7 @@ TclConvertElement(
*p = *src;
p++;
}
- return p - dst;
+ return (p - dst);
}
/*
@@ -1563,12 +1570,12 @@ TclConvertElement(
char *
Tcl_Merge(
- int argc, /* How many strings to merge. */
+ Tcl_Size argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- int i;
+ Tcl_Size i;
unsigned int bytesNeeded = 0;
char *result, *dst;
@@ -1597,7 +1604,7 @@ Tcl_Merge(
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
- bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
+ bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]);
if (bytesNeeded > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
@@ -1615,7 +1622,7 @@ Tcl_Merge(
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
- dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
+ dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
@@ -1627,6 +1634,7 @@ Tcl_Merge(
return result;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -1660,6 +1668,7 @@ Tcl_Backslash(
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1678,14 +1687,14 @@ Tcl_Backslash(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclTrimRight(
const char *bytes, /* String to be trimmed... */
- int numBytes, /* ...and its length in bytes */
+ Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
- int numTrim) /* ...and its length in bytes */
+ Tcl_Size numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
@@ -1703,15 +1712,12 @@ TclTrimRight(
do {
const char *q = trim;
- int pInc = 0, bytesLeft = numTrim;
+ Tcl_Size pInc = 0, bytesLeft = numTrim;
- pp = TclUtfPrev(p, bytes);
-#if TCL_UTF_MAX < 4
- pp = TclUtfPrev(pp, bytes);
-#endif
+ pp = Tcl_UtfPrev(p, bytes);
do {
pp += pInc;
- pInc = TclUtfToUCS4(pp, &ch1);
+ pInc = Tcl_UtfToUniChar(pp, &ch1);
} while (pp + pInc < p);
/*
@@ -1719,7 +1725,7 @@ TclTrimRight(
*/
do {
- pInc = TclUtfToUCS4(q, &ch2);
+ pInc = Tcl_UtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
@@ -1760,14 +1766,14 @@ TclTrimRight(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
- int numBytes, /* ...and its length in bytes */
+ Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
- int numTrim) /* ...and its length in bytes */
+ Tcl_Size numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
@@ -1784,16 +1790,16 @@ TclTrimLeft(
*/
do {
- int pInc = TclUtfToUCS4(p, &ch1);
+ Tcl_Size pInc = Tcl_UtfToUniChar(p, &ch1);
const char *q = trim;
- int bytesLeft = numTrim;
+ Tcl_Size bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
- int qInc = TclUtfToUCS4(q, &ch2);
+ Tcl_Size qInc = Tcl_UtfToUniChar(q, &ch2);
if (ch1 == ch2) {
break;
@@ -1834,19 +1840,19 @@ TclTrimLeft(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclTrim(
const char *bytes, /* String to be trimmed... */
- int numBytes, /* ...and its length in bytes */
+ Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
- int numTrim, /* ...and its length in bytes */
+ Tcl_Size numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
- int *trimRightPtr) /* Offset from the end of the string. */
+ Tcl_Size *trimRightPtr) /* Offset from the end of the string. */
{
- int trimLeft = 0, trimRight = 0;
+ Tcl_Size trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
@@ -1860,7 +1866,7 @@ TclTrim(
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
- bytes += TclUtfToUCS4(first, &ch);
+ bytes += Tcl_UtfToUniChar(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
@@ -1898,10 +1904,10 @@ TclTrim(
char *
Tcl_Concat(
- int argc, /* Number of strings to concatenate. */
+ Tcl_Size argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
- int i, needSpace = 0, bytesNeeded = 0;
+ Tcl_Size i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
@@ -1924,6 +1930,10 @@ Tcl_Concat(
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
}
+
+ /*
+ * All element bytes + (argc - 1) spaces + 1 terminating NULL.
+ */
if (bytesNeeded + argc - 1 < 0) {
/*
* Panic test could be tighter, but not going to bother for this
@@ -1933,14 +1943,10 @@ Tcl_Concat(
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
- /*
- * All element bytes + (argc - 1) spaces + 1 terminating NULL.
- */
-
result = (char *)ckalloc(bytesNeeded + argc);
for (p = result, i = 0; i < argc; i++) {
- int triml, trimr, elemLength;
+ Tcl_Size triml, trimr, elemLength;
const char *element;
element = argv[i];
@@ -1998,10 +2004,11 @@ Tcl_Concat(
Tcl_Obj *
Tcl_ConcatObj(
- int objc, /* Number of objects to concatenate. */
+ Tcl_Size objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
- int i, elemLength, needSpace = 0, bytesNeeded = 0;
+ int needSpace = 0;
+ Tcl_Size i, bytesNeeded = 0, elemLength;
const char *element;
Tcl_Obj *objPtr, *resPtr;
@@ -2012,13 +2019,13 @@ Tcl_ConcatObj(
*/
for (i = 0; i < objc; i++) {
- int length;
+ Tcl_Size length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr)) {
continue;
}
- Tcl_GetStringFromObj(objPtr, &length);
+ TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
@@ -2027,7 +2034,7 @@ Tcl_ConcatObj(
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- if (objPtr->bytes && objPtr->length == 0) {
+ if (!TclListObjIsCanonical(objPtr)) {
continue;
}
if (resPtr) {
@@ -2080,7 +2087,7 @@ Tcl_ConcatObj(
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
- int triml, trimr;
+ Tcl_Size triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
@@ -2114,6 +2121,7 @@ Tcl_ConcatObj(
return resPtr;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -2132,6 +2140,7 @@ Tcl_ConcatObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_StringMatch
int
Tcl_StringMatch(
const char *str, /* String. */
@@ -2140,7 +2149,7 @@ Tcl_StringMatch(
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
-
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
@@ -2212,9 +2221,9 @@ Tcl_StringCaseMatch(
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
- TclUtfToUCS4(pattern, &ch2);
+ Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
- ch2 = TclUCS4ToLower(ch2);
+ ch2 = Tcl_UniCharToLower(ch2);
}
}
@@ -2228,8 +2237,8 @@ Tcl_StringCaseMatch(
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
- charLen = TclUtfToUCS4(str, &ch1);
- if (ch2==ch1 || ch2==TclUCS4ToLower(ch1)) {
+ charLen = Tcl_UtfToUniChar(str, &ch1);
+ if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
@@ -2242,7 +2251,7 @@ Tcl_StringCaseMatch(
*/
while (*str) {
- charLen = TclUtfToUCS4(str, &ch1);
+ charLen = Tcl_UtfToUniChar(str, &ch1);
if (ch2 == ch1) {
break;
}
@@ -2256,7 +2265,7 @@ Tcl_StringCaseMatch(
if (*str == '\0') {
return 0;
}
- str += TclUtfToUCS4(str, &ch1);
+ str += Tcl_UtfToUniChar(str, &ch1);
}
}
@@ -2267,7 +2276,7 @@ Tcl_StringCaseMatch(
if (p == '?') {
pattern++;
- str += TclUtfToUCS4(str, &ch1);
+ str += Tcl_UtfToUniChar(str, &ch1);
continue;
}
@@ -2286,9 +2295,9 @@ Tcl_StringCaseMatch(
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
- str += TclUtfToUCS4(str, &ch1);
+ str += Tcl_UtfToUniChar(str, &ch1);
if (nocase) {
- ch1 = TclUCS4ToLower(ch1);
+ ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
@@ -2300,9 +2309,9 @@ Tcl_StringCaseMatch(
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
- pattern += TclUtfToUCS4(pattern, &startChar);
+ pattern += Tcl_UtfToUniChar(pattern, &startChar);
if (nocase) {
- startChar = TclUCS4ToLower(startChar);
+ startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
@@ -2315,9 +2324,9 @@ Tcl_StringCaseMatch(
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
- pattern += TclUtfToUCS4(pattern, &endChar);
+ pattern += Tcl_UtfToUniChar(pattern, &endChar);
if (nocase) {
- endChar = TclUCS4ToLower(endChar);
+ endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
@@ -2363,10 +2372,10 @@ Tcl_StringCaseMatch(
* each string match.
*/
- str += TclUtfToUCS4(str, &ch1);
- pattern += TclUtfToUCS4(pattern, &ch2);
+ str += Tcl_UtfToUniChar(str, &ch1);
+ pattern += Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
- if (TclUCS4ToLower(ch1) != TclUCS4ToLower(ch2)) {
+ if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
@@ -2398,12 +2407,12 @@ Tcl_StringCaseMatch(
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
- int strLen, /* Length of String */
+ Tcl_Size strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
- int ptnLen, /* Length of Pattern */
- int flags)
+ Tcl_Size ptnLen, /* Length of Pattern */
+ TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
@@ -2579,7 +2588,8 @@ TclStringMatchObj(
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
- int match, length, plen;
+ int match;
+ Tcl_Size length, plen;
/*
* Promote based on the type of incoming object.
@@ -2588,11 +2598,11 @@ TclStringMatchObj(
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
- if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) {
+ if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
- udata = Tcl_GetUnicodeFromObj(strObj, &length);
- uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
+ udata = TclGetUnicodeFromObj(strObj, &length);
+ uptn = TclGetUnicodeFromObj(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
} else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj)
&& !flags) {
@@ -2649,7 +2659,7 @@ Tcl_DStringInit(
* Side effects:
* Length bytes from "bytes" (or all of "bytes" if length is less than
* zero) are added to the current value of the string. Memory gets
- * reallocated if needed to accommodate the string's new size.
+ * reallocated if needed to accomodate the string's new size.
*
*----------------------------------------------------------------------
*/
@@ -2657,13 +2667,13 @@ Tcl_DStringInit(
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
- const char *bytes, /* String to append. If length is -1 then this
- * must be null-terminated. */
- int length) /* Number of bytes from "bytes" to append. If
+ const char *bytes, /* String to append. If length is
+ * < 0 then this must be null-terminated. */
+ Tcl_Size length) /* Number of bytes from "bytes" to append. If
* < 0, then append all of bytes, up to null
* at end. */
{
- int newSize;
+ Tcl_Size newSize;
if (length < 0) {
length = strlen(bytes);
@@ -2684,16 +2694,16 @@ Tcl_DStringAppend(
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
- int offset = -1;
+ Tcl_Size offset = -1;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
+ /* Source string is within this DString. Note offset */
offset = bytes - dsPtr->string;
}
-
- dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
-
+ dsPtr->string =
+ (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
bytes = dsPtr->string + offset;
}
@@ -2726,8 +2736,8 @@ TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
- int length;
- char *bytes = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_Size length;
+ const char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
@@ -2753,7 +2763,7 @@ TclDStringAppendDString(
*
* Side effects:
* String is reformatted as a list element and added to the current value
- * of the string. Memory gets reallocated if needed to accommodate the
+ * of the string. Memory gets reallocated if needed to accomodate the
* string's new size.
*
*----------------------------------------------------------------------
@@ -2768,7 +2778,8 @@ Tcl_DStringAppendElement(
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = 0;
- int quoteHash = 1, newSize;
+ int quoteHash = 1;
+ Tcl_Size newSize;
if (needSpace) {
/*
@@ -2794,7 +2805,7 @@ Tcl_DStringAppendElement(
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
- newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
+ newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags);
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
@@ -2820,11 +2831,11 @@ Tcl_DStringAppendElement(
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
+ /* Source string is within this DString. Note offset */
offset = element - dsPtr->string;
}
-
- dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
-
+ dsPtr->string =
+ (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
@@ -2843,7 +2854,7 @@ Tcl_DStringAppendElement(
dsPtr->length++;
}
- dsPtr->length += TclConvertElement(element, -1, dst, flags);
+ dsPtr->length += TclConvertElement(element, TCL_INDEX_NONE, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
@@ -2870,9 +2881,9 @@ Tcl_DStringAppendElement(
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
- int length) /* New length for dynamic string. */
+ Tcl_Size length) /* New length for dynamic string. */
{
- int newsize;
+ Tcl_Size newsize;
if (length < 0) {
length = 0;
@@ -2965,8 +2976,7 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(dsPtr));
}
/*
@@ -2995,6 +3005,14 @@ Tcl_DStringGetResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+ Tcl_Obj *obj = Tcl_GetObjResult(interp);
+ const char *bytes = TclGetString(obj);
+
+ Tcl_DStringFree(dsPtr);
+ Tcl_DStringAppend(dsPtr, bytes, obj->length);
+ Tcl_ResetResult(interp);
+#else
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
@@ -3018,7 +3036,7 @@ Tcl_DStringGetResult(
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
- if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
+ if (iPtr->objResultPtr->bytes == &tclEmptyString) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
@@ -3027,8 +3045,8 @@ Tcl_DStringGetResult(
dsPtr->string = TclGetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
- TclFreeIntRep(iPtr->objResultPtr);
- iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ TclFreeInternalRep(iPtr->objResultPtr);
+ iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
@@ -3066,12 +3084,13 @@ Tcl_DStringGetResult(
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
}
/*
*----------------------------------------------------------------------
*
- * TclDStringToObj --
+ * Tcl_DStringToObj --
*
* This function moves a dynamic string's contents to a new Tcl_Obj. Be
* aware that this function does *not* check that the encoding of the
@@ -3091,7 +3110,7 @@ Tcl_DStringGetResult(
*/
Tcl_Obj *
-TclDStringToObj(
+Tcl_DStringToObj(
Tcl_DString *dsPtr)
{
Tcl_Obj *result;
@@ -3204,9 +3223,7 @@ Tcl_DStringEndSublist(
void
Tcl_PrintDouble(
- Tcl_Interp *interp, /* Interpreter whose tcl_precision variable
- * used to be used to control printing. It's
- * ignored now. */
+ TCL_UNUSED(Tcl_Interp *),
double value, /* Value to print as string. */
char *dst) /* Where to store converted value; must have
* at least TCL_DOUBLE_SPACE characters. */
@@ -3222,7 +3239,7 @@ Tcl_PrintDouble(
* Handle NaN.
*/
- if (TclIsNaN(value)) {
+ if (isnan(value)) {
TclFormatNaN(value, dst);
return;
}
@@ -3231,7 +3248,7 @@ Tcl_PrintDouble(
* Handle infinities.
*/
- if (TclIsInfinite(value)) {
+ if (isinf(value)) {
/*
* Remember to copy the terminating NUL too.
*/
@@ -3249,7 +3266,7 @@ Tcl_PrintDouble(
*/
if (*precisionPtr == 0) {
- digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
+ digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST,
&exponent, &signum, &end);
} else {
/*
@@ -3286,13 +3303,13 @@ Tcl_PrintDouble(
* the first (the recommended zero value for tcl_precision avoids the
* problem entirely).
*
- * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method
+ * Uncomment TCL_DD_SHORTEST in the next call to prefer the method
* that allows floating point values to be shortened if it can be done
* without loss of precision.
*/
digits = TclDoubleDigits(value, *precisionPtr,
- TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */,
+ TCL_DD_E_FORMAT /* | TCL_DD_SHORTEST */,
&exponent, &signum, &end);
}
if (signum) {
@@ -3378,16 +3395,17 @@ Tcl_PrintDouble(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *
TclPrecTraceProc(
- ClientData clientData, /* Not used. */
+ void *clientData,
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
Tcl_Obj *value;
- int prec;
+ Tcl_WideInt prec;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
@@ -3411,7 +3429,7 @@ TclPrecTraceProc(
if (flags & TCL_TRACE_READS) {
- Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr),
+ Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr),
flags & TCL_GLOBAL_ONLY);
return NULL;
}
@@ -3427,13 +3445,14 @@ TclPrecTraceProc(
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL
- || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK
+ || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK
|| prec < 0 || prec > TCL_MAX_PREC) {
return (char *) "improper value for precision";
}
- *precisionPtr = prec;
+ *precisionPtr = (int)prec;
return NULL;
}
+#endif /* !TCL_NO_DEPRECATED)*/
/*
*----------------------------------------------------------------------
@@ -3553,22 +3572,21 @@ TclNeedSpace(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
- long n) /* The integer to format. */
+ Tcl_WideInt n) /* The integer to format. */
{
- unsigned long intVal;
- int i = 0;
- int numFormatted, j;
+ Tcl_WideUInt intVal;
+ int i = 0, numFormatted, j;
static const char digits[] = "0123456789";
/*
* Generate the characters of the result backwards in the buffer.
*/
- intVal = (n < 0 ? -(unsigned long)n : (unsigned long)n);
+ intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n);
do {
buffer[i++] = digits[intVal % 10];
intVal = intVal / 10;
@@ -3595,13 +3613,81 @@ TclFormatInt(
/*
*----------------------------------------------------------------------
*
- * TclGetIntForIndex --
+ * GetWideForIndex --
+ *
+ * This function produces a wide integer value corresponding to the
+ * index value held in *objPtr. The parsing supports all values
+ * recognized as any size of integer, and the syntaxes end[-+]$integer
+ * and $integer[-+]$integer. The argument endValue is used to give
+ * the meaning of the literal index value "end". Index arithmetic
+ * on arguments outside the wide integer range are only accepted
+ * when interp is a working interpreter, not NULL.
+ *
+ * Results:
+ * When parsing of *objPtr successfully recognizes an index value,
+ * TCL_OK is returned, and the wide integer value corresponding to
+ * the recognized index value is written to *widePtr. When parsing
+ * fails, TCL_ERROR is returned and error information is written to
+ * interp, if non-NULL.
+ *
+ * Side effects:
+ * The type of *objPtr may change.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetWideForIndex(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ Tcl_Obj *objPtr, /* Points to the value to be parsed */
+ Tcl_WideInt 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 = Tcl_GetNumberFromObj(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;
+ if ((*widePtr < 0)) {
+ *widePtr = (endValue == -1) ? WIDE_MIN : -1;
+ }
+ return TCL_OK;
+ }
+ if (numType == TCL_NUMBER_BIG) {
+ /* objPtr holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ *widePtr = ((mp_isneg((mp_int *)cd)) ? ((endValue == -1) ? WIDE_MIN : -1) : WIDE_MAX);
+ return TCL_OK;
+ }
+ }
+
+ /* objPtr does not hold a number, check the end+/- format... */
+ return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetIntForIndex --
*
* Provides an integer corresponding to the list index held in a Tcl
* object. The string value 'objPtr' is expected have the format
* integer([+-]integer)? or end([+-]integer)?.
*
- * Value
+ * If the computed index lies within the valid range of Tcl indices
+ * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as
+ * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1).
+ *
+ *
+ * Results:
* TCL_OK
*
* The index is stored at the address given by by 'indexPtr'. If
@@ -3622,133 +3708,54 @@ TclFormatInt(
*/
int
-TclGetIntForIndex(
+Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
- int endValue, /* The value to be stored at "indexPtr" if
- * "objPtr" holds "end". */
- int *indexPtr) /* Location filled in with an integer
- * representing an index. */
+ Tcl_Size endValue, /* The value corresponding to the "end" index */
+ Tcl_Size *indexPtr) /* Location filled in with an integer
+ * representing an index. May be NULL.*/
{
- int length;
- char *opPtr;
- const char *bytes;
-
- if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
-
- if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
-
- bytes = TclGetStringFromObj(objPtr, &length);
+ Tcl_WideInt wide;
- /*
- * Leading whitespace is acceptable in an index.
- */
-
- while (length && TclIsSpaceProcM(*bytes)) {
- bytes++;
- length--;
+ if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) {
+ return TCL_ERROR;
}
-
- if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr,
- TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
- int code, first, second;
- char savedOp = *opPtr;
-
- if ((savedOp != '+') && (savedOp != '-')) {
- goto parseError;
- }
- if (TclIsSpaceProcM(opPtr[1])) {
- goto parseError;
- }
- *opPtr = '\0';
- code = Tcl_GetInt(interp, bytes, &first);
- *opPtr = savedOp;
- if (code == TCL_ERROR) {
- goto parseError;
- }
- if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) {
- goto parseError;
- }
- if (savedOp == '+') {
- *indexPtr = first + second;
+ if (indexPtr != NULL) {
+ if ((wide < 0) && (endValue >= 0)) {
+ *indexPtr = TCL_INDEX_NONE;
+ } else if (wide > INT_MAX) {
+ *indexPtr = INT_MAX;
+ } else if (wide < INT_MIN) {
+ *indexPtr = INT_MIN;
} else {
- *indexPtr = first - second;
- }
- return TCL_OK;
- }
-
- /*
- * Report a parse error.
- */
-
- parseError:
- if (interp != NULL) {
- bytes = TclGetString(objPtr);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be integer?[+-]integer? or"
- " end?[+-]integer?", bytes));
- if (!strncmp(bytes, "end-", 4)) {
- bytes += 4;
+ *indexPtr = (int) wide;
}
- TclCheckBadOctal(interp, bytes);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
-
- return TCL_ERROR;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfEndOffset --
- *
- * Update the string rep of a Tcl object holding an "end-offset"
- * expression.
+ * GetEndOffsetFromObj --
*
- * Results:
- * None.
+ * Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
+ * convert it to an internal representation.
*
- * Side effects:
- * Stores a valid string in the object's string rep.
+ * The internal representation (wideValue) uses the following encoding:
*
- * This function does NOT free any earlier string rep. If it is called on an
- * object that already has a valid string rep, it will leak memory.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfEndOffset(
- Tcl_Obj *objPtr)
-{
- char buffer[TCL_INTEGER_SPACE + 5];
- int len = 3;
-
- memcpy(buffer, "end", 4);
- if (objPtr->internalRep.longValue != 0) {
- buffer[len++] = '-';
- len += TclFormatInt(buffer+len,
- (long)(-(unsigned long)(objPtr->internalRep.longValue)));
- }
- objPtr->bytes = (char *)ckalloc(len+1);
- memcpy(objPtr->bytes, buffer, len+1);
- objPtr->length = len;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetEndOffsetFromObj --
- *
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
+ * WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
+ * WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
+ * -$n: Index "end-[expr {$n-1}]"
+ * -2: Index "end-1"
+ * -1: Index "end"
+ * 0: Index "0"
+ * WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for
+ * commands like lset.
+ * WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
@@ -3761,118 +3768,239 @@ UpdateStringOfEndOffset(
static int
GetEndOffsetFromObj(
+ Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
- int endValue, /* The value to be stored at "indexPtr" if
+ Tcl_WideInt endValue, /* The value to be stored at "widePtr" if
* "objPtr" holds "end". */
- int *indexPtr) /* Location filled in with an integer
+ Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
- if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
+ Tcl_ObjInternalRep *irPtr;
+ Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
+ void *cd;
- /* TODO: Handle overflow cases sensibly */
- *indexPtr = endValue + (int)objPtr->internalRep.longValue;
- return TCL_OK;
-}
+ while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
+ Tcl_ObjInternalRep ir;
+ Tcl_Size length;
+ const char *bytes = TclGetStringFromObj(objPtr, &length);
+ if (*bytes != 'e') {
+ int numType;
+ const char *opPtr;
+ int t1 = 0, t2 = 0;
-/*
- *----------------------------------------------------------------------
- *
- * SetEndOffsetFromAny --
- *
- * Look for a string of the form "end[+-]offset" and convert it to an
- * internal representation holding the offset.
- *
- * Results:
- * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
- *
- * Side effects:
- * If interp is not NULL, stores an error message in the interpreter
- * result.
- *
- *----------------------------------------------------------------------
- */
+ /* Value doesn't start with "e" */
-static int
-SetEndOffsetFromAny(
- Tcl_Interp *interp, /* Tcl interpreter or NULL */
- Tcl_Obj *objPtr) /* Pointer to the object to parse */
-{
- int offset; /* Offset in the "end-offset" expression */
- const char *bytes; /* String rep of the object */
- int length; /* Length of the object's string rep */
+ /* If we reach here, the string rep of objPtr exists. */
- /*
- * If it's already the right type, we're fine.
- */
+ /*
+ * 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.
+ */
- if (objPtr->typePtr == &tclEndOffsetType) {
- return TCL_OK;
- }
+ /*
+ * Quick scan to see if multi-value list is even possible.
+ * This relies on TclGetString() returning a NUL-terminated string.
+ */
+ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
- /*
- * Check for a string rep of the right form.
- */
+ /* If it's possible, do the full list parse. */
+ && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length))
+ && (length > 1)) {
+ goto parseError;
+ }
- bytes = TclGetStringFromObj(objPtr, &length);
- if ((*bytes != 'e') || (strncmp(bytes, "end",
- (size_t)((length > 3) ? 3 : length)) != 0)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
- }
- return TCL_ERROR;
- }
+ /* Passed the list screen, so parse for index arithmetic expression */
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr,
+ TCL_PARSE_INTEGER_ONLY)) {
+ Tcl_WideInt w1=0, w2=0;
- /*
- * Convert the string rep.
- */
+ /* value starts with valid integer... */
- if (length <= 3) {
- offset = 0;
- } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
- /*
- * This is our limited string expression evaluator. Pass everything
- * after "end-" to Tcl_GetInt, then reverse for offset.
- */
+ if ((*opPtr == '-') || (*opPtr == '+')) {
+ /* ... value continues with [-+] ... */
- if (TclIsSpaceProcM(bytes[4])) {
- goto badIndexFormat;
- }
- if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
- return TCL_ERROR;
+ /* Save first integer as wide if possible */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t1);
+ if (t1 == TCL_NUMBER_INT) {
+ w1 = (*(Tcl_WideInt *)cd);
+ }
+
+ if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
+ TCL_INDEX_NONE, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* ... value concludes with second valid integer */
+
+ /* Save second integer as wide if possible */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t2);
+ if (t2 == TCL_NUMBER_INT) {
+ w2 = (*(Tcl_WideInt *)cd);
+ }
+ }
+ }
+ /* Clear invalid internalreps left by TclParseNumber */
+ TclFreeInternalRep(objPtr);
+
+ if (t1 && t2) {
+ /* We have both integer values */
+ if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
+ /* Both are wide, do wide-integer math */
+ if (*opPtr == '-') {
+ if (w2 == WIDE_MIN) {
+ goto extreme;
+ }
+ w2 = -w2;
+ }
+
+ if ((w1 ^ w2) < 0) {
+ /* Different signs, sum cannot overflow */
+ offset = w1 + w2;
+ } else if (w1 >= 0) {
+ if (w1 < WIDE_MAX - w2) {
+ offset = w1 + w2;
+ } else {
+ offset = WIDE_MAX;
+ }
+ } else {
+ if (w1 > WIDE_MIN - w2) {
+ offset = w1 + w2;
+ } else {
+ offset = WIDE_MIN;
+ }
+ }
+ } else {
+ /*
+ * At least one is big, do bignum math. Little reason to
+ * value performance here. Re-use code. Parse has verified
+ * objPtr is an expression. Compute it.
+ */
+
+ Tcl_Obj *sum;
+
+ extreme:
+ if (interp) {
+ Tcl_ExprObj(interp, objPtr, &sum);
+ } else {
+ Tcl_Interp *compute = Tcl_CreateInterp();
+ Tcl_ExprObj(compute, objPtr, &sum);
+ Tcl_DeleteInterp(compute);
+ }
+ Tcl_GetNumberFromObj(NULL, sum, &cd, &numType);
+
+ if (numType == TCL_NUMBER_INT) {
+ /* sum holds an integer in the signed wide range */
+ offset = *(Tcl_WideInt *)cd;
+ } else {
+ /* sum holds an integer outside the signed wide range */
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ offset = WIDE_MIN;
+ } else {
+ offset = WIDE_MAX;
+ }
+ }
+ Tcl_DecrRefCount(sum);
+ }
+ if (offset < 0) {
+ offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1;
+ }
+ goto parseOK;
+ }
+ }
+ goto parseError;
}
- if (bytes[3] == '-') {
- offset = (int)(-(unsigned int)offset);
+ if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
+ /* Doesn't start with "end" */
+ goto parseError;
}
- } else {
- /*
- * Conversion failed. Report the error.
- */
+ if (length > 4) {
+ int t;
+
+ /* Parse for the "end-..." or "end+..." formats */
+
+ if ((bytes[3] != '-') && (bytes[3] != '+')) {
+ /* No operator where we need one */
+ goto parseError;
+ }
+ if (TclIsSpaceProc(bytes[4])) {
+ /* Space after + or - not permitted. */
+ goto parseError;
+ }
+
+ /* Parse the integer offset */
+ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
+ bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
+ /* Not a recognized integer format */
+ goto parseError;
+ }
+
+ /* Got an integer offset; pull it from where parser left it. */
+ Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t);
- badIndexFormat:
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad index \"%s\": must be end?[+-]integer?", bytes));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
+ if (t == TCL_NUMBER_BIG) {
+ /* Truncate to the signed wide range. */
+ if (mp_isneg((mp_int *)cd)) {
+ offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
+ } else {
+ offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
+ }
+ } else {
+ /* assert (t == TCL_NUMBER_INT); */
+ offset = (*(Tcl_WideInt *)cd);
+ if (bytes[3] == '-') {
+ offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
+ }
+ if (offset == 1) {
+ offset = WIDE_MAX; /* "end+1" */
+ } else if (offset > 1) {
+ offset = WIDE_MAX - 1; /* "end+n", out of range */
+ } else if (offset != WIDE_MIN) {
+ offset--;
+ }
+ }
}
- return TCL_ERROR;
+
+ parseOK:
+ /* Success. Store the new internal rep. */
+ ir.wideValue = offset;
+ Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir);
}
- /*
- * The conversion succeeded. Free the old internal rep and set the new
- * one.
- */
+ offset = irPtr->wideValue;
+
+ if (offset == WIDE_MAX) {
+ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
+ } else if (offset == WIDE_MIN) {
+ *widePtr = -1;
+ } else if (endValue == -1) {
+ *widePtr = offset;
+ } else if (offset < 0) {
+ /* Different signs, sum cannot overflow */
+ *widePtr = endValue + offset + 1;
+ } else if (offset < WIDE_MAX) {
+ *widePtr = offset;
+ } else {
+ *widePtr = WIDE_MAX;
+ }
+ return TCL_OK;
- TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = offset;
- objPtr->typePtr = &tclEndOffsetType;
+ /* Report a parse error. */
+ parseError:
+ if (interp != NULL) {
+ char * bytes = TclGetString(objPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad index \"%s\": must be integer?[+-]integer? or"
+ " end?[+-]integer?", bytes));
+ if (!strncmp(bytes, "end-", 4)) {
+ bytes += 4;
+ }
+ TclCheckBadOctal(interp, bytes);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (void *)NULL);
+ }
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -3887,7 +4015,7 @@ SetEndOffsetFromAny(
* arithmetic expressions. The absolute index values that can be
* directly meaningful as an index into either a list or a string are
* those integer values >= TCL_INDEX_START (0)
- * and < TCL_INDEX_AFTER (INT_MAX).
+ * and < INT_MAX.
* The largest string supported in Tcl 8 has bytelength INT_MAX.
* This means the largest supported character length is also INT_MAX,
* and the index of the last character in a string of length INT_MAX
@@ -3896,9 +4024,9 @@ SetEndOffsetFromAny(
* Any absolute index value parsed outside that range is encoded
* using the before and after values passed in by the
* caller as the encoding to use for indices that are either
- * less than or greater than the usable index range. TCL_INDEX_AFTER
+ * less than or greater than the usable index range. TCL_INDEX_NONE
* is available as a good choice for most callers to use for
- * after. Likewise, the value TCL_INDEX_BEFORE is good for
+ * after. Likewise, the value TCL_INDEX_NONE is good for
* most callers to use for before. Other values are possible
* when the caller knows it is helpful in producing its own behavior
* for indices before and after the indexed item.
@@ -3916,10 +4044,6 @@ SetEndOffsetFromAny(
* if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
* they can be encoded with the before value.
*
- * These details will require re-examination whenever string and
- * list length limits are increased, but that will likely also
- * mean a revised routine capable of returning Tcl_WideInt values.
- *
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
*
@@ -3934,51 +4058,36 @@ int
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
- int before, /* Value to return for index before beginning */
- int after, /* Value to return for index after end */
+ Tcl_Size before, /* Value to return for index before beginning */
+ Tcl_Size after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
+ Tcl_WideInt wide;
int idx;
- if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) {
- /* We parsed a value in the range INT_MIN...INT_MAX */
- integerEncode:
- if (idx < TCL_INDEX_START) {
- /* All negative absolute indices are "before the beginning" */
- idx = before;
- } else if (idx == INT_MAX) {
- /* This index value is always "after the end" */
- idx = after;
- }
- /* usual case, the absolute index value encodes itself */
- } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
- /*
- * We parsed an end+offset index value.
- * idx holds the offset value in the range INT_MIN...INT_MAX.
- */
- if (idx > 0) {
- /*
- * All end+positive or end-negative expressions
- * always indicate "after the end".
- */
- idx = after;
- } else if (idx < INT_MIN - TCL_INDEX_END) {
- /* These indices always indicate "before the beginning" */
- idx = before;
- } else {
- /* Encoded end-positive (or end+negative) are offset */
- idx += TCL_INDEX_END;
- }
-
- /* TODO: Consider flag to suppress repeated end-offset parse. */
- } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) {
- /*
- * Only reach this case when the index value is a
- * constant index arithmetic expression, and idx
- * holds the result. Treat it the same as if it were
- * parsed as an absolute integer value.
- */
- goto integerEncode;
+ if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType);
+ if (irPtr && irPtr->wideValue >= 0) {
+ /* "int[+-]int" syntax, works the same here as "int" */
+ irPtr = NULL;
+ }
+ /*
+ * We parsed an end+offset index value.
+ * wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
+ */
+ if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
+ /*
+ * All end+postive or end-negative expressions
+ * always indicate "after the end".
+ */
+ idx = after;
+ } else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) {
+ /* These indices always indicate "before the beginning" */
+ idx = before;
+ } else {
+ /* Encoded end-positive (or end+negative) are offset */
+ idx = (int)wide;
+ }
} else {
return TCL_ERROR;
}
@@ -4001,15 +4110,19 @@ TclIndexEncode(
*----------------------------------------------------------------------
*/
-int
+Tcl_Size
TclIndexDecode(
int encoded, /* Value to decode */
- int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
+ Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
{
- if (encoded <= TCL_INDEX_END) {
- return (encoded - TCL_INDEX_END) + endValue;
+ if (encoded > TCL_INDEX_END) {
+ return encoded;
+ }
+ endValue += encoded - TCL_INDEX_END;
+ if (endValue >= 0) {
+ return endValue;
}
- return encoded;
+ return TCL_INDEX_NONE;
}
/*
@@ -4071,7 +4184,7 @@ TclCheckBadOctal(
*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- " (looks like invalid octal number)", -1);
+ " (looks like invalid octal number)", TCL_INDEX_NONE);
}
return 1;
}
@@ -4154,7 +4267,7 @@ GetThreadHash(
static void
FreeThreadHash(
- ClientData clientData)
+ void *clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
@@ -4176,7 +4289,7 @@ FreeThreadHash(
static void
FreeProcessGlobalValue(
- ClientData clientData)
+ void *clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
@@ -4225,7 +4338,8 @@ TclSetProcessGlobalValue(
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
- bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
+ bytes = TclGetString(newValue);
+ pgvPtr->numBytes = newValue->length;
pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
@@ -4268,7 +4382,7 @@ TclGetProcessGlobalValue(
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
- int epoch = pgvPtr->epoch;
+ Tcl_Size epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
@@ -4418,11 +4532,10 @@ TclGetObjNameOfExecutable(void)
const char *
Tcl_GetNameOfExecutable(void)
{
- int numBytes;
- const char *bytes =
- Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes);
+ Tcl_Obj *obj = TclGetObjNameOfExecutable();
+ const char *bytes = TclGetString(obj);
- if (numBytes == 0) {
+ if (obj->length == 0) {
return NULL;
}
return bytes;
@@ -4500,7 +4613,7 @@ int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
- int reStrLen,
+ Tcl_Size reStrLen,
Tcl_DString *dsPtr,
int *exactPtr,
int *quantifiersFoundPtr)
@@ -4694,7 +4807,7 @@ TclReToGlob(
invalidGlob:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
- Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, (void *)NULL);
}
Tcl_DStringFree(dsPtr);
return TCL_ERROR;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index b2e59b3..3007296 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -7,11 +7,11 @@
* The implementation of arrays is modelled after an initial
* implementation by Mark Diekhans and Karl Lehenbauer.
*
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 Scriptics Corporation.
- * Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2007 Miguel Sofer
+ * Copyright © 1987-1994 The Regents of the University of California.
+ * Copyright © 1994-1997 Sun Microsystems, Inc.
+ * Copyright © 1998-1999 Scriptics Corporation.
+ * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2007 Miguel Sofer
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -45,7 +45,7 @@ static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
- ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+ ((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
/*
* NOTE: VarHashCreateVar increments the recount of its key argument.
@@ -60,8 +60,7 @@ VarHashCreateVar(
Tcl_Obj *key,
int *newPtr)
{
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
- key, newPtr);
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr);
if (!hPtr) {
return NULL;
@@ -109,9 +108,6 @@ VarHashNextVar(
return VarHashGetValue(hPtr);
}
-#define VarHashGetKey(varPtr) \
- (((VarInHash *)(varPtr))->entry.key.objPtr)
-
#define VarHashDeleteTable(tablePtr) \
Tcl_DeleteHashTable(&(tablePtr)->table)
@@ -146,6 +142,7 @@ static const char ISARRAYELEMENT[] =
*/
typedef struct ArraySearch {
+ Tcl_Obj *name; /* Name of this search */
int id; /* Integer id used to distinguish among
* multiple concurrent searches for the same
* array. */
@@ -165,11 +162,30 @@ typedef struct ArraySearch {
} ArraySearch;
/*
+ * TIP #508: [array default]
+ *
+ * The following structure extends the regular TclVarHashTable used by array
+ * variables to store their optional default value.
+ */
+
+typedef struct ArrayVarHashTable {
+ TclVarHashTable table;
+ Tcl_Obj *defaultObj;
+} ArrayVarHashTable;
+
+/*
* Forward references to functions defined later in this file:
*/
static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *patternPtr, int includeLinks);
+static void ArrayPopulateSearch(Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, Var *varPtr,
+ ArraySearch *searchPtr);
+static void ArrayDoneSearch(Interp *iPtr, Var *varPtr,
+ ArraySearch *searchPtr);
+static Tcl_NRPostProc ArrayForLoopCallback;
+static Tcl_ObjCmdProc ArrayForNRCmd;
static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
Var *varPtr, int flags, int index);
@@ -188,8 +204,14 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags, int index);
-static int SetArraySearchObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
+
+/*
+ * TIP #508: [array default]
+ */
+
+static Tcl_ObjCmdProc ArrayDefaultCmd;
+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
@@ -202,14 +224,9 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp,
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_FreeInternalRepProc FreeLocalVarName;
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
-static Tcl_UpdateStringProc UpdateParsedVarName;
-
-static Tcl_UpdateStringProc PanicOnUpdateVarName;
-static Tcl_SetFromAnyProc PanicOnSetVarName;
/*
* Types of Tcl_Objs used to cache variable lookups.
@@ -228,30 +245,52 @@ static Tcl_SetFromAnyProc PanicOnSetVarName;
static const Tcl_ObjType localVarNameType = {
"localVarName",
- FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName
+ FreeLocalVarName, DupLocalVarName, NULL, NULL
};
-static const Tcl_ObjType tclParsedVarNameType = {
+#define LocalSetInternalRep(objPtr, index, namePtr) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ Tcl_Obj *ptr = (namePtr); \
+ if (ptr) {Tcl_IncrRefCount(ptr);} \
+ ir.twoPtrValue.ptr1 = ptr; \
+ ir.twoPtrValue.ptr2 = INT2PTR(index); \
+ Tcl_StoreInternalRep((objPtr), &localVarNameType, &ir); \
+ } 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 ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
+ } while (0)
+
+static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
- FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
+ FreeParsedVarName, DupParsedVarName, NULL, NULL
};
-/*
- * Type of Tcl_Objs used to speed up array searches.
- *
- * INTERNALREP DEFINITION:
- * twoPtrValue.ptr1: searchIdNumber (cast to pointer)
- * twoPtrValue.ptr2: variableNameStartInString (cast to pointer)
- *
- * Note that the value stored in ptr2 is the offset into the string of the
- * start of the variable name and not the address of the variable name itself,
- * as this can be safely copied.
- */
-
-const Tcl_ObjType tclArraySearchType = {
- "array search",
- NULL, NULL, NULL, SetArraySearchObj
-};
+#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
+ do { \
+ Tcl_ObjInternalRep ir; \
+ Tcl_Obj *ptr1 = (arrayPtr); \
+ Tcl_Obj *ptr2 = (elem); \
+ if (ptr1) {Tcl_IncrRefCount(ptr1);} \
+ if (ptr2) {Tcl_IncrRefCount(ptr2);} \
+ ir.twoPtrValue.ptr1 = ptr1; \
+ ir.twoPtrValue.ptr2 = ptr2; \
+ Tcl_StoreInternalRep((objPtr), &parsedVarNameType, &ir); \
+ } while (0)
+
+#define ParsedGetInternalRep(objPtr, parsed, array, elem) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &parsedVarNameType); \
+ (parsed) = (irPtr != NULL); \
+ (array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
+ (elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
+ } while (0)
Var *
TclVarHashCreateVar(
@@ -302,7 +341,7 @@ NotArrayError(
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (void *)NULL);
return TCL_ERROR;
}
@@ -337,7 +376,8 @@ CleanupVar(
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
- && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
+ && (VarHashRefCount(varPtr) == (Tcl_Size)
+ !TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
ckfree(varPtr);
} else {
@@ -346,7 +386,8 @@ CleanupVar(
}
if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
- (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
+ (VarHashRefCount(arrayPtr) == (Tcl_Size)
+ !TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
ckfree(arrayPtr);
} else {
@@ -474,9 +515,8 @@ TclLookupVar(
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
- * are 1. The object part1Ptr is converted to one of localVarNameType,
- * tclNsVarNameType or tclParsedVarNameType and caches as much of the
- * lookup as it can.
+ * are 1. The object part1Ptr is converted to one of localVarNameType
+ * or parsedVarNameType and caches as much of the lookup as it can.
* When createPart1 is 1, callers must IncrRefCount part1Ptr if they
* plan to DecrRefCount it.
*
@@ -558,24 +598,20 @@ TclObjLookupVarEx(
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
- const char *part1;
- int index, len1, len2;
- int parsed = 0;
- Tcl_Obj *objPtr;
- const Tcl_ObjType *typePtr = part1Ptr->typePtr;
const char *errMsg = NULL;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
- char *newPart2 = NULL;
- *arrayPtrPtr = NULL;
+ int index, parsed = 0;
- if (typePtr == &localVarNameType) {
- int localIndex;
+ Tcl_Size localIndex;
+ Tcl_Obj *namePtr, *arrayPtr, *elem;
- localVarNameTypeHandling:
- localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2);
+ *arrayPtrPtr = NULL;
+
+ restart:
+ LocalGetInternalRep(part1Ptr, localIndex, namePtr);
+ if (localIndex >= 0) {
if (HasLocalVars(varFramePtr)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
@@ -583,8 +619,7 @@ TclObjLookupVarEx(
* Use the cached index if the names coincide.
*/
- Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex);
+ Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex);
if ((!namePtr && (checkNamePtr == part1Ptr)) ||
(namePtr && (checkNamePtr == namePtr))) {
@@ -596,12 +631,11 @@ TclObjLookupVarEx(
}
/*
- * If part1Ptr is a tclParsedVarNameType, separate it into the preparsed
- * parts.
+ * If part1Ptr is a parsedVarNameType, retrieve the preparsed parts.
*/
- if (typePtr == &tclParsedVarNameType) {
- if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
+ ParsedGetInternalRep(part1Ptr, parsed, arrayPtr, elem);
+ if (parsed && arrayPtr) {
if (part2Ptr != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot specify
@@ -611,90 +645,44 @@ TclObjLookupVarEx(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
NOSUCHVAR, -1);
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME", (void *)NULL);
}
return NULL;
}
- part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
- if (newPart2) {
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
- }
- part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
- typePtr = part1Ptr->typePtr;
- if (typePtr == &localVarNameType) {
- goto localVarNameTypeHandling;
- }
- }
- parsed = 1;
+ part2Ptr = elem;
+ part1Ptr = arrayPtr;
+ goto restart;
}
- part1 = TclGetStringFromObj(part1Ptr, &len1);
- if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) {
+ if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
- int i;
+ Tcl_Size len;
+ const char *part1 = TclGetStringFromObj(part1Ptr, &len);
- len2 = -1;
- for (i = 0; i < len1; i++) {
- if (*(part1 + i) == '(') {
+ if ((len > 1) && (part1[len - 1] == ')')) {
+ const char *part2 = strchr(part1, '(');
+
+ if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg,
NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VARNAME",
- NULL);
+ (void *)NULL);
}
return NULL;
}
- /*
- * part1Ptr points to an array element; first copy the element
- * name to a new string part2.
- */
+ arrayPtr = Tcl_NewStringObj(part1, (part2 - part1));
+ part2Ptr = Tcl_NewStringObj(part2 + 1,
+ len - (part2 - part1) - 2);
- part2 = part1 + i + 1;
- len2 = len1 - i - 2;
- len1 = i;
-
- newPart2 = ckalloc(len2 + 1);
- memcpy(newPart2, part2, len2);
- *(newPart2+len2) = '\0';
- part2 = newPart2;
- part2Ptr = Tcl_NewStringObj(newPart2, -1);
- if (createPart2) {
- Tcl_IncrRefCount(part2Ptr);
- }
+ ParsedSetInternalRep(part1Ptr, arrayPtr, part2Ptr);
- /*
- * Free the internal rep of the original part1Ptr, now renamed
- * objPtr, and set it to tclParsedVarNameType.
- */
-
- objPtr = part1Ptr;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclParsedVarNameType;
-
- /*
- * Define a new string object to hold the new part1Ptr, i.e.,
- * the array name. Set the internal rep of objPtr, reset
- * typePtr and part1 to contain the references to the array
- * name.
- */
-
- TclNewStringObj(part1Ptr, part1, len1);
- Tcl_IncrRefCount(part1Ptr);
-
- objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr;
- objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2;
-
- typePtr = part1Ptr->typePtr;
- part1 = TclGetString(part1Ptr);
- break;
+ part1Ptr = arrayPtr;
}
}
}
@@ -705,18 +693,13 @@ TclObjLookupVarEx(
* the cached types if possible.
*/
- TclFreeIntRep(part1Ptr);
-
varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
&errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- TclGetString(part1Ptr), NULL);
- }
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
+ TclGetString(part1Ptr), (void *)NULL);
}
return NULL;
}
@@ -729,28 +712,46 @@ TclObjLookupVarEx(
/*
* An indexed local variable.
*/
- Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index);
-
- part1Ptr->typePtr = &localVarNameType;
- if (part1Ptr != cachedNamePtr) {
- part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr;
- Tcl_IncrRefCount(cachedNamePtr);
- if (cachedNamePtr->typePtr != &localVarNameType
- || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) {
- TclFreeIntRep(cachedNamePtr);
- }
+
+ Tcl_Obj *cachedNamePtr = localName(varFramePtr, index);
+
+ if (part1Ptr == cachedNamePtr) {
+ LocalSetInternalRep(part1Ptr, index, NULL);
} else {
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
+ /*
+ * [80304238ac] Trickiness here. We will store and incr the
+ * refcount on cachedNamePtr. Trouble is that it's possible
+ * (see test var-22.1) for cachedNamePtr to have an internalrep
+ * that contains a stored and refcounted part1Ptr. This
+ * would be a reference cycle which leads to a memory leak.
+ *
+ * The solution here is to wipe away all internalrep(s) in
+ * cachedNamePtr and leave it as string only. This is
+ * radical and destructive, so a better idea would be welcome.
+ */
+
+ /*
+ * Firstly set cached local var reference (avoid free before set,
+ * see [45b9faf103f2])
+ */
+ LocalSetInternalRep(part1Ptr, index, cachedNamePtr);
+
+ /* Then wipe it */
+ TclFreeInternalRep(cachedNamePtr);
+
+ /*
+ * Now go ahead and convert it the the "localVarName" type,
+ * since we suspect at least some use of the value as a
+ * varname and we want to resolve it quickly.
+ */
+ LocalSetInternalRep(cachedNamePtr, index, NULL);
}
- part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index);
} else {
/*
* At least mark part1Ptr as already parsed.
*/
- part1Ptr->typePtr = &tclParsedVarNameType;
- part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
- part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
+ ParsedSetInternalRep(part1Ptr, NULL, NULL);
}
donePart1:
@@ -766,9 +767,6 @@ TclObjLookupVarEx(
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
createPart1, createPart2, varPtr, -1);
- if (newPart2) {
- Tcl_DecrRefCount(part2Ptr);
- }
}
return varPtr;
}
@@ -843,7 +841,8 @@ TclLookupSimpleVar(
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
- int isNew, i, result, varLen;
+ int isNew, result;
+ Tcl_Size i, varLen;
const char *varName = TclGetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
@@ -935,46 +934,49 @@ TclLookupSimpleVar(
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
- if (create) { /* Var wasn't found so create it. */
- TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
- flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
- if (varNsPtr == NULL) {
- *errMsgPtr = BADNAMESPACE;
- return NULL;
- } else if (tail == NULL) {
- *errMsgPtr = MISSINGNAME;
- return NULL;
- }
- if (tail != varName) {
- tailPtr = Tcl_NewStringObj(tail, -1);
- } else {
- tailPtr = varNamePtr;
- }
- varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr,
- &isNew);
- if (lookGlobal) {
- /*
- * The variable was created starting from the global
- * namespace: a global reference is returned even if it
- * wasn't explicitly requested.
- */
-
- *indexPtr = -1;
- } else {
- *indexPtr = -2;
- }
- } else { /* Var wasn't found and not to create it. */
+ if (!create) { /* Var wasn't found and not to create it. */
*errMsgPtr = NOSUCHVAR;
return NULL;
}
+
+ /*
+ * Var wasn't found so create it.
+ */
+
+ TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags,
+ &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
+ if (varNsPtr == NULL) {
+ *errMsgPtr = BADNAMESPACE;
+ return NULL;
+ } else if (tail == NULL) {
+ *errMsgPtr = MISSINGNAME;
+ return NULL;
+ }
+ if (tail != varName) {
+ tailPtr = Tcl_NewStringObj(tail, -1);
+ } else {
+ tailPtr = varNamePtr;
+ }
+ varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew);
+ if (lookGlobal) {
+ /*
+ * The variable was created starting from the global
+ * namespace: a global reference is returned even if it wasn't
+ * explicitly requested.
+ */
+
+ *indexPtr = -1;
+ } else {
+ *indexPtr = -2;
+ }
}
} else { /* Local var: look in frame varFramePtr. */
- int localCt = varFramePtr->numCompiledLocals;
+ Tcl_Size localCt = varFramePtr->numCompiledLocals;
if (localCt > 0) {
Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
const char *localNameStr;
- int localLen;
+ Tcl_Size localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
@@ -1072,8 +1074,6 @@ TclLookupArrayElement(
{
int isNew;
Var *varPtr;
- TclVarHashTable *tablePtr;
- Namespace *nsPtr;
/*
* We're dealing with an array element. Make sure the variable is an array
@@ -1086,7 +1086,7 @@ TclLookupArrayElement(
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
NOSUCHVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL);
}
return NULL;
}
@@ -1101,27 +1101,18 @@ TclLookupArrayElement(
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
DANGLINGVAR, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL);
}
return NULL;
}
- TclSetVarArray(arrayPtr);
- tablePtr = ckalloc(sizeof(TclVarHashTable));
- arrayPtr->value.tablePtr = tablePtr;
-
- if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
- nsPtr = TclGetVarNsPtr(arrayPtr);
- } else {
- nsPtr = NULL;
- }
- TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr);
+ TclInitArrayVar(arrayPtr);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, NEEDARRAY,
index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- arrayNamePtr?TclGetString(arrayNamePtr):NULL, NULL);
+ arrayNamePtr?TclGetString(arrayNamePtr):NULL, (void *)NULL);
}
return NULL;
}
@@ -1142,7 +1133,7 @@ TclLookupArrayElement(
TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg,
NOSUCHELEMENT, index);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT",
- TclGetString(elNamePtr), NULL);
+ TclGetString(elNamePtr), (void *)NULL);
}
}
}
@@ -1171,6 +1162,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetVar
const char *
Tcl_GetVar(
@@ -1191,6 +1183,7 @@ Tcl_GetVar(
}
return TclGetString(resultPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1463,6 +1456,28 @@ TclPtrGetVarIdx(
return varPtr->value.objPtr;
}
+ /*
+ * Return the array default value if any.
+ */
+
+ if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) {
+ return TclGetArrayDefault(arrayPtr);
+ }
+ if (TclIsVarArrayElement(varPtr) && !arrayPtr) {
+ /*
+ * UGLY! Peek inside the implementation of things. This lets us get
+ * the default of an array even when we've been [upvar]ed to just an
+ * element of the array.
+ */
+
+ ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *)
+ ((VarInHash *) varPtr)->entry.tablePtr;
+
+ if (avhtPtr->defaultObj) {
+ return avhtPtr->defaultObj;
+ }
+ }
+
if (flags & TCL_LEAVE_ERR_MSG) {
if (TclIsVarUndefined(varPtr) && arrayPtr
&& !TclIsVarUndefined(arrayPtr)) {
@@ -1481,7 +1496,7 @@ TclPtrGetVarIdx(
*/
errorReturn:
- Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "READ", "VARNAME", (void *)NULL);
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
}
@@ -1507,7 +1522,7 @@ TclPtrGetVarIdx(
int
Tcl_SetObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1559,6 +1574,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetVar
const char *
Tcl_SetVar(
@@ -1571,18 +1587,15 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
-
- Tcl_IncrRefCount(varNamePtr);
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL,
Tcl_NewStringObj(newValue, -1), flags);
- Tcl_DecrRefCount(varNamePtr);
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1824,6 +1837,130 @@ TclPtrSetVar(
/*
*----------------------------------------------------------------------
*
+ * ListAppendInVar, StringAppendInVar --
+ *
+ * Support functions for TclPtrSetVarIdx that implement various types of
+ * appending operations.
+ *
+ * Results:
+ * ListAppendInVar returns a Tcl result code (from the core list append
+ * operation). StringAppendInVar has no return value.
+ *
+ * Side effects:
+ * The variable or element of the array is updated. This may make the
+ * variable/element exist. Reference counts of values may be updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+ListAppendInVar(
+ Tcl_Interp *interp,
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ if (oldValuePtr == NULL) {
+ /*
+ * No previous value. Check for defaults if there's an array we can
+ * ask this of.
+ */
+
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ oldValuePtr = Tcl_DuplicateObj(defValuePtr);
+ }
+ }
+
+ if (oldValuePtr == NULL) {
+ /*
+ * No default. [lappend] semantics say this is like being an empty
+ * string.
+ */
+
+ TclNewObj(oldValuePtr);
+ }
+ varPtr->value.objPtr = oldValuePtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ } else if (Tcl_IsShared(oldValuePtr)) {
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
+ }
+
+ return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr);
+}
+
+static inline void
+StringAppendInVar(
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *oldValuePtr,
+ Tcl_Obj *newValuePtr)
+{
+ /*
+ * If there was no previous value, either we use the array's default (if
+ * this is an array with a default at all) or we treat this as a simple
+ * set.
+ */
+
+ if (oldValuePtr == NULL) {
+ if (arrayPtr) {
+ Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr);
+
+ if (defValuePtr) {
+ /*
+ * This is *almost* the same as the shared path below, except
+ * that the original value reference in defValuePtr is not
+ * decremented.
+ */
+
+ Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr);
+
+ varPtr->value.objPtr = valuePtr;
+ TclContinuationsCopy(valuePtr, defValuePtr);
+ Tcl_IncrRefCount(valuePtr);
+ Tcl_AppendObjToObj(valuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+ return;
+ }
+ }
+ varPtr->value.objPtr = newValuePtr;
+ Tcl_IncrRefCount(newValuePtr);
+ return;
+ }
+
+ /*
+ * We append newValuePtr's bytes but don't change its ref count. Unless
+ * the reference is shared, when we have to duplicate in order to be safe
+ * to modify at all.
+ */
+
+ if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
+ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
+
+ TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
+
+ TclDecrRefCount(oldValuePtr);
+ oldValuePtr = varPtr->value.objPtr;
+ Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
+ }
+
+ Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
+ if (newValuePtr->refCount == 0) {
+ Tcl_DecrRefCount(newValuePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclPtrSetVarIdx --
*
* This function is the same as Tcl_SetVar2Ex above, except that it
@@ -1884,11 +2021,11 @@ TclPtrSetVarIdx(
if (TclIsVarArrayElement(varPtr)) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGELEMENT, index);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", (void *)NULL);
} else {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set",
DANGLINGVAR, index);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", (void *)NULL);
}
}
goto earlyError;
@@ -1901,7 +2038,7 @@ TclPtrSetVarIdx(
if (TclIsVarArray(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY,index);
- Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL);
}
goto earlyError;
}
@@ -1936,44 +2073,13 @@ TclPtrSetVarIdx(
}
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (flags & TCL_LIST_ELEMENT) { /* Append list element. */
- if (oldValuePtr == NULL) {
- TclNewObj(oldValuePtr);
- varPtr->value.objPtr = oldValuePtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- } else if (Tcl_IsShared(oldValuePtr)) {
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */
- }
- result = Tcl_ListObjAppendElement(interp, oldValuePtr,
+ result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr,
newValuePtr);
if (result != TCL_OK) {
goto earlyError;
}
} else { /* Append string. */
- /*
- * We append newValuePtr's bytes but don't change its ref count.
- */
-
- if (oldValuePtr == NULL) {
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr);
- } else {
- if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */
- varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
-
- TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr);
-
- TclDecrRefCount(oldValuePtr);
- oldValuePtr = varPtr->value.objPtr;
- Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */
- }
- Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
- if (newValuePtr->refCount == 0) {
- Tcl_DecrRefCount(newValuePtr);
- }
- }
+ StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr);
}
} else if (newValuePtr != oldValuePtr) {
/*
@@ -2025,7 +2131,7 @@ TclPtrSetVarIdx(
cleanup:
if (resultPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "VARNAME", (void *)NULL);
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
@@ -2263,6 +2369,7 @@ TclPtrIncrObjVarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
@@ -2291,6 +2398,7 @@ Tcl_UnsetVar(
Tcl_DecrRefCount(varNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2498,7 +2606,7 @@ TclPtrUnsetVarIdx(
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
- Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (void *)NULL);
}
}
@@ -2708,7 +2816,7 @@ UnsetVarStruct(
int
Tcl_UnsetObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2775,7 +2883,7 @@ Tcl_UnsetObjCmd(
int
Tcl_AppendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2840,15 +2948,15 @@ Tcl_AppendObjCmd(
int
Tcl_LappendObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
- int numElems, createdNewObj;
+ Tcl_Size numElems;
Var *varPtr, *arrayPtr;
- int result;
+ int result, createdNewObj;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
@@ -2869,7 +2977,7 @@ Tcl_LappendObjCmd(
return TCL_ERROR;
}
} else {
- result = TclListObjLength(interp, newValuePtr, &numElems);
+ result = TclListObjLengthM(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
@@ -2927,7 +3035,7 @@ Tcl_LappendObjCmd(
createdNewObj = 1;
}
- result = TclListObjLength(interp, varValuePtr, &numElems);
+ result = TclListObjLengthM(interp, varValuePtr, &numElems);
if (result == TCL_OK) {
result = Tcl_ListObjReplace(interp, varValuePtr, numElems, 0,
(objc-2), (objv+2));
@@ -2964,6 +3072,319 @@ Tcl_LappendObjCmd(
/*
*----------------------------------------------------------------------
*
+ * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext --
+ *
+ * These functions implement the "array for" Tcl command.
+ * array for {k v} a {}
+ * The array for command iterates over the array, setting the the
+ * specified loop variables, and executing the body each iteration.
+ *
+ * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
+ *
+ * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
+ * inside the structure and calls VarHashFirstEntry to start the hash
+ * iteration.
+ *
+ * ArrayForNRCmd() does not execute the body or set the loop variables,
+ * it only initializes the iterator.
+ *
+ * ArrayForLoopCallback() iterates over the entire array, executing the
+ * body each time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ArrayObjNext(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, /* array */
+ Var *varPtr, /* array */
+ ArraySearch *searchPtr,
+ Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key
+ * written into, or NULL. */
+ Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the
+ * value written into, or NULL.*/
+{
+ Tcl_Obj *keyObj;
+ Tcl_Obj *valueObj = NULL;
+ int gotValue;
+ int donerc;
+
+ donerc = TCL_BREAK;
+
+ if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
+ donerc = TCL_ERROR;
+ return donerc;
+ }
+
+ gotValue = 0;
+ while (1) {
+ Tcl_HashEntry *hPtr = searchPtr->nextEntry;
+
+ if (hPtr != NULL) {
+ searchPtr->nextEntry = NULL;
+ } else {
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ gotValue = 0;
+ break;
+ }
+ }
+ varPtr = VarHashGetValue(hPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ gotValue = 1;
+ break;
+ }
+ }
+
+ if (!gotValue) {
+ return donerc;
+ }
+
+ donerc = TCL_CONTINUE;
+
+ keyObj = VarHashGetKey(varPtr);
+ *keyPtrPtr = keyObj;
+ valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj,
+ TCL_LEAVE_ERR_MSG);
+ *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;
+ Tcl_Size 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", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+
+ /*
+ * Make a new array search, put it on the stack.
+ */
+
+ searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
+ ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
+
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish.
+ */
+
+ /* Do not use TclListObjCopy here - shimmers arithseries to list */
+ varListObj = Tcl_DuplicateObj(objv[1]);
+ if (!varListObj) {
+ return TCL_ERROR;
+ }
+ scriptObj = objv[3];
+ Tcl_IncrRefCount(scriptObj);
+
+ /*
+ * Run the script.
+ */
+
+ 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;
+ Tcl_Size varc;
+
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ done = TCL_ERROR;
+
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"array for\" body line %d)",
+ Tcl_GetErrorLine(interp)));
+ }
+ goto arrayfordone;
+ }
+
+ /*
+ * Get the next mapping from the array.
+ */
+
+ keyObj = NULL;
+ valueObj = NULL;
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ if (varPtr == NULL) {
+ done = TCL_ERROR;
+ } else {
+ done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj,
+ &valueObj);
+ }
+
+ result = TCL_OK;
+ if (done != TCL_CONTINUE) {
+ Tcl_ResetResult(interp);
+ if (done == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array changed during iteration", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", (void *)NULL);
+ varPtr->flags |= TCL_LEAVE_ERR_MSG;
+ result = done;
+ }
+ goto arrayfordone;
+ }
+
+ result = TclListObjGetElementsM(NULL, varListObj, &varc, &varv);
+ if (result != TCL_OK) {
+ goto arrayfordone;
+ }
+ 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,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
+ }
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+ arrayNameObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ arrayfordone:
+ if (done != TCL_ERROR) {
+ /*
+ * If the search was terminated by an array change, the
+ * VAR_SEARCH_ACTIVE flag will no longer be set.
+ */
+
+ ArrayDoneSearch(iPtr, varPtr, searchPtr);
+ Tcl_DecrRefCount(searchPtr->name);
+ ckfree(searchPtr);
+ }
+
+ TclDecrRefCount(varListObj);
+ TclDecrRefCount(scriptObj);
+ return result;
+}
+
+/*
+ * ArrayPopulateSearch
+ */
+
+static void
+ArrayPopulateSearch(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+ if (isNew) {
+ searchPtr->id = 1;
+ varPtr->flags |= VAR_SEARCH_ACTIVE;
+ searchPtr->nextPtr = NULL;
+ } else {
+ searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+ searchPtr->nextPtr = (ArraySearch *)Tcl_GetHashValue(hPtr);
+ }
+ searchPtr->varPtr = varPtr;
+ searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+ &searchPtr->search);
+ Tcl_SetHashValue(hPtr, searchPtr);
+ searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
+ TclGetString(arrayNameObj));
+ Tcl_IncrRefCount(searchPtr->name);
+}
+/*
+ *----------------------------------------------------------------------
+ *
* ArrayStartSearchCmd --
*
* This object-based function is invoked to process the "array
@@ -2981,17 +3402,14 @@ Tcl_LappendObjCmd(
static int
ArrayStartSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
- int isNew, isArray;
+ int isArray;
ArraySearch *searchPtr;
- const char *varName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
@@ -3010,24 +3428,54 @@ ArrayStartSearchCmd(
* Make a new array search with a free name.
*/
- varName = TclGetString(objv[1]);
- searchPtr = ckalloc(sizeof(ArraySearch));
- hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
- if (isNew) {
- searchPtr->id = 1;
- varPtr->flags |= VAR_SEARCH_ACTIVE;
- searchPtr->nextPtr = NULL;
+ searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
+ ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr);
+ Tcl_SetObjResult(interp, searchPtr->name);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArrayDoneSearch --
+ *
+ * Removes the search from the hash of active searches.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+ArrayDoneSearch(
+ Interp *iPtr,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr;
+ ArraySearch *prevPtr;
+
+ /*
+ * Unhook the search from the list of searches associated with the
+ * variable.
+ */
+
+ hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+ if (hPtr == NULL) {
+ return;
+ }
+ if (searchPtr == Tcl_GetHashValue(hPtr)) {
+ if (searchPtr->nextPtr) {
+ Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+ } else {
+ varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(hPtr);
+ }
} else {
- searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
- searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+ for (prevPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); ; prevPtr=prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ break;
+ }
+ }
}
- searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
- &searchPtr->search);
- Tcl_SetHashValue(hPtr, searchPtr);
- Tcl_SetObjResult(interp,
- Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
- return TCL_OK;
}
/*
@@ -3049,12 +3497,12 @@ ArrayStartSearchCmd(
static int
ArrayAnyMoreCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
int gotValue, isArray;
@@ -3127,7 +3575,7 @@ ArrayAnyMoreCmd(
static int
ArrayNextElementCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3207,16 +3655,15 @@ ArrayNextElementCmd(
static int
ArrayDoneSearchCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
- ArraySearch *searchPtr, *prevPtr;
+ ArraySearch *searchPtr;
int isArray;
if (objc != 3) {
@@ -3243,27 +3690,8 @@ ArrayDoneSearchCmd(
return TCL_ERROR;
}
- /*
- * Unhook the search from the list of searches associated with the
- * variable.
- */
-
- hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
- if (searchPtr == Tcl_GetHashValue(hPtr)) {
- if (searchPtr->nextPtr) {
- Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
- } else {
- varPtr->flags &= ~VAR_SEARCH_ACTIVE;
- Tcl_DeleteHashEntry(hPtr);
- }
- } else {
- for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
- }
- }
- }
+ ArrayDoneSearch(iPtr, varPtr, searchPtr);
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
}
@@ -3287,7 +3715,7 @@ ArrayDoneSearchCmd(
static int
ArrayExistsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3327,7 +3755,7 @@ ArrayExistsCmd(
static int
ArrayGetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3337,7 +3765,8 @@ ArrayGetCmd(
Tcl_Obj **nameObjPtr, *patternObj;
Tcl_HashSearch search;
const char *pattern;
- int i, count, result, isArray;
+ Tcl_Size i, count;
+ int result, isArray;
switch (objc) {
case 2:
@@ -3419,7 +3848,7 @@ ArrayGetCmd(
*/
TclNewObj(tmpResObj);
- result = TclListObjGetElements(interp, nameLstObj, &count, &nameObjPtr);
+ result = TclListObjGetElementsM(interp, nameLstObj, &count, &nameObjPtr);
if (result != TCL_OK) {
goto errorInArrayGet;
}
@@ -3486,7 +3915,7 @@ ArrayGetCmd(
static int
ArrayNamesCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3653,7 +4082,7 @@ TclFindArrayPtrElements(
static int
ArraySetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3661,7 +4090,7 @@ ArraySetCmd(
Tcl_Obj *arrayNameObj;
Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
- int result, i;
+ int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
@@ -3683,7 +4112,7 @@ ArraySetCmd(
CleanupVar(varPtr, arrayPtr);
TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", NEEDARRAY, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- TclGetString(arrayNameObj), NULL);
+ TclGetString(arrayNameObj), (void *)NULL);
return TCL_ERROR;
}
@@ -3692,7 +4121,7 @@ ArraySetCmd(
*/
arrayElemObj = objv[2];
- if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
+ if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
@@ -3739,23 +4168,28 @@ ArraySetCmd(
* -compatibility reasons) a list.
*/
- int elemLen;
+ Tcl_Size elemLen;
Tcl_Obj **elemPtrs, *copyListObj;
+ Tcl_Size i;
- result = TclListObjGetElements(interp, arrayElemObj,
- &elemLen, &elemPtrs);
+ result = TclListObjLengthM(interp, arrayElemObj, &elemLen);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"list must have an even number of elements", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", (void *)NULL);
return TCL_ERROR;
}
if (elemLen == 0) {
goto ensureArray;
}
+ result = TclListObjGetElementsM(interp, arrayElemObj,
+ &elemLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
/*
* We needn't worry about traces invalidating arrayPtr: should that be
@@ -3764,6 +4198,9 @@ ArraySetCmd(
*/
copyListObj = TclListObjCopy(NULL, arrayElemObj);
+ if (!copyListObj) {
+ return TCL_ERROR;
+ }
for (i=0 ; i<elemLen ; i+=2) {
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
@@ -3801,13 +4238,11 @@ ArraySetCmd(
TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
NEEDARRAY, -1);
- Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL);
return TCL_ERROR;
}
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ TclInitArrayVar(varPtr);
return TCL_OK;
}
@@ -3830,7 +4265,7 @@ ArraySetCmd(
static int
ArraySizeCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3865,7 +4300,7 @@ ArraySizeCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
return TCL_OK;
}
@@ -3889,7 +4324,7 @@ ArraySizeCmd(
static int
ArrayStatsCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3943,7 +4378,7 @@ ArrayStatsCmd(
static int
ArrayUnsetCmd(
- ClientData clientData,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -4083,8 +4518,10 @@ TclInitArrayCmd(
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
+ {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
{"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -4185,7 +4622,7 @@ ObjMakeUpvar(
"bad variable name \"%s\": can't create namespace "
"variable that refers to procedure variable",
TclGetString(myNamePtr)));
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (void *)NULL);
return TCL_ERROR;
}
}
@@ -4301,7 +4738,7 @@ TclPtrObjMakeUpvarIdx(
"bad variable name \"%s\": can't create a scalar "
"variable that looks like an array element", myName));
Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT",
- NULL);
+ (void *)NULL);
return TCL_ERROR;
}
}
@@ -4320,7 +4757,7 @@ TclPtrObjMakeUpvarIdx(
if (varPtr == NULL) {
TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- TclGetString(myNamePtr), NULL);
+ TclGetString(myNamePtr), (void *)NULL);
return TCL_ERROR;
}
}
@@ -4328,14 +4765,14 @@ TclPtrObjMakeUpvarIdx(
if (varPtr == otherPtr) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_NewStringObj(
"can't upvar from variable to itself", -1));
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "SELF", (void *)NULL);
return TCL_ERROR;
}
if (TclIsVarTraced(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" has traces: can't use for upvar", myName));
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "TRACED", (void *)NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
Var *linkPtr;
@@ -4350,7 +4787,7 @@ TclPtrObjMakeUpvarIdx(
if (!TclIsVarLink(varPtr)) {
Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf(
"variable \"%s\" already exists", myName));
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "EXISTS", (void *)NULL);
return TCL_ERROR;
}
@@ -4394,6 +4831,7 @@ TclPtrObjMakeUpvarIdx(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
@@ -4427,6 +4865,7 @@ Tcl_UpVar(
Tcl_DecrRefCount(localNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -4536,7 +4975,7 @@ Tcl_GetVariableFullName(
Tcl_AppendObjToObj(objPtr, namePtr);
}
} else if (iPtr->varFramePtr->procPtr) {
- int index = varPtr - iPtr->varFramePtr->compiledLocals;
+ Tcl_Size index = varPtr - iPtr->varFramePtr->compiledLocals;
if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) {
namePtr = localName(iPtr->varFramePtr, index);
@@ -4564,7 +5003,7 @@ Tcl_GetVariableFullName(
int
Tcl_GlobalObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4668,7 +5107,7 @@ Tcl_GlobalObjCmd(
int
Tcl_VariableObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4700,7 +5139,7 @@ Tcl_VariableObjCmd(
TclObjVarErrMsg(interp, varNamePtr, NULL, "define",
ISARRAYELEMENT, -1);
- Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", (void *)NULL);
return TCL_ERROR;
}
@@ -4801,7 +5240,7 @@ Tcl_VariableObjCmd(
int
Tcl_UpvarObjCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -4851,7 +5290,7 @@ Tcl_UpvarObjCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad level \"%s\"", TclGetString(levelObj)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL",
- TclGetString(levelObj), NULL);
+ TclGetString(levelObj), (void *)NULL);
return TCL_ERROR;
}
@@ -4881,75 +5320,6 @@ Tcl_UpvarObjCmd(
/*
*----------------------------------------------------------------------
*
- * SetArraySearchObj --
- *
- * This function converts the given tcl object into one that has the
- * "array search" internal type.
- *
- * Results:
- * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when
- * an error message will be placed in the interpreter's result.)
- *
- * Side effects:
- * Updates the internal type and representation of the object to make
- * this an array-search object. See the tclArraySearchType declaration
- * above for details of the internal representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetArraySearchObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- const char *string;
- char *end; /* Can't be const due to strtoul defn. */
- int id;
- size_t offset;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = TclGetString(objPtr);
-
- /*
- * Parse the id into the three parts separated by dashes.
- */
-
- if ((string[0] != 's') || (string[1] != '-')) {
- goto syntax;
- }
- id = strtoul(string+2, &end, 10);
- if ((end == (string+2)) || (*end != '-')) {
- goto syntax;
- }
-
- /*
- * Can't perform value check in this context, so place reference to place
- * in string to use for the check in the object instead.
- */
-
- end++;
- offset = end - string;
-
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclArraySearchType;
- objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id);
- objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset);
- return TCL_OK;
-
- syntax:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "illegal search identifier \"%s\"", string));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* ParseSearchId --
*
* This function translates from a tcl object to a pointer to an active
@@ -4960,10 +5330,6 @@ SetArraySearchObj(
* or NULL if there isn't one. If NULL is returned, the interp's result
* contains an error message.
*
- * Side effects:
- * The tcl object might have its internal type and representation
- * modified.
- *
*----------------------------------------------------------------------
*/
@@ -4979,65 +5345,43 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
- const char *string;
- size_t offset;
- int id;
ArraySearch *searchPtr;
- const char *varName = TclGetString(varNamePtr);
-
- /*
- * Parse the id.
- */
-
- if ((handleObj->typePtr != &tclArraySearchType)
- && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
- return NULL;
- }
-
- /*
- * Extract the information out of the Tcl_Obj.
- */
-
- id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1);
- string = TclGetString(handleObj);
- offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2);
-
- /*
- * This test cannot be placed inside the Tcl_Obj machinery, since it is
- * dependent on the variable context.
- */
-
- if (strcmp(string+offset, varName) != 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "search identifier \"%s\" isn't for variable \"%s\"",
- string, varName));
- goto badLookup;
- }
-
- /*
- * Search through the list of active searches on the interpreter to see if
- * the desired one exists.
- *
- * Note that we cannot store the searchPtr directly in the Tcl_Obj as that
- * would run into trouble when DeleteSearches() was called so we must scan
- * this list every time.
- */
+ const char *handle = TclGetString(handleObj);
+ char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
- for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ /* First look for same (Tcl_Obj *) */
+ for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
+ searchPtr = searchPtr->nextPtr) {
+ if (searchPtr->name == handleObj) {
+ return searchPtr;
+ }
+ }
+ /* Fallback: do string compares. */
+ for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
- if (searchPtr->id == id) {
+ if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
return searchPtr;
}
}
}
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't find search \"%s\"", string));
- badLookup:
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
+ if ((handle[0] != 's') || (handle[1] != '-')
+ || (strtoul(handle + 2, &end, 10), end == (handle + 2))
+ || (*end != '-')) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "illegal search identifier \"%s\"", handle));
+ } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "search identifier \"%s\" isn't for variable \"%s\"",
+ handle, TclGetString(varNamePtr)));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", handle));
+ }
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, (void *)NULL);
return NULL;
}
@@ -5072,6 +5416,7 @@ DeleteSearches(
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
+ Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
@@ -5256,7 +5601,7 @@ TclDeleteCompiledLocalVars(
* assigned local variables to delete. */
{
Var *varPtr;
- int numLocals, i;
+ Tcl_Size numLocals, i;
Tcl_Obj **namePtrPtr;
numLocals = framePtr->numCompiledLocals;
@@ -5364,8 +5709,7 @@ DeleteArray(
TclClearVarNamespaceVar(elPtr);
}
- VarHashDeleteTable(varPtr->value.tablePtr);
- ckfree(varPtr->value.tablePtr);
+ DeleteArrayVar(varPtr);
}
/*
@@ -5443,28 +5787,6 @@ TclObjVarErrMsg(
*/
/*
- * Panic functions that should never be called in normal operation.
- */
-
-static void
-PanicOnUpdateVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "updateStringProc",
- objPtr->typePtr->name);
-}
-
-static int
-PanicOnSetVarName(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- Tcl_Panic("%s of type %s should not be called", "setFromAnyProc",
- objPtr->typePtr->name);
- return TCL_ERROR;
-}
-
-/*
* localVarName -
*
* INTERNALREP DEFINITION:
@@ -5477,12 +5799,15 @@ static void
FreeLocalVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *namePtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Size index;
+ Tcl_Obj *namePtr;
+
+ LocalGetInternalRep(objPtr, index, namePtr);
+ index++; /* Compiler warning bait. */
if (namePtr) {
Tcl_DecrRefCount(namePtr);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5490,17 +5815,14 @@ DupLocalVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Size index;
+ Tcl_Obj *namePtr;
+ LocalGetInternalRep(srcPtr, index, namePtr);
if (!namePtr) {
namePtr = srcPtr;
}
- dupPtr->internalRep.twoPtrValue.ptr1 = namePtr;
- Tcl_IncrRefCount(namePtr);
-
- dupPtr->internalRep.twoPtrValue.ptr2 =
- srcPtr->internalRep.twoPtrValue.ptr2;
- dupPtr->typePtr = &localVarNameType;
+ LocalSetInternalRep(dupPtr, index, namePtr);
}
/*
@@ -5516,14 +5838,16 @@ static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *elem = objPtr->internalRep.twoPtrValue.ptr2;
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
+
+ ParsedGetInternalRep(objPtr, parsed, arrayPtr, elem);
+ parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
- ckfree(elem);
+ TclDecrRefCount(elem);
}
- objPtr->typePtr = NULL;
}
static void
@@ -5531,58 +5855,13 @@ DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
- char *elemCopy;
- unsigned elemLen;
-
- if (arrayPtr != NULL) {
- Tcl_IncrRefCount(arrayPtr);
- elemLen = strlen(elem);
- elemCopy = (char *)ckalloc(elemLen + 1);
- memcpy(elemCopy, elem, elemLen);
- *(elemCopy + elemLen) = '\0';
- elem = elemCopy;
- }
-
- dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
- dupPtr->internalRep.twoPtrValue.ptr2 = elem;
- dupPtr->typePtr = &tclParsedVarNameType;
-}
-
-static void
-UpdateParsedVarName(
- Tcl_Obj *objPtr)
-{
- Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
- char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
- const char *part1;
- char *p;
- int len1, len2, totalLen;
-
- if (arrayPtr == NULL) {
- /*
- * This is a parsed scalar name: what is it doing here?
- */
-
- Tcl_Panic("scalar parsedVarName without a string rep");
- }
+ Tcl_Obj *arrayPtr, *elem;
+ int parsed;
- part1 = TclGetStringFromObj(arrayPtr, &len1);
- len2 = strlen(part2);
+ ParsedGetInternalRep(srcPtr, parsed, arrayPtr, elem);
- totalLen = len1 + len2 + 2;
- p = ckalloc(totalLen + 1);
- objPtr->bytes = p;
- objPtr->length = totalLen;
-
- memcpy(p, part1, len1);
- p += len1;
- *p++ = '(';
- memcpy(p, part2, len2);
- p += len2;
- *p++ = ')';
- *p = '\0';
+ parsed++; /* Silence compiler. */
+ ParsedSetInternalRep(dupPtr, arrayPtr, elem);
}
/*
@@ -5742,7 +6021,7 @@ ObjFindNamespaceVar(
if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown variable \"%s\"", name));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, (void *)NULL);
}
return (Tcl_Var) varPtr;
}
@@ -5773,7 +6052,7 @@ ObjFindNamespaceVar(
int
TclInfoVarsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -5964,7 +6243,7 @@ TclInfoVarsCmd(
int
TclInfoGlobalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6057,7 +6336,7 @@ TclInfoGlobalsCmd(
int
TclInfoLocalsCmd(
- ClientData dummy, /* Not used. */
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -6116,7 +6395,8 @@ AppendLocals(
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
- int i, localVarCt, added;
+ Tcl_Size i, localVarCt;
+ int added;
Tcl_Obj *objNamePtr;
const char *varName;
TclVarHashTable *localVarTablePtr;
@@ -6207,25 +6487,50 @@ AppendLocals(
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
- CallContext *contextPtr = iPtr->varFramePtr->clientData;
- Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ Method *mPtr = (Method *)
+ Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData);
+ PrivateVariableMapping *privatePtr;
if (mPtr->declaringObjectPtr) {
- FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
+ Object *oPtr = mPtr->declaringObjectPtr;
+
+ FOREACH(objNamePtr, oPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
if (added && (!pattern ||
Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
}
}
+ FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
+ Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+ &added);
+ if (added && (!pattern ||
+ Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+ pattern))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ privatePtr->variableObj);
+ }
+ }
} else {
- FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
+ Class *clsPtr = mPtr->declaringClassPtr;
+
+ FOREACH(objNamePtr, clsPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
if (added && (!pattern ||
Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
}
}
+ FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
+ Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
+ &added);
+ if (added && (!pattern ||
+ Tcl_StringMatch(TclGetString(privatePtr->variableObj),
+ pattern))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ privatePtr->variableObj);
+ }
+ }
}
}
Tcl_DeleteHashTable(&addedTable);
@@ -6247,7 +6552,7 @@ TclInitVarHashTable(
static Tcl_HashEntry *
AllocVarEntry(
- Tcl_HashTable *tablePtr, /* Hash table. */
+ TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
@@ -6287,13 +6592,13 @@ FreeVarEntry(
static int
CompareVarKeys(
- void *keyPtr, /* New key to compare. */
+ void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = hPtr->key.objPtr;
const char *p1, *p2;
- int l1, l2;
+ Tcl_Size l1, l2;
/*
* If the object pointers are the same then they match.
@@ -6307,10 +6612,8 @@ CompareVarKeys(
* register.
*/
- p1 = TclGetString(objPtr1);
- l1 = objPtr1->length;
- p2 = TclGetString(objPtr2);
- l2 = objPtr2->length;
+ p1 = TclGetStringFromObj(objPtr1, &l1);
+ p2 = TclGetStringFromObj(objPtr2, &l2);
/*
* Only compare string representations of the same length.
@@ -6319,6 +6622,263 @@ CompareVarKeys(
return ((l1 == l2) && !memcmp(p1, p2, l1));
}
+/*----------------------------------------------------------------------
+ *
+ * ArrayDefaultCmd --
+ *
+ * This function implements the 'array default' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * 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
+ };
+ enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET };
+ Tcl_Obj *arrayNameObj, *defaultValueObj;
+ Var *varPtr, *arrayPtr;
+ int isArray, option;
+
+ /*
+ * Parse arguments.
+ */
+
+ if (objc != 3 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option",
+ 0, &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum arrayDefaultOptionsEnum)option) {
+ case OPT_GET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ if (!defaultValueObj) {
+ /* Array default must exist. */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array has no default value", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", (void *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_SET:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Attempt to create array if needed.
+ */
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (arrayPtr) {
+ /*
+ * Not a valid array name.
+ */
+
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ NEEDARRAY, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(arrayNameObj), (void *)NULL);
+ return TCL_ERROR;
+ }
+ if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ /*
+ * Not an array.
+ */
+
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set",
+ NEEDARRAY, -1);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL);
+ return TCL_ERROR;
+ }
+
+ if (!TclIsVarArray(varPtr)) {
+ TclInitArrayVar(varPtr);
+ }
+ defaultValueObj = objv[3];
+ SetArrayDefault(varPtr, defaultValueObj);
+ return TCL_OK;
+
+ case OPT_EXISTS:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Undefined variables (whether or not they have storage allocated) do
+ * not have defaults, and this is not an error case.
+ */
+
+ if (!varPtr || TclIsVarUndefined(varPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ } else {
+ defaultValueObj = TclGetArrayDefault(varPtr);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj));
+ }
+ return TCL_OK;
+
+ case OPT_UNSET:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+
+ if (varPtr && !TclIsVarUndefined(varPtr)) {
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
+ }
+ SetArrayDefault(varPtr, NULL);
+ }
+ return TCL_OK;
+ }
+
+ /* Unreached */
+ return TCL_ERROR;
+}
+
+/*
+ * Initialize array variable.
+ */
+
+void
+TclInitArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable));
+
+ /*
+ * Mark the variable as an array.
+ */
+
+ TclSetVarArray(arrayPtr);
+
+ /*
+ * Regular TclVarHashTable initialization.
+ */
+
+ arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr;
+ TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr));
+
+ /*
+ * Default value initialization.
+ */
+
+ tablePtr->defaultObj = NULL;
+}
+
+/*
+ * Cleanup array variable.
+ */
+
+static void
+DeleteArrayVar(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Default value cleanup.
+ */
+
+ SetArrayDefault(arrayPtr, NULL);
+
+ /*
+ * Regular TclVarHashTable cleanup.
+ */
+
+ VarHashDeleteTable(arrayPtr->value.tablePtr);
+ ckfree(tablePtr);
+}
+
+/*
+ * Get array default value if any.
+ */
+
+Tcl_Obj *
+TclGetArrayDefault(
+ Var *arrayPtr)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ return tablePtr->defaultObj;
+}
+
+/*
+ * Set/replace/unset array default value.
+ */
+
+static void
+SetArrayDefault(
+ Var *arrayPtr,
+ Tcl_Obj *defaultObj)
+{
+ ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
+ arrayPtr->value.tablePtr;
+
+ /*
+ * Increment/decrement refcount twice to ensure that the object is shared,
+ * so that it doesn't get modified accidentally by the folling code:
+ *
+ * array default set v 1
+ * lappend v(a) 2; # returns a new object {1 2}
+ * set v(b); # returns the original default object "1"
+ */
+
+ if (tablePtr->defaultObj) {
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ Tcl_DecrRefCount(tablePtr->defaultObj);
+ }
+ tablePtr->defaultObj = defaultObj;
+ if (tablePtr->defaultObj) {
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ Tcl_IncrRefCount(tablePtr->defaultObj);
+ }
+}
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
new file mode 100644
index 0000000..5df300a
--- /dev/null
+++ b/generic/tclZipfs.c
@@ -0,0 +1,6571 @@
+/*
+ * tclZipfs.c --
+ *
+ * Implementation of the ZIP filesystem used in TIP 430
+ * Adapted from the implementation for AndroWish.
+ *
+ * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com>
+ * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de>
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * This file is distributed in two ways:
+ * generic/tclZipfs.c file in the TIP430-enabled Tcl cores.
+ * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430
+ * projects.
+ *
+ * Helpful docs:
+ * https://pkware.cachefly.net/webdocs/APPNOTE/APPNOTE-6.3.9.TXT
+ * https://libzip.org/specifications/appnote_iz.txt
+ */
+
+#include "tclInt.h"
+#include "tclFileSystem.h"
+
+#include <assert.h>
+
+#ifndef _WIN32
+#include <sys/mman.h>
+#endif /* _WIN32*/
+
+#ifndef MAP_FILE
+#define MAP_FILE 0
+#endif /* !MAP_FILE */
+#define NOBYFOUR
+#ifndef TBLS
+#define TBLS 1
+#endif
+
+#if !defined(_WIN32) && !defined(NO_DLFCN_H)
+#include <dlfcn.h>
+#endif
+
+/*
+ * Macros to report errors only if an interp is present.
+ */
+
+#define ZIPFS_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \
+ } \
+ } while (0)
+#define ZIPFS_MEM_ERROR(interp) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj( \
+ "out of memory", -1)); \
+ Tcl_SetErrorCode(interp, "TCL", "MALLOC", (void *)NULL); \
+ } \
+ } while (0)
+#define ZIPFS_POSIX_ERROR(interp,errstr) \
+ do { \
+ if (interp) { \
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
+ "%s: %s", errstr, Tcl_PosixError(interp))); \
+ } \
+ } while (0)
+#define ZIPFS_ERROR_CODE(interp,errcode) \
+ do { \
+ if (interp) { \
+ Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, (void *)NULL); \
+ } \
+ } while (0)
+
+#ifdef HAVE_ZLIB
+#include "zlib.h"
+#include "crypt.h"
+#include "zutil.h"
+#include "crc32.h"
+
+static const z_crc_t* crc32tab;
+
+/*
+** We are compiling as part of the core.
+** TIP430 style zipfs prefix
+*/
+
+#define ZIPFS_VOLUME "//zipfs:/"
+#define ZIPFS_ROOTDIR_DEPTH 3 /* Number of / in root mount */
+#define ZIPFS_VOLUME_LEN 9
+#define ZIPFS_APP_MOUNT ZIPFS_VOLUME "app"
+#define ZIPFS_ZIP_MOUNT ZIPFS_VOLUME "lib/tcl"
+#define ZIPFS_FALLBACK_ENCODING "cp437"
+
+/*
+ * Various constants and offsets found in ZIP archive files
+ */
+
+#define ZIP_SIG_LEN 4
+
+/*
+ * Local header of ZIP archive member (at very beginning of each member).
+ */
+
+#define ZIP_LOCAL_HEADER_SIG 0x04034b50
+#define ZIP_LOCAL_HEADER_LEN 30
+#define ZIP_LOCAL_SIG_OFFS 0
+#define ZIP_LOCAL_VERSION_OFFS 4
+#define ZIP_LOCAL_FLAGS_OFFS 6
+#define ZIP_LOCAL_COMPMETH_OFFS 8
+#define ZIP_LOCAL_MTIME_OFFS 10
+#define ZIP_LOCAL_MDATE_OFFS 12
+#define ZIP_LOCAL_CRC32_OFFS 14
+#define ZIP_LOCAL_COMPLEN_OFFS 18
+#define ZIP_LOCAL_UNCOMPLEN_OFFS 22
+#define ZIP_LOCAL_PATHLEN_OFFS 26
+#define ZIP_LOCAL_EXTRALEN_OFFS 28
+
+/*
+ * Central header of ZIP archive member at end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_HEADER_SIG 0x02014b50
+#define ZIP_CENTRAL_HEADER_LEN 46
+#define ZIP_CENTRAL_SIG_OFFS 0
+#define ZIP_CENTRAL_VERSIONMADE_OFFS 4
+#define ZIP_CENTRAL_VERSION_OFFS 6
+#define ZIP_CENTRAL_FLAGS_OFFS 8
+#define ZIP_CENTRAL_COMPMETH_OFFS 10
+#define ZIP_CENTRAL_MTIME_OFFS 12
+#define ZIP_CENTRAL_MDATE_OFFS 14
+#define ZIP_CENTRAL_CRC32_OFFS 16
+#define ZIP_CENTRAL_COMPLEN_OFFS 20
+#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24
+#define ZIP_CENTRAL_PATHLEN_OFFS 28
+#define ZIP_CENTRAL_EXTRALEN_OFFS 30
+#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32
+#define ZIP_CENTRAL_DISKFILE_OFFS 34
+#define ZIP_CENTRAL_IATTR_OFFS 36
+#define ZIP_CENTRAL_EATTR_OFFS 38
+#define ZIP_CENTRAL_LOCALHDR_OFFS 42
+
+/*
+ * Central end signature at very end of ZIP file.
+ */
+
+#define ZIP_CENTRAL_END_SIG 0x06054b50
+#define ZIP_CENTRAL_END_LEN 22
+#define ZIP_CENTRAL_END_SIG_OFFS 0
+#define ZIP_CENTRAL_DISKNO_OFFS 4
+#define ZIP_CENTRAL_DISKDIR_OFFS 6
+#define ZIP_CENTRAL_ENTS_OFFS 8
+#define ZIP_CENTRAL_TOTALENTS_OFFS 10
+#define ZIP_CENTRAL_DIRSIZE_OFFS 12
+#define ZIP_CENTRAL_DIRSTART_OFFS 16
+#define ZIP_CENTRAL_COMMENTLEN_OFFS 20
+
+#define ZIP_MIN_VERSION 20
+#define ZIP_COMPMETH_STORED 0
+#define ZIP_COMPMETH_DEFLATED 8
+
+#define ZIP_PASSWORD_END_SIG 0x5a5a4b50
+#define ZIP_CRYPT_HDR_LEN 12
+
+#define ZIP_MAX_FILE_SIZE INT_MAX
+#define DEFAULT_WRITE_MAX_SIZE ZIP_MAX_FILE_SIZE
+
+/*
+ * Mutex to protect localtime(3) when no reentrant version available.
+ */
+
+#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS
+TCL_DECLARE_MUTEX(localtimeMutex)
+#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */
+
+/*
+ * Forward declaration.
+ */
+
+struct ZipEntry;
+
+/*
+ * In-core description of mounted ZIP archive file.
+ */
+
+typedef struct ZipFile {
+ char *name; /* Archive name */
+ size_t nameLength; /* Length of archive name */
+ char isMemBuffer; /* When true, not a file but a memory buffer */
+ Tcl_Channel chan; /* Channel handle or NULL */
+ unsigned char *data; /* Memory mapped or malloc'ed file */
+ size_t length; /* Length of memory mapped file */
+ void *ptrToFree; /* Non-NULL if malloc'ed file */
+ size_t numFiles; /* Number of files in archive */
+ size_t baseOffset; /* Archive start */
+ size_t passOffset; /* Password start */
+ size_t directoryOffset; /* Archive directory start */
+ size_t directorySize; /* Size of archive directory */
+ unsigned char passBuf[264]; /* Password buffer */
+ size_t numOpen; /* Number of open files on archive */
+ struct ZipEntry *entries; /* List of files in archive */
+ struct ZipEntry *topEnts; /* List of top-level dirs in archive */
+ char *mountPoint; /* Mount point name */
+ Tcl_Size mountPointLen; /* Length of mount point name */
+#ifdef _WIN32
+ HANDLE mountHandle; /* Handle used for direct file access. */
+#endif /* _WIN32 */
+} ZipFile;
+
+/*
+ * In-core description of file contained in mounted ZIP archive.
+ */
+
+typedef struct ZipEntry {
+ char *name; /* The full pathname of the virtual file */
+ ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
+ size_t offset; /* Data offset into memory mapped ZIP file */
+ int numBytes; /* Uncompressed size of the virtual file.
+ -1 for zip64 */
+ int numCompressedBytes; /* Compressed size of the virtual file.
+ -1 for zip64 */
+ int compressMethod; /* Compress method */
+ int isDirectory; /* 0 if file, 1 if directory, -1 if root */
+ int depth; /* Number of slashes in path. */
+ int crc32; /* CRC-32 as stored in ZIP */
+ int timestamp; /* Modification time */
+ int isEncrypted; /* True if data is encrypted */
+ int flags;
+#define ZE_F_CRC_COMPARED 0x0001 /* If 1, the CRC has been compared. */
+#define ZE_F_CRC_CORRECT 0x0002 /* Only meaningful if ZE_F_CRC_COMPARED is 1 */
+#define ZE_F_VOLUME 0x0004 /* Entry corresponds to //zipfs:/ */
+ unsigned char *data; /* File data if written */
+ struct ZipEntry *next; /* Next file in the same archive */
+ struct ZipEntry *tnext; /* Next top-level dir in archive */
+} ZipEntry;
+
+/*
+ * File channel for file contained in mounted ZIP archive.
+ *
+ * Regarding data buffers:
+ * For READ-ONLY files that are not encrypted and not compressed (zip STORE
+ * method), ubuf points directly to the mapped zip file data in memory. No
+ * additional storage is allocated and so ubufToFree is NULL.
+ *
+ * In all other combinations of compression and encryption or if channel is
+ * writable, storage is allocated for the decrypted and/or uncompressed data
+ * and a pointer to it is stored in ubufToFree and ubuf. When channel is
+ * closed, ubufToFree is freed if not NULL. ubuf is irrelevant since it may
+ * or may not point to allocated storage as above.
+ */
+
+typedef struct ZipChannel {
+ ZipFile *zipFilePtr; /* The ZIP file holding this channel */
+ ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
+ Tcl_Size maxWrite; /* Maximum size for write */
+ Tcl_Size numBytes; /* Number of bytes of uncompressed data */
+ Tcl_Size cursor; /* Seek position for next read or write*/
+ unsigned char *ubuf; /* Pointer to the uncompressed data */
+ unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not
+ need freeing. Else memory to free (ubuf
+ may point *inside* the block) */
+ Tcl_Size ubufSize; /* Size of allocated ubufToFree */
+ int iscompr; /* True if data is compressed */
+ int isDirectory; /* Set to 1 if directory, or -1 if root */
+ int isEncrypted; /* True if data is encrypted */
+ int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/
+ unsigned long keys[3]; /* Key for decryption */
+} ZipChannel;
+static inline int ZipChannelWritable(ZipChannel *info) {
+ return (info->mode & (O_WRONLY | O_RDWR)) != 0;
+}
+
+/*
+ * Global variables.
+ *
+ * Most are kept in single ZipFS struct. When build with threading support
+ * this struct is protected by the ZipFSMutex (see below).
+ *
+ * The "fileHash" component is the process-wide global table of all known ZIP
+ * archive members in all mounted ZIP archives.
+ *
+ * The "zipHash" components is the process wide global table of all mounted
+ * ZIP archive files.
+ */
+
+static struct {
+ int initialized; /* True when initialized */
+ int lock; /* RW lock, see below */
+ int waiters; /* RW lock, see below */
+ int wrmax; /* Maximum write size of a file; only written
+ * to from Tcl code in a trusted interpreter,
+ * so NOT protected by mutex. */
+ char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when
+ * they are believed to not be UTF-8; only
+ * written to from Tcl code in a trusted
+ * interpreter, so not protected by mutex. */
+ int idCount; /* Counter for channel names */
+ Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
+ Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
+} ZipFS = {
+ 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, NULL, 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}
+};
+
+/*
+ * For password rotation.
+ */
+
+static const char pwrot[17] =
+ "\x00\x80\x40\xC0\x20\xA0\x60\xE0"
+ "\x10\x90\x50\xD0\x30\xB0\x70\xF0";
+
+static const char *zipfs_literal_tcl_library = NULL;
+
+/* Function prototypes */
+
+static int CopyImageFile(Tcl_Interp *interp, const char *imgName,
+ Tcl_Channel out);
+static int DescribeMounted(Tcl_Interp *interp,
+ const char *mountPoint);
+static int InitReadableChannel(Tcl_Interp *interp,
+ ZipChannel *info, ZipEntry *z);
+static int InitWritableChannel(Tcl_Interp *interp,
+ ZipChannel *info, ZipEntry *z, int trunc);
+static int ListMountPoints(Tcl_Interp *interp);
+static int ContainsMountPoint(const char *path, int pathLen);
+static void CleanupMount(ZipFile *zf);
+static Tcl_Obj * ScriptLibrarySetup(const char *dirName);
+static void SerializeCentralDirectoryEntry(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ ZipEntry *z, size_t nameLength);
+static void SerializeCentralDirectorySuffix(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ int entryCount, long long directoryStartOffset,
+ long long suffixStartOffset);
+static void SerializeLocalEntryHeader(
+ const unsigned char *start,
+ const unsigned char *end, unsigned char *buf,
+ ZipEntry *z, int nameLength, int align);
+static int IsCryptHeaderValid(ZipEntry *z,
+ unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
+static int DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z,
+ unsigned long keys[3],
+ unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
+#if !defined(STATIC_BUILD)
+static int ZipfsAppHookFindTclInit(const char *archive);
+#endif
+static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr,
+ void **clientDataPtr);
+static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
+static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
+static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode);
+static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int mode, int permissions);
+static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr,
+ const char *pattern, Tcl_GlobTypeData *types);
+static void ZipFSMatchMountPoints(Tcl_Obj *result,
+ Tcl_Obj *normPathPtr, const char *pattern,
+ Tcl_DString *prefix);
+static Tcl_Obj * ZipFSListVolumesProc(void);
+static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef);
+static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index,
+ Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
+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 ZipfsSetup(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);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+static int ZipChannelSeek(void *instanceData, long offset,
+ int mode, int *errloc);
+#endif
+static long long ZipChannelWideSeek(void *instanceData,
+ long long offset, int mode, int *errloc);
+static void ZipChannelWatchChannel(void *instanceData,
+ int mask);
+static int ZipChannelWrite(void *instanceData,
+ const char *buf, int toWrite, int *errloc);
+
+/*
+ * Define the ZIP filesystem dispatch table.
+ */
+
+static const Tcl_Filesystem zipfsFilesystem = {
+ "zipfs",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_2,
+ ZipFSPathInFilesystemProc,
+ NULL, /* dupInternalRepProc */
+ NULL, /* freeInternalRepProc */
+ NULL, /* internalToNormalizedProc */
+ NULL, /* createInternalRepProc */
+ NULL, /* normalizePathProc */
+ ZipFSFilesystemPathTypeProc,
+ ZipFSFilesystemSeparatorProc,
+ ZipFSStatProc,
+ ZipFSAccessProc,
+ ZipFSOpenFileChannelProc,
+ ZipFSMatchInDirectoryProc,
+ NULL, /* utimeProc */
+ NULL, /* linkProc */
+ ZipFSListVolumesProc,
+ ZipFSFileAttrStringsProc,
+ ZipFSFileAttrsGetProc,
+ ZipFSFileAttrsSetProc,
+ NULL, /* createDirectoryProc */
+ NULL, /* removeDirectoryProc */
+ NULL, /* deleteFileProc */
+ NULL, /* copyFileProc */
+ NULL, /* renameFileProc */
+ NULL, /* copyDirectoryProc */
+ NULL, /* lstatProc */
+ (Tcl_FSLoadFileProc *) (void *) ZipFSLoadFile,
+ NULL, /* getCwdProc */
+ NULL, /* chdirProc */
+};
+
+/*
+ * The channel type/driver definition used for ZIP archive members.
+ */
+
+static Tcl_ChannelType ZipChannelType = {
+ "zip", /* Type name. */
+ TCL_CHANNEL_VERSION_5,
+ TCL_CLOSE2PROC, /* Close channel, clean instance data */
+ ZipChannelRead, /* Handle read request */
+ ZipChannelWrite, /* Handle write request */
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ ZipChannelSeek, /* Move location of access point, NULL'able */
+#else
+ NULL, /* Move location of access point, NULL'able */
+#endif
+ NULL, /* Set options, NULL'able */
+ NULL, /* Get options, NULL'able */
+ ZipChannelWatchChannel, /* Initialize notifier */
+ ZipChannelGetFile, /* Get OS handle from the channel */
+ ZipChannelClose, /* 2nd version of close channel, NULL'able */
+ NULL, /* Set blocking mode for raw channel,
+ * NULL'able */
+ NULL, /* Function to flush channel, NULL'able */
+ NULL, /* Function to handle event, NULL'able */
+ ZipChannelWideSeek, /* Wide seek function, NULL'able */
+ NULL, /* Thread action function, NULL'able */
+ NULL, /* Truncate function, NULL'able */
+};
+
+/*
+ * Miscellaneous constants.
+ */
+
+#define ERROR_LENGTH ((size_t) -1)
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclIsZipfsPath --
+ *
+ * Checks if the passed path has a zipfs volume prefix.
+ *
+ * Results:
+ * 0 if not a zipfs path
+ * else the length of the zipfs volume prefix
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+int TclIsZipfsPath (const char *path)
+{
+#ifdef _WIN32
+ return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? 0 : ZIPFS_VOLUME_LEN;
+#else
+ int i;
+ for (i = 0; i < ZIPFS_VOLUME_LEN; ++i) {
+ if (path[i] != ZIPFS_VOLUME[i] &&
+ (path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) {
+ return 0;
+ }
+ }
+ return ZIPFS_VOLUME_LEN;
+#endif
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort --
+ *
+ * Inline functions to read and write little-endian 16 and 32 bit
+ * integers from/to buffers representing parts of ZIP archives.
+ *
+ * These take bufferStart and bufferEnd pointers, which are used to
+ * maintain a guarantee that out-of-bounds accesses don't happen when
+ * reading or writing critical directory structures.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline unsigned int
+ZipReadInt(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ const unsigned char *ptr)
+{
+ if (ptr < bufferStart || ptr + 4 > bufferEnd) {
+ Tcl_Panic("out of bounds read(4): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ return ptr[0] | (ptr[1] << 8) | (ptr[2] << 16) |
+ ((unsigned int)ptr[3] << 24);
+}
+
+static inline unsigned short
+ZipReadShort(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ const unsigned char *ptr)
+{
+ if (ptr < bufferStart || ptr + 2 > bufferEnd) {
+ Tcl_Panic("out of bounds read(2): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ return ptr[0] | (ptr[1] << 8);
+}
+
+static inline void
+ZipWriteInt(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ unsigned char *ptr,
+ unsigned int value)
+{
+ if (ptr < bufferStart || ptr + 4 > bufferEnd) {
+ Tcl_Panic("out of bounds write(4): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ ptr[0] = value & 0xff;
+ ptr[1] = (value >> 8) & 0xff;
+ ptr[2] = (value >> 16) & 0xff;
+ ptr[3] = (value >> 24) & 0xff;
+}
+
+static inline void
+ZipWriteShort(
+ const unsigned char *bufferStart,
+ const unsigned char *bufferEnd,
+ unsigned char *ptr,
+ unsigned short value)
+{
+ if (ptr < bufferStart || ptr + 2 > bufferEnd) {
+ Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p",
+ bufferStart, bufferEnd, ptr);
+ }
+ ptr[0] = value & 0xff;
+ ptr[1] = (value >> 8) & 0xff;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ReadLock, WriteLock, Unlock --
+ *
+ * POSIX like rwlock functions to support multiple readers and single
+ * writer on internal structs.
+ *
+ * Limitations:
+ * - a read lock cannot be promoted to a write lock
+ * - a write lock may not be nested
+ *
+ *-------------------------------------------------------------------------
+ */
+
+TCL_DECLARE_MUTEX(ZipFSMutex)
+
+#if TCL_THREADS
+
+static Tcl_Condition ZipFSCond;
+
+static inline void
+ReadLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock < 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock++;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static inline void
+WriteLock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ while (ZipFS.lock != 0) {
+ ZipFS.waiters++;
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL);
+ ZipFS.waiters--;
+ }
+ ZipFS.lock = -1;
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+static inline void
+Unlock(void)
+{
+ Tcl_MutexLock(&ZipFSMutex);
+ if (ZipFS.lock > 0) {
+ --ZipFS.lock;
+ } else if (ZipFS.lock < 0) {
+ ZipFS.lock = 0;
+ }
+ if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) {
+ Tcl_ConditionNotify(&ZipFSCond);
+ }
+ Tcl_MutexUnlock(&ZipFSMutex);
+}
+
+#else /* !TCL_THREADS */
+#define ReadLock() do {} while (0)
+#define WriteLock() do {} while (0)
+#define Unlock() do {} while (0)
+#endif /* TCL_THREADS */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DosTimeDate, ToDosTime, ToDosDate --
+ *
+ * Functions to perform conversions between DOS time stamps and POSIX
+ * time_t.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static time_t
+DosTimeDate(
+ int dosDate,
+ int dosTime)
+{
+ struct tm tm;
+ time_t ret;
+
+ memset(&tm, 0, sizeof(tm));
+ tm.tm_isdst = -1; /* let mktime() deal with DST */
+ tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80;
+ tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1;
+ tm.tm_mday = dosDate & 0x1f;
+ tm.tm_hour = (dosTime & 0xf800) >> 11;
+ tm.tm_min = (dosTime & 0x7e0) >> 5;
+ tm.tm_sec = (dosTime & 0x1f) << 1;
+ ret = mktime(&tm);
+ if (ret == (time_t) -1) {
+ /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */
+ ret = (time_t) 315532800;
+ }
+ return ret;
+}
+
+static int
+ToDosTime(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !TCL_THREADS || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
+ tmp = localtime(&when);
+ tm = *tmp;
+#elif defined(HAVE_LOCALTIME_R)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1);
+}
+
+static int
+ToDosDate(
+ time_t when)
+{
+ struct tm *tmp, tm;
+
+#if !TCL_THREADS || defined(_WIN32)
+ /* Not threaded, or on Win32 which uses thread local storage */
+ tmp = localtime(&when);
+ tm = *tmp;
+#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R)
+ /* Threaded, have reentrant API */
+ tmp = &tm;
+ localtime_r(&when, tmp);
+#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */
+ /* Only using a mutex is safe. */
+ Tcl_MutexLock(&localtimeMutex);
+ tmp = localtime(&when);
+ tm = *tmp;
+ Tcl_MutexUnlock(&localtimeMutex);
+#endif
+ return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * CountSlashes --
+ *
+ * This function counts the number of slashes in a pathname string.
+ *
+ * Results:
+ * Number of slashes found in string.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+CountSlashes(
+ const char *string)
+{
+ int count = 0;
+ const char *p = string;
+
+ while (*p != '\0') {
+ if (*p == '/') {
+ count++;
+ }
+ p++;
+ }
+ return count;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * IsCryptHeaderValid --
+ *
+ * Computes the validity of the encryption header CRC for a ZipEntry.
+ *
+ * Results:
+ * Returns 1 if the header is valid else 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+static int IsCryptHeaderValid(
+ ZipEntry *z,
+ unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN]
+ )
+{
+ /*
+ * There are multiple possibilities. The last one or two bytes of the
+ * encryption header should match the last one or two bytes of the
+ * CRC of the file. Or the last byte of the encryption header should
+ * be the high order byte of the file time. Depending on the archiver
+ * and version, any of the might be in used. We follow libzip in checking
+ * only one byte against both the crc and the time. Note that by design
+ * the check generates high number of false positives in any case.
+ * Also, in case a check is passed when it should not, the final CRC
+ * calculation will (should) catch it. Only difference is it will be
+ * reported as a corruption error instead of incorrect password.
+ */
+ int dosTime = ToDosTime(z->timestamp);
+ if (cryptHeader[11] == (unsigned char)(dosTime >> 8)) {
+ /* Infozip style - Tested with test-password.zip */
+ return 1;
+ }
+ /* DOS time did not match, may be CRC does */
+ if (z->crc32) {
+ /* Pkware style - Tested with test-password2.zip */
+ return (cryptHeader[11] == (unsigned char)(z->crc32 >> 24));
+ }
+
+ /* No CRC, no way to verify. Assume valid */
+ return 1;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * DecodeCryptHeader --
+ *
+ * Decodes the crypt header and validates it.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR on failure.
+ *
+ * Side effects:
+ * On success, keys[] are updated. On failure, an error message is
+ * left in interp if not NULL.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+DecodeCryptHeader(Tcl_Interp *interp,
+ ZipEntry *z,
+ unsigned long keys[3],/* Updated on success. Must have been
+ initialized by caller. */
+ unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN]) /* From zip file content */
+{
+ int i;
+ int ch;
+ int len = z->zipFilePtr->passBuf[0] & 0xFF;
+ char passBuf[260];
+
+ for (i = 0; i < len; i++) {
+ ch = z->zipFilePtr->passBuf[len - i];
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ }
+ passBuf[i] = '\0';
+ init_keys(passBuf, keys, crc32tab);
+ memset(passBuf, 0, sizeof(passBuf));
+ unsigned char encheader[ZIP_CRYPT_HDR_LEN];
+ memcpy(encheader, cryptHeader, ZIP_CRYPT_HDR_LEN);
+ for (i = 0; i < ZIP_CRYPT_HDR_LEN; i++) {
+ ch = cryptHeader[i];
+ ch ^= decrypt_byte(keys, crc32tab);
+ encheader[i] = ch;
+ update_keys(keys, crc32tab, ch);
+ }
+ if (!IsCryptHeaderValid(z, encheader)) {
+ ZIPFS_ERROR(interp, "invalid password");
+ ZIPFS_ERROR_CODE(interp, "PASSWORD");
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DecodeZipEntryText --
+ *
+ * Given a sequence of bytes from an entry in a ZIP central directory,
+ * convert that into a Tcl string. This is complicated because we don't
+ * actually know what encoding is in use! So we try to use UTF-8, and if
+ * that goes wrong, we fall back to a user-specified encoding, or to an
+ * encoding we specify (Windows code page 437), or to ISO 8859-1 if
+ * absolutely nothing else works.
+ *
+ * During Tcl startup, we skip the user-specified encoding and cp437, as
+ * we may well not have any loadable encodings yet. Tcl's own library
+ * files ought to be using ASCII filenames.
+ *
+ * Results:
+ * The decoded filename; the filename is owned by the argument DString.
+ *
+ * Side effects:
+ * Updates dstPtr.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static char *
+DecodeZipEntryText(
+ const unsigned char *inputBytes,
+ unsigned int inputLength,
+ Tcl_DString *dstPtr) /* Must have been initialized by caller! */
+{
+ Tcl_Encoding encoding;
+ const char *src;
+ char *dst;
+ int dstLen, srcLen = inputLength, flags;
+ Tcl_EncodingState state;
+
+ if (inputLength < 1) {
+ return Tcl_DStringValue(dstPtr);
+ }
+
+ /*
+ * We can't use Tcl_ExternalToUtfDString at this point; it has no way to
+ * fail. So we use this modified version of it that can report encoding
+ * errors to us (so we can fall back to something else).
+ *
+ * The utf-8 encoding is implemented internally, and so is guaranteed to
+ * be present.
+ */
+
+ src = (const char *) inputBytes;
+ dst = Tcl_DStringValue(dstPtr);
+ dstLen = dstPtr->spaceAvl - 1;
+ flags = TCL_ENCODING_START | TCL_ENCODING_END |
+ TCL_ENCODING_PROFILE_STRICT; /* Special flag! */
+
+ while (1) {
+ int srcRead, dstWrote;
+ int result = Tcl_ExternalToUtf(NULL, tclUtf8Encoding, src, srcLen, flags,
+ &state, dst, dstLen, &srcRead, &dstWrote, NULL);
+ int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+
+ if (result == TCL_OK) {
+ Tcl_DStringSetLength(dstPtr, soFar);
+ return Tcl_DStringValue(dstPtr);
+ } else if (result != TCL_CONVERT_NOSPACE) {
+ break;
+ }
+
+ flags &= ~TCL_ENCODING_START;
+ src += srcRead;
+ srcLen -= srcRead;
+ if (Tcl_DStringLength(dstPtr) == 0) {
+ Tcl_DStringSetLength(dstPtr, dstLen);
+ }
+ Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
+ dst = Tcl_DStringValue(dstPtr) + soFar;
+ dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
+ }
+
+ /*
+ * Something went wrong. Fall back to another encoding. Those *can* use
+ * Tcl_ExternalToUtfDString().
+ */
+
+ encoding = NULL;
+ if (ZipFS.fallbackEntryEncoding) {
+ encoding = Tcl_GetEncoding(NULL, ZipFS.fallbackEntryEncoding);
+ }
+ if (!encoding) {
+ encoding = Tcl_GetEncoding(NULL, ZIPFS_FALLBACK_ENCODING);
+ }
+ if (!encoding) {
+ /*
+ * Fallback to internal encoding that always converts all bytes.
+ * Should only happen when a filename isn't UTF-8 and we've not got
+ * our encodings initialised for some reason.
+ */
+
+ encoding = Tcl_GetEncoding(NULL, "iso8859-1");
+ }
+
+ char *converted = Tcl_ExternalToUtfDString(encoding,
+ (const char *) inputBytes, inputLength, dstPtr);
+ Tcl_FreeEncoding(encoding);
+ return converted;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * NormalizeMountPoint --
+ *
+ * Converts the passed path into a normalized zipfs mount point
+ * of the form //zipfs:/some/path. On Windows any \ path separators
+ * are converted to /.
+ *
+ * Mount points with a volume will raise an error unless the volume is
+ * zipfs root. Thus D:/foo is not a valid mount point.
+ *
+ * Relative paths and absolute paths without a volume are mapped under
+ * the zipfs root.
+ *
+ * The empty string is mapped to the zipfs root.
+ *
+ * dsPtr is initialized by the function and must be cleared by caller
+ * on a successful return.
+ *
+ * Results:
+ * TCL_OK on success with normalized mount path in dsPtr
+ * TCL_ERROR on fail with error message in interp if not NULL
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+NormalizeMountPoint(Tcl_Interp *interp,
+ const char *mountPath,
+ Tcl_DString *dsPtr) /* Must be initialized by caller! */
+{
+ const char *joiner[2];
+ char *joinedPath;
+ Tcl_Obj *unnormalizedObj;
+ Tcl_Obj *normalizedObj;
+ const char *normalizedPath;
+ Tcl_Size normalizedLen;
+ Tcl_DString dsJoin;
+
+ /*
+ * Several things need to happen here
+ * - Absolute paths containing volumes (drive letter or UNC) raise error
+ * except of course if the volume is zipfs root
+ * - \ -> / and // -> / conversions (except if UNC which is error)
+ * - . and .. have to be dealt with
+ * The first is explicitly checked, the others are dealt with a
+ * combination file join and normalize. Easier than doing it ourselves
+ * and not performance sensitive anyways.
+ */
+
+ joiner[0] = ZIPFS_VOLUME;
+ joiner[1] = mountPath;
+ Tcl_DStringInit(&dsJoin);
+ joinedPath = Tcl_JoinPath(2, joiner, &dsJoin);
+
+ /* Now joinedPath has all \ -> / and // -> / (except UNC) converted. */
+
+ if (!strncmp(ZIPFS_VOLUME, joinedPath, ZIPFS_VOLUME_LEN)) {
+ unnormalizedObj = Tcl_DStringToObj(&dsJoin);
+ } else {
+ if (joinedPath[0] != '/' || joinedPath[1] == '/') {
+ /* mount path was D:/x, D:x or //unc */
+ goto invalidMountPath;
+ }
+ unnormalizedObj = Tcl_ObjPrintf(ZIPFS_VOLUME "%s", joinedPath + 1);
+ }
+ Tcl_IncrRefCount(unnormalizedObj);
+ normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj);
+ if (normalizedObj == NULL) {
+ Tcl_DecrRefCount(unnormalizedObj);
+ goto errorReturn;
+ }
+ Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
+ Tcl_DecrRefCount(unnormalizedObj);
+
+ /* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
+ normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen);
+ Tcl_DStringFree(&dsJoin);
+ Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
+ Tcl_DecrRefCount(normalizedObj);
+ return TCL_OK;
+
+invalidMountPath:
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("Invalid mount path \"%s\"", mountPath));
+ ZIPFS_ERROR_CODE(interp, "MOUNT_PATH");
+ }
+
+errorReturn:
+ Tcl_DStringFree(&dsJoin);
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * MapPathToZipfs --
+ *
+ * Maps a path as stored in a zip archive to its normalized location
+ * under a given zipfs mount point. Relative paths and Unix style
+ * absolute paths go directly under the mount point. Volume relative
+ * paths and absolute paths that have a volume (drive or UNC) are
+ * stripped of the volume before joining the mount point.
+ *
+ * Results:
+ * Pointer to normalized path.
+ *
+ * Side effects:
+ * Stores mapped path in dsPtr.
+ *
+ *------------------------------------------------------------------------
+ */
+static char *
+MapPathToZipfs(Tcl_Interp *interp,
+ const char *mountPath, /* Must be fully normalized */
+ const char *path, /* Archive content path to map */
+ Tcl_DString *dsPtr) /* Must be initialized and cleared
+ by caller */
+{
+ const char *joiner[2];
+ char *joinedPath;
+ Tcl_Obj *unnormalizedObj;
+ Tcl_Obj *normalizedObj;
+ const char *normalizedPath;
+ Tcl_Size normalizedLen;
+ Tcl_DString dsJoin;
+
+ assert(TclIsZipfsPath(mountPath));
+
+ joiner[0] = mountPath;
+ joiner[1] = path;
+#ifndef _WIN32
+ /* On Unix C:/foo/bat is not treated as absolute by JoinPath so check ourself */
+ if (path[0] && path[1] == ':') {
+ joiner[1] += 2;
+ }
+#endif
+ Tcl_DStringInit(&dsJoin);
+ joinedPath = Tcl_JoinPath(2, joiner, &dsJoin);
+
+ if (strncmp(ZIPFS_VOLUME, joinedPath, ZIPFS_VOLUME_LEN)) {
+ /* path was not relative. Strip off the volume (e.g. UNC) */
+ Tcl_Size numParts;
+ const char **partsPtr;
+ Tcl_SplitPath(path, &numParts, &partsPtr);
+ Tcl_DStringFree(&dsJoin);
+ partsPtr[0] = mountPath;
+ (void)Tcl_JoinPath(numParts, partsPtr, &dsJoin);
+ ckfree(partsPtr);
+ }
+ unnormalizedObj = Tcl_DStringToObj(&dsJoin); /* Also resets dsJoin */
+ Tcl_IncrRefCount(unnormalizedObj);
+ normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj);
+ if (normalizedObj == NULL) {
+ /* Should not happen but continue... */
+ normalizedObj = unnormalizedObj;
+ }
+ Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
+ Tcl_DecrRefCount(unnormalizedObj);
+
+ /* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
+ normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen);
+ Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
+ Tcl_DecrRefCount(normalizedObj);
+ return Tcl_DStringValue(dsPtr);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookup --
+ *
+ * This function returns the ZIP entry struct corresponding to the ZIP
+ * archive member of the given file name. Caller must hold the right
+ * lock.
+ *
+ * Results:
+ * Returns the pointer to ZIP entry struct or NULL if the the given file
+ * name could not be found in the global list of ZIP archive members.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipEntry *
+ZipFSLookup(
+ const char *filename)
+{
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
+ if (hPtr) {
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+ }
+ return z;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLookupZip --
+ *
+ * This function gets the structure for a mounted ZIP archive.
+ *
+ * Results:
+ * Returns a pointer to the structure, or NULL if the file is ZIP file is
+ * unknown/not mounted.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipFile *
+ZipFSLookupZip(
+ const char *mountPoint)
+{
+ Tcl_HashEntry *hPtr;
+ ZipFile *zf = NULL;
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ if (hPtr) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ }
+ return zf;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ContainsMountPoint --
+ *
+ * Check if there is a mount point anywhere under the specified path.
+ * Although the function will work for any path, for efficiency reasons
+ * it should be called only after checking ZipFSLookup does not find
+ * the path.
+ *
+ * Caller must hold read lock before calling.
+ *
+ * Results:
+ * 1 - there is at least one mount point under the path
+ * 0 - otherwise
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+ContainsMountPoint (const char *path, int pathLen)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ if (ZipFS.zipHash.numEntries == 0) {
+ return 0;
+ }
+ if (pathLen < 0)
+ pathLen = strlen(path);
+
+ /*
+ * We are looking for the case where the path is //zipfs:/a/b
+ * and there is a mount point //zipfs:/a/b/c/.. below it
+ */
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ /*
+ * Enumerate the contents of the ZIP; it's mounted on the root.
+ * TODO - a holdover from androwish? Tcl does not allow mounting
+ * outside of the //zipfs:/ area.
+ */
+ ZipEntry *z;
+
+ for (z = zf->topEnts; z; z = z->tnext) {
+ int lenz = (int) strlen(z->name);
+ if ((lenz >= pathLen) &&
+ (z->name[pathLen] == '/' || z->name[pathLen] == '\0') &&
+ (strncmp(z->name, path, pathLen) == 0)) {
+ return 1;
+ }
+ }
+ } else if ((zf->mountPointLen >= pathLen) &&
+ (zf->mountPoint[pathLen] == '/' ||
+ zf->mountPoint[pathLen] == '\0' ||
+ pathLen == ZIPFS_VOLUME_LEN) &&
+ (strncmp(zf->mountPoint, path, pathLen) == 0)) {
+ /* Matched standard mount */
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * AllocateZipFile, AllocateZipEntry, AllocateZipChannel --
+ *
+ * Allocates the memory for a datastructure. Always ensures that it is
+ * zeroed out for safety.
+ *
+ * Returns:
+ * The allocated structure, or NULL if allocate fails.
+ *
+ * Side effects:
+ * The interpreter result may be written to on error. Which might fail
+ * (for ZipFile) in a low-memory situation. Always panics if ZipEntry
+ * allocation fails.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline ZipFile *
+AllocateZipFile(
+ Tcl_Interp *interp,
+ size_t mountPointNameLength)
+{
+ size_t size = sizeof(ZipFile) + mountPointNameLength + 1;
+ ZipFile *zf = (ZipFile *) attemptckalloc(size);
+
+ if (!zf) {
+ ZIPFS_MEM_ERROR(interp);
+ } else {
+ memset(zf, 0, size);
+ }
+ return zf;
+}
+
+static inline ZipEntry *
+AllocateZipEntry(void)
+{
+ ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry));
+ memset(z, 0, sizeof(ZipEntry));
+ return z;
+}
+
+static inline ZipChannel *
+AllocateZipChannel(
+ Tcl_Interp *interp)
+{
+ ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel));
+
+ if (!zc) {
+ ZIPFS_MEM_ERROR(interp);
+ } else {
+ memset(zc, 0, sizeof(ZipChannel));
+ }
+ return zc;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCloseArchive --
+ *
+ * This function closes a mounted ZIP archive file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A memory mapped ZIP archive is unmapped, allocated memory is released.
+ * The ZipFile pointer is *NOT* deallocated by this function.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipFSCloseArchive(
+ Tcl_Interp *interp, /* Current interpreter. */
+ ZipFile *zf)
+{
+ if (zf->nameLength) {
+ ckfree(zf->name);
+ }
+ if (zf->isMemBuffer) {
+ /* Pointer to memory */
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ zf->data = NULL;
+ return;
+ }
+
+ /*
+ * Remove the memory mapping, if we have one.
+ */
+
+#ifdef _WIN32
+ if (zf->data && !zf->ptrToFree) {
+ UnmapViewOfFile(zf->data);
+ zf->data = NULL;
+ }
+ if (zf->mountHandle != INVALID_HANDLE_VALUE) {
+ CloseHandle(zf->mountHandle);
+ }
+#else /* !_WIN32 */
+ if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
+ munmap(zf->data, zf->length);
+ zf->data = (unsigned char *) MAP_FAILED;
+ }
+#endif /* _WIN32 */
+
+ if (zf->ptrToFree) {
+ ckfree(zf->ptrToFree);
+ zf->ptrToFree = NULL;
+ }
+ if (zf->chan) {
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFindTOC --
+ *
+ * This function takes a memory mapped zip file and indexes the contents.
+ * When "needZip" is zero an embedded ZIP archive in an executable file
+ * is accepted. Note that we do not support ZIP64.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL.
+ *
+ * Side effects:
+ * The given ZipFile struct is filled with information about the ZIP
+ * archive file. On error, ZipFSCloseArchive is called on zf but
+ * it is not freed.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFindTOC(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i, minoff;
+ const unsigned char *eocdPtr; /* End of Central Directory Record */
+ const unsigned char *start = zf->data;
+ const unsigned char *end = zf->data + zf->length;
+
+ /*
+ * Scan backwards from the end of the file for the signature. This is
+ * necessary because ZIP archives aren't the only things that get tagged
+ * on the end of executables; digital signatures can also go there.
+ */
+
+ eocdPtr = zf->data + zf->length - ZIP_CENTRAL_END_LEN;
+ while (eocdPtr >= start) {
+ if (*eocdPtr == (ZIP_CENTRAL_END_SIG & 0xFF)) {
+ if (ZipReadInt(start, end, eocdPtr) == ZIP_CENTRAL_END_SIG) {
+ break;
+ }
+ eocdPtr -= ZIP_SIG_LEN;
+ } else {
+ --eocdPtr;
+ }
+ }
+ if (eocdPtr < zf->data) {
+ /*
+ * Didn't find it (or not enough space for a central directory!); not
+ * a ZIP archive. This might be OK or a problem.
+ */
+
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "archive directory end signature not found");
+ ZIPFS_ERROR_CODE(interp, "END_SIG");
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+
+ }
+
+ /*
+ * eocdPtr -> End of Central Directory (EOCD) record at this point.
+ * Note this is not same as "end of Central Directory" :-) as EOCD
+ * is a record/structure in the ZIP spec terminology
+ */
+
+ /*
+ * How many files in the archive? If that's bogus, we're done here.
+ */
+
+ zf->numFiles = ZipReadShort(start, end, eocdPtr + ZIP_CENTRAL_ENTS_OFFS);
+ if (zf->numFiles == 0) {
+ if (!needZip) {
+ zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "empty archive");
+ ZIPFS_ERROR_CODE(interp, "EMPTY");
+ goto error;
+ }
+
+ /*
+ * The Central Directory (CD) is a series of Central Directory File
+ * Header (CDFH) records preceding the EOCD (but not necessarily
+ * immediately preceding). cdirZipOffset is the offset into the
+ * *archive* to the CD (first CDFH). The size of the CD is given by
+ * cdirSize. NOTE: offset into archive does NOT mean offset into
+ * (zf->data) as other data may precede the archive in the file.
+ */
+ ptrdiff_t eocdDataOffset = eocdPtr - zf->data;
+ unsigned int cdirZipOffset = ZipReadInt(start, end, eocdPtr + ZIP_CENTRAL_DIRSTART_OFFS);
+ unsigned int cdirSize = ZipReadInt(start, end, eocdPtr + ZIP_CENTRAL_DIRSIZE_OFFS);
+
+ /*
+ * As computed above,
+ * eocdDataOffset < zf->length.
+ * In addition, the following consistency checks must be met
+ * (1) cdirZipOffset <= eocdDataOffset (to prevent under flow in computation of (2))
+ * (2) cdirZipOffset + cdirSize <= eocdDataOffset. Else the CD will be overlapping
+ * the EOCD. Note this automatically means cdirZipOffset+cdirSize < zf->length.
+ */
+ if (!(cdirZipOffset <= (size_t)eocdDataOffset &&
+ cdirSize <= eocdDataOffset - cdirZipOffset)) {
+ if (!needZip) {
+ /* Simply point to end od data */
+ zf->directoryOffset = zf->baseOffset = zf->passOffset = zf->length;
+ return TCL_OK;
+ }
+ ZIPFS_ERROR(interp, "archive directory truncated");
+ ZIPFS_ERROR_CODE(interp, "NO_DIR");
+ goto error;
+ }
+
+ /*
+ * Calculate the offset of the CD in the *data*. If there was no extra
+ * "junk" preceding the archive, this would just be cdirZipOffset but
+ * otherwise we have to account for it.
+ */
+ if (eocdDataOffset - cdirSize > cdirZipOffset) {
+ zf->baseOffset = eocdDataOffset - cdirSize - cdirZipOffset;
+ } else {
+ zf->baseOffset = 0;
+ }
+ zf->passOffset = zf->baseOffset;
+ zf->directoryOffset = cdirZipOffset + zf->baseOffset;
+ zf->directorySize = cdirSize;
+
+ /*
+ * Read the central directory.
+ */
+ const unsigned char *const cdirStart = eocdPtr - cdirSize; /* Start of CD */
+ const unsigned char *dirEntry;
+ minoff = zf->length;
+ for (dirEntry = cdirStart, i = 0; i < zf->numFiles; i++) {
+ if ((dirEntry-cdirStart) + ZIP_CENTRAL_HEADER_LEN > (ptrdiff_t)zf->directorySize) {
+ ZIPFS_ERROR(interp, "truncated directory");
+ ZIPFS_ERROR_CODE(interp, "TRUNC_DIR");
+ goto error;
+ }
+ if (ZipReadInt(start, end, dirEntry) != ZIP_CENTRAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "wrong header signature");
+ ZIPFS_ERROR_CODE(interp, "HDR_SIG");
+ goto error;
+ }
+ int pathlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_PATHLEN_OFFS);
+ int comlen = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ int extra = ZipReadShort(start, end, dirEntry + ZIP_CENTRAL_EXTRALEN_OFFS);
+ size_t localhdr_off = ZipReadInt(start, end, dirEntry + ZIP_CENTRAL_LOCALHDR_OFFS);
+ const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off;
+ if (localP > (cdirStart - ZIP_LOCAL_HEADER_LEN) ||
+ ZipReadInt(start, end, localP) != ZIP_LOCAL_HEADER_SIG) {
+ ZIPFS_ERROR(interp, "Failed to find local header");
+ ZIPFS_ERROR_CODE(interp, "LCL_HDR");
+ goto error;
+ }
+ if (localhdr_off < minoff) {
+ minoff = localhdr_off;
+ }
+ dirEntry += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ if ((dirEntry-cdirStart) < (ptrdiff_t) zf->directorySize) {
+ /* file count and dir size do not match */
+ ZIPFS_ERROR(interp, "short file count");
+ ZIPFS_ERROR_CODE(interp, "FILE_COUNT");
+ goto error;
+ }
+
+ zf->passOffset = minoff + zf->baseOffset;
+
+ /*
+ * If there's also an encoded password, extract that too (but don't decode
+ * yet).
+ * TODO - is this even part of the ZIP "standard". The idea of storing
+ * a password with the archive seems absurd, encoded or not.
+ */
+
+ unsigned char *q = zf->data + zf->passOffset;
+ if ((zf->passOffset >= 6) && (start < q-4) &&
+ (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) {
+ const unsigned char *passPtr;
+
+ i = q[-5];
+ passPtr = q - 5 - i;
+ if (passPtr >= start && passPtr + i < end) {
+ zf->passBuf[0] = i;
+ memcpy(zf->passBuf + 1, passPtr, i);
+ zf->passOffset -= i ? (5 + i) : 0;
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenArchive --
+ *
+ * This function opens a ZIP archive file for reading. An attempt is made
+ * to memory map that file. Otherwise it is read into an allocated memory
+ * buffer. The ZIP archive header is verified and must be valid for the
+ * function to succeed. When "needZip" is zero an embedded ZIP archive in
+ * an executable file is accepted.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL. On error, ZipFSCloseArchive
+ * is called on zf but it is not freed.
+ *
+ * Side effects:
+ * ZIP archive is memory mapped or read into allocated memory, the given
+ * ZipFile struct is filled with information about the ZIP archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSOpenArchive(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *zipname, /* Path to ZIP file to open. */
+ int needZip,
+ ZipFile *zf)
+{
+ size_t i;
+ void *handle;
+
+ zf->nameLength = 0;
+ zf->isMemBuffer = 0;
+#ifdef _WIN32
+ zf->data = NULL;
+ zf->mountHandle = INVALID_HANDLE_VALUE;
+#else /* !_WIN32 */
+ zf->data = (unsigned char *) MAP_FAILED;
+#endif /* _WIN32 */
+ zf->length = 0;
+ zf->numFiles = 0;
+ zf->baseOffset = zf->passOffset = 0;
+ zf->ptrToFree = NULL;
+ zf->passBuf[0] = 0;
+
+ /*
+ * Actually open the file.
+ */
+
+ zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
+ if (!zf->chan) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * See if we can get the OS handle. If we can, we can use that to memory
+ * map the file, which is nice and efficient. However, it totally depends
+ * on the filename pointing to a real regular OS file.
+ *
+ * Opening real filesystem entities that are not files will lead to an
+ * error.
+ */
+
+ if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) == TCL_OK) {
+ if (ZipMapArchive(interp, zf, handle) != TCL_OK) {
+ goto error;
+ }
+ } else {
+ /*
+ * Not an OS file, but rather something in a Tcl VFS. Must copy into
+ * memory.
+ */
+
+ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ /* What's the magic about 64 * 1024 * 1024 ? */
+ if ((zf->length <= ZIP_CENTRAL_END_LEN) ||
+ (zf->length - ZIP_CENTRAL_END_LEN) >
+ (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_ERROR(interp, "illegal file size");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto error;
+ }
+ if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
+ ZIPFS_POSIX_ERROR(interp, "seek error");
+ goto error;
+ }
+ zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length);
+ if (!zf->ptrToFree) {
+ ZIPFS_MEM_ERROR(interp);
+ goto error;
+ }
+ i = Tcl_Read(zf->chan, (char *) zf->data, zf->length);
+ if (i != zf->length) {
+ ZIPFS_POSIX_ERROR(interp, "file read error");
+ goto error;
+ }
+ }
+ /*
+ * Close the Tcl channel. If the file was mapped, the mapping is
+ * unaffected. It is important to close the channel otherwise there is a
+ * potential chicken and egg issue at finalization time as the channels
+ * are closed before the file systems are dismounted.
+ */
+ Tcl_Close(interp, zf->chan);
+ zf->chan = NULL;
+ return ZipFSFindTOC(interp, needZip, zf);
+
+ /*
+ * Handle errors by closing the archive. This includes closing the channel
+ * handle for the archive file.
+ */
+
+ error:
+ ZipFSCloseArchive(interp, zf);
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipMapArchive --
+ *
+ * Wrapper around the platform-specific parts of mmap() (and Windows's
+ * equivalent) because it's not part of the standard channel API.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipMapArchive(
+ Tcl_Interp *interp, /* Interpreter for error reporting. */
+ ZipFile *zf, /* The archive descriptor structure. */
+ void *handle) /* The OS handle to the open archive. */
+{
+#ifdef _WIN32
+ HANDLE hFile = (HANDLE) handle;
+ int readSuccessful;
+
+ /*
+ * Determine the file size.
+ */
+
+ readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0;
+ if (!readSuccessful) {
+ Tcl_WinConvertError(GetLastError());
+ ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
+ return TCL_ERROR;
+ }
+ if (zf->length < ZIP_CENTRAL_END_LEN) {
+ Tcl_SetErrno(EINVAL);
+ ZIPFS_POSIX_ERROR(interp, "truncated file");
+ return TCL_ERROR;
+ }
+ if (zf->length > TCL_SIZE_MAX) {
+ Tcl_SetErrno(EFBIG);
+ ZIPFS_POSIX_ERROR(interp, "zip archive too big");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Map the file.
+ */
+
+ zf->mountHandle = CreateFileMappingW(hFile, 0, PAGE_READONLY, 0,
+ zf->length, 0);
+ if (zf->mountHandle == INVALID_HANDLE_VALUE) {
+ Tcl_WinConvertError(GetLastError());
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+ zf->data = (unsigned char *)
+ MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, zf->length);
+ if (!zf->data) {
+ Tcl_WinConvertError(GetLastError());
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+#else /* !_WIN32 */
+ int fd = PTR2INT(handle);
+
+ /*
+ * Determine the file size.
+ */
+
+ zf->length = lseek(fd, 0, SEEK_END);
+ if (zf->length == ERROR_LENGTH) {
+ ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
+ return TCL_ERROR;
+ }
+ if (zf->length < ZIP_CENTRAL_END_LEN) {
+ Tcl_SetErrno(EINVAL);
+ ZIPFS_POSIX_ERROR(interp, "truncated file");
+ return TCL_ERROR;
+ }
+ lseek(fd, 0, SEEK_SET);
+
+ zf->data = (unsigned char *)
+ mmap(0, zf->length, PROT_READ, MAP_FILE | MAP_PRIVATE, fd, 0);
+ if (zf->data == MAP_FAILED) {
+ ZIPFS_POSIX_ERROR(interp, "file mapping failed");
+ return TCL_ERROR;
+ }
+#endif /* _WIN32 */
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * IsPasswordValid --
+ *
+ * Basic test for whether a passowrd is valid. If the test fails, sets an
+ * error message in the interpreter.
+ *
+ * Returns:
+ * TCL_OK if the test passes, TCL_ERROR if it fails.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline int
+IsPasswordValid(
+ Tcl_Interp *interp,
+ const char *passwd,
+ int pwlen)
+{
+ if ((pwlen > 255) || strchr(passwd, 0xff)) {
+ ZIPFS_ERROR(interp, "illegal password");
+ ZIPFS_ERROR_CODE(interp, "BAD_PASS");
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCatalogFilesystem --
+ *
+ * This function generates the root node for a ZIPFS filesystem by
+ * reading the ZIP's central directory.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with an error message placed
+ * into the given "interp" if it is not NULL. On error, frees zf!!
+ *
+ * Side effects:
+ * Will acquire and release the write lock.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCatalogFilesystem(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ ZipFile *zf, /* Temporary buffer hold archive descriptors */
+ const char *mountPoint, /* Mount point path. Must be fully normalized */
+ const char *passwd, /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+ const char *zipname) /* Path to ZIP file to build a catalog of. */
+{
+ int pwlen, isNew;
+ size_t i;
+ ZipFile *zf0;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString ds, fpBuf;
+ unsigned char *q;
+
+ assert(TclIsZipfsPath(mountPoint)); /* Caller should have normalized */
+
+ Tcl_DStringInit(&ds);
+
+ /*
+ * Basic verification of the password for sanity.
+ */
+
+ pwlen = 0;
+ if (passwd) {
+ pwlen = strlen(passwd);
+ if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) {
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Validate the TOC data. If that's bad, things fall apart.
+ */
+
+ if (zf->baseOffset >= zf->length || zf->passOffset >= zf->length ||
+ zf->directoryOffset >= zf->length) {
+ ZIPFS_ERROR(interp, "bad zip data");
+ ZIPFS_ERROR_CODE(interp, "BAD_ZIP");
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+
+ WriteLock();
+
+ hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
+ if (!isNew) {
+ if (interp) {
+ zf0 = (ZipFile *) Tcl_GetHashValue(hPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s is already mounted on %s", zf0->name, mountPoint));
+ ZIPFS_ERROR_CODE(interp, "MOUNTED");
+ }
+ Unlock();
+ ZipFSCloseArchive(interp, zf);
+ Tcl_DStringFree(&ds);
+ ckfree(zf);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert to a real archive descriptor.
+ */
+
+ zf->mountPoint = (char *) Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
+ zf->mountPointLen = strlen(zf->mountPoint);
+
+ zf->nameLength = strlen(zipname);
+ zf->name = (char *) ckalloc(zf->nameLength + 1);
+ memcpy(zf->name, zipname, zf->nameLength + 1);
+
+ Tcl_SetHashValue(hPtr, zf);
+ if ((zf->passBuf[0] == 0) && pwlen) {
+ int k = 0;
+
+ zf->passBuf[k++] = pwlen;
+ for (i = pwlen; i-- > 0 ;) {
+ zf->passBuf[k++] = (passwd[i] & 0x0f)
+ | pwrot[(passwd[i] >> 4) & 0x0f];
+ }
+ zf->passBuf[k] = '\0';
+ }
+ /* TODO - is this test necessary? When will mountPoint[0] be \0 ? */
+ if (mountPoint[0] != '\0') {
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
+ if (isNew) {
+ z = AllocateZipEntry();
+ Tcl_SetHashValue(hPtr, z);
+
+ z->depth = CountSlashes(mountPoint);
+ assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
+ z->zipFilePtr = zf;
+ z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
+ z->offset = zf->baseOffset;
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ if (!strcmp(z->name, ZIPFS_VOLUME)) {
+ z->flags |= ZE_F_VOLUME; /* Mark as root volume */
+ }
+ Tcl_Time t;
+ Tcl_GetTime(&t);
+ z->timestamp = t.sec;
+ z->next = zf->entries;
+ zf->entries = z;
+ }
+ }
+ q = zf->data + zf->directoryOffset;
+ Tcl_DStringInit(&fpBuf);
+ for (i = 0; i < zf->numFiles; i++) {
+ const unsigned char *start = zf->data;
+ const unsigned char *end = zf->data + zf->length;
+ int extra, isdir = 0, dosTime, dosDate, nbcompr;
+ size_t offs, pathlen, comlen;
+ unsigned char *lq, *gq = NULL;
+ char *fullpath, *path;
+
+ pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS);
+ comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS);
+ extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS);
+ Tcl_DStringSetLength(&ds, 0);
+ path = DecodeZipEntryText(q + ZIP_CENTRAL_HEADER_LEN, pathlen, &ds);
+ if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
+ Tcl_DStringSetLength(&ds, pathlen - 1);
+ path = Tcl_DStringValue(&ds);
+ isdir = 1;
+ }
+ if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) {
+ goto nextent;
+ }
+ lq = zf->data + zf->baseOffset
+ + ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS);
+ if ((lq < start) || (lq + ZIP_LOCAL_HEADER_LEN > end)) {
+ goto nextent;
+ }
+ nbcompr = ZipReadInt(start, end, lq + ZIP_LOCAL_COMPLEN_OFFS);
+ if (!isdir && (nbcompr == 0)
+ && (ZipReadInt(start, end, lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0)
+ && (ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS) == 0)) {
+ gq = q;
+ nbcompr = ZipReadInt(start, end, gq + ZIP_CENTRAL_COMPLEN_OFFS);
+ }
+ offs = (lq - zf->data)
+ + ZIP_LOCAL_HEADER_LEN
+ + ZipReadShort(start, end, lq + ZIP_LOCAL_PATHLEN_OFFS)
+ + ZipReadShort(start, end, lq + ZIP_LOCAL_EXTRALEN_OFFS);
+ if (offs + nbcompr > zf->length) {
+ goto nextent;
+ }
+
+ if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) {
+#ifdef ANDROID
+ /*
+ * When mounting the ZIP archive on the root directory try to
+ * remap top level regular files of the archive to
+ * /assets/.root/... since this directory should not be in a valid
+ * APK due to the leading dot in the file name component. This
+ * trick should make the files AndroidManifest.xml,
+ * resources.arsc, and classes.dex visible to Tcl.
+ */
+ Tcl_DString ds2;
+
+ Tcl_DStringInit(&ds2);
+ Tcl_DStringAppend(&ds2, "assets/.root/", -1);
+ Tcl_DStringAppend(&ds2, path, -1);
+ if (ZipFSLookup(Tcl_DStringValue(&ds2))) {
+ /* should not happen but skip it anyway */
+ Tcl_DStringFree(&ds2);
+ goto nextent;
+ }
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2),
+ Tcl_DStringLength(&ds2));
+ path = Tcl_DStringValue(&ds);
+ Tcl_DStringFree(&ds2);
+#else /* !ANDROID */
+ /*
+ * Regular files skipped when mounting on root.
+ */
+ goto nextent;
+#endif /* ANDROID */
+ }
+
+ Tcl_DStringSetLength(&fpBuf, 0);
+ fullpath = MapPathToZipfs(interp, mountPoint, path, &fpBuf);
+ z = AllocateZipEntry();
+ z->depth = CountSlashes(fullpath);
+ assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
+ z->zipFilePtr = zf;
+ z->isDirectory = isdir;
+ z->isEncrypted =
+ (ZipReadShort(start, end, lq + ZIP_LOCAL_FLAGS_OFFS) & 1)
+ && (nbcompr > ZIP_CRYPT_HDR_LEN);
+ z->offset = offs;
+ if (gq) {
+ z->crc32 = ZipReadInt(start, end, gq + ZIP_CENTRAL_CRC32_OFFS);
+ dosDate = ZipReadShort(start, end, gq + ZIP_CENTRAL_MDATE_OFFS);
+ dosTime = ZipReadShort(start, end, gq + ZIP_CENTRAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(start, end,
+ gq + ZIP_CENTRAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(start, end,
+ gq + ZIP_CENTRAL_COMPMETH_OFFS);
+ } else {
+ z->crc32 = ZipReadInt(start, end, lq + ZIP_LOCAL_CRC32_OFFS);
+ dosDate = ZipReadShort(start, end, lq + ZIP_LOCAL_MDATE_OFFS);
+ dosTime = ZipReadShort(start, end, lq + ZIP_LOCAL_MTIME_OFFS);
+ z->timestamp = DosTimeDate(dosDate, dosTime);
+ z->numBytes = ZipReadInt(start, end,
+ lq + ZIP_LOCAL_UNCOMPLEN_OFFS);
+ z->compressMethod = ZipReadShort(start, end,
+ lq + ZIP_LOCAL_COMPMETH_OFFS);
+ }
+ z->numCompressedBytes = nbcompr;
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
+ if (!isNew) {
+ /* should not happen but skip it anyway */
+ ckfree(z);
+ goto nextent;
+ }
+
+ Tcl_SetHashValue(hPtr, z);
+ z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ z->next = zf->entries;
+ zf->entries = z;
+ if (isdir && (mountPoint[0] == '\0') && (z->depth == ZIPFS_ROOTDIR_DEPTH)) {
+ z->tnext = zf->topEnts;
+ zf->topEnts = z;
+ }
+
+ /*
+ * Make any directory nodes we need. ZIPs are not consistent about
+ * containing directory nodes.
+ */
+
+ if (!z->isDirectory && (z->depth > ZIPFS_ROOTDIR_DEPTH)) {
+ char *dir, *endPtr;
+ ZipEntry *zd;
+
+ Tcl_DStringSetLength(&ds, strlen(z->name) + 8);
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, z->name, -1);
+ dir = Tcl_DStringValue(&ds);
+ for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir);
+ endPtr = strrchr(dir, '/')) {
+ Tcl_DStringSetLength(&ds, endPtr - dir);
+ hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
+ if (!isNew) {
+ /*
+ * Already made. That's fine.
+ */
+ break;
+ }
+
+ zd = AllocateZipEntry();
+ zd->depth = CountSlashes(dir);
+ assert(zd->depth > ZIPFS_ROOTDIR_DEPTH);
+ zd->zipFilePtr = zf;
+ zd->isDirectory = 1;
+ zd->offset = z->offset;
+ zd->timestamp = z->timestamp;
+ zd->compressMethod = ZIP_COMPMETH_STORED;
+ Tcl_SetHashValue(hPtr, zd);
+ zd->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
+ zd->next = zf->entries;
+ zf->entries = zd;
+ if ((mountPoint[0] == '\0') && (zd->depth == ZIPFS_ROOTDIR_DEPTH)) {
+ zd->tnext = zf->topEnts;
+ zf->topEnts = zd;
+ }
+ }
+ }
+ nextent:
+ q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN;
+ }
+ Unlock();
+ Tcl_DStringFree(&fpBuf);
+ Tcl_DStringFree(&ds);
+ Tcl_FSMountsChanged(NULL);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipfsSetup --
+ *
+ * Common initialisation code. ZipFS.initialized must *not* be set prior
+ * to the call.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipfsSetup(void)
+{
+#if TCL_THREADS
+ static const Tcl_Time t = { 0, 0 };
+
+ /*
+ * Inflate condition variable.
+ */
+
+ Tcl_MutexLock(&ZipFSMutex);
+ Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t);
+ Tcl_MutexUnlock(&ZipFSMutex);
+#endif /* TCL_THREADS */
+
+ crc32tab = get_crc_table();
+ Tcl_FSRegister(NULL, &zipfsFilesystem);
+ Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS);
+ ZipFS.idCount = 1;
+ ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE;
+ ZipFS.fallbackEntryEncoding = (char *)
+ ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1);
+ strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING);
+ ZipFS.initialized = 1;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ListMountPoints --
+ *
+ * This procedure lists the mount points and what's mounted there, or
+ * reports whether there are any mounts (if there's no interpreter). The
+ * read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no
+ * interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ListMountPoints(
+ Tcl_Interp *interp)
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ ZipFile *zf;
+ Tcl_Obj *resultList;
+
+ if (!interp) {
+ /*
+ * Are there any entries in the zipHash? Don't need to enumerate them
+ * all to know.
+ */
+
+ return (ZipFS.zipHash.numEntries ? TCL_OK : TCL_BREAK);
+ }
+
+ TclNewObj(resultList);
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
+ zf->mountPoint, -1));
+ Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
+ zf->name, -1));
+ }
+ Tcl_SetObjResult(interp, resultList);
+ return TCL_OK;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * CleanupMount --
+ *
+ * Releases all resources associated with a mounted archive. There
+ * must not be any open files in the archive.
+ *
+ * Caller MUST be holding WriteLock() before calling this function.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory associated with the mounted archive is deallocated.
+ *------------------------------------------------------------------------
+ */
+static void
+CleanupMount(ZipFile *zf) /* Mount point */
+{
+ ZipEntry *z, *znext;
+ Tcl_HashEntry *hPtr;
+ for (z = zf->entries; z; z = znext) {
+ znext = z->next;
+ hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
+ if (hPtr) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ if (z->data) {
+ ckfree(z->data);
+ }
+ ckfree(z);
+ }
+ zf->entries = NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * DescribeMounted --
+ *
+ * This procedure describes what is mounted at the given the mount point.
+ * The interpreter result is not updated if there is nothing mounted at
+ * the given point. The read lock must be held by the caller.
+ *
+ * Results:
+ * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there
+ * and no interpreter).
+ *
+ * Side effects:
+ * Interpreter result may be updated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+DescribeMounted(
+ Tcl_Interp *interp,
+ const char *mountPoint)
+{
+ if (interp) {
+ ZipFile *zf = ZipFSLookupZip(mountPoint);
+
+ if (zf) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
+ return TCL_OK;
+ }
+ }
+ return (interp ? TCL_OK : TCL_BREAK);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint with optional ZIP password.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *zipname, /* Path to ZIP file to mount */
+ const char *mountPoint, /* Mount point path. */
+ const char *passwd) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZipFile *zf;
+ int ret;
+
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ /*
+ * No mount point, so list all mount points and what is mounted there.
+ */
+
+ if (mountPoint == NULL) {
+ ret = ListMountPoints(interp);
+ Unlock();
+ return ret;
+ }
+
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ ret = NormalizeMountPoint(interp, mountPoint, &ds);
+ if (ret != TCL_OK) {
+ Unlock();
+ return ret;
+ }
+ mountPoint = Tcl_DStringValue(&ds);
+
+ if (!zipname) {
+ /*
+ * Mount point but no file, so describe what is mounted at that mount
+ * point.
+ */
+
+ ret = DescribeMounted(interp, mountPoint);
+ Unlock();
+ } else {
+ /* Have both a mount point and a file (name) to mount there. */
+
+ Tcl_Obj *zipPathObj;
+ Tcl_Obj *normZipPathObj;
+
+ Unlock();
+
+ zipPathObj = Tcl_NewStringObj(zipname, -1);
+ Tcl_IncrRefCount(zipPathObj);
+ normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj);
+ if (normZipPathObj == NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("could not normalize zip filename \"%s\"", zipname));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", (void *)NULL);
+ ret = TCL_ERROR;
+ } else {
+ Tcl_IncrRefCount(normZipPathObj);
+ const char *normPath = Tcl_GetString(normZipPathObj);
+ if (passwd == NULL ||
+ (ret = IsPasswordValid(interp, passwd, strlen(passwd))) ==
+ TCL_OK) {
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (zf == NULL) {
+ ret = TCL_ERROR;
+ }
+ else {
+ ret = ZipFSOpenArchive(interp, normPath, 1, zf);
+ if (ret != TCL_OK) {
+ ckfree(zf);
+ }
+ else {
+ ret = ZipFSCatalogFilesystem(
+ interp, zf, mountPoint, passwd, normPath);
+ /* Note zf is already freed on error! */
+ }
+ }
+ }
+ Tcl_DecrRefCount(normZipPathObj);
+ if (ret == TCL_OK && interp) {
+ Tcl_DStringResult(interp, &ds);
+ }
+ }
+ Tcl_DecrRefCount(zipPathObj);
+ }
+
+ Tcl_DStringFree(&ds);
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_MountBuffer --
+ *
+ * This procedure is invoked to mount a given ZIP archive file on a given
+ * mountpoint.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A ZIP archive file is read, analyzed and mounted, resources are
+ * allocated.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const void *data,
+ size_t datalen,
+ const char *mountPoint, /* Mount point path. */
+ int copy)
+{
+ ZipFile *zf;
+ int ret;
+
+ if (mountPoint == NULL || data == NULL) {
+ ZIPFS_ERROR(interp, "mount point and/or data are null");
+ return TCL_ERROR;
+ }
+
+ /* TODO - how come a *read* lock suffices for initialzing ? */
+ ReadLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ ret = NormalizeMountPoint(interp, mountPoint, &ds);
+ if (ret != TCL_OK) {
+ Unlock();
+ return ret;
+ }
+ mountPoint = Tcl_DStringValue(&ds);
+
+ Unlock();
+
+ /*
+ * Have both a mount point and data to mount there.
+ * What's the magic about 64 * 1024 * 1024 ?
+ */
+ ret = TCL_ERROR;
+ if ((datalen <= ZIP_CENTRAL_END_LEN) ||
+ (datalen - ZIP_CENTRAL_END_LEN) >
+ (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
+ ZIPFS_ERROR(interp, "illegal file size");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto done;
+ }
+ zf = AllocateZipFile(interp, strlen(mountPoint));
+ if (zf == NULL) {
+ goto done;
+ }
+ zf->isMemBuffer = 1;
+ zf->length = datalen;
+
+ if (copy) {
+ zf->data = (unsigned char *)attemptckalloc(datalen);
+ if (zf->data == NULL) {
+ ZipFSCloseArchive(interp, zf);
+ ckfree(zf);
+ ZIPFS_MEM_ERROR(interp);
+ goto done;
+ }
+ memcpy(zf->data, data, datalen);
+ zf->ptrToFree = zf->data;
+ }
+ else {
+ zf->data = (unsigned char *)data;
+ zf->ptrToFree = NULL;
+ }
+ ret = ZipFSFindTOC(interp, 1, zf);
+ if (ret != TCL_OK) {
+ ckfree(zf);
+ }
+ else {
+ /* Note ZipFSCatalogFilesystem will free zf on error */
+ ret = ZipFSCatalogFilesystem(
+ interp, zf, mountPoint, NULL, "Memory Buffer");
+ }
+ if (ret == TCL_OK && interp) {
+ Tcl_DStringResult(interp, &ds);
+ }
+
+done:
+ Tcl_DStringFree(&ds);
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Unmount --
+ *
+ * This procedure is invoked to unmount a given ZIP archive.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A mounted ZIP archive file is unmounted, resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ const char *mountPoint) /* Mount point path. */
+{
+ ZipFile *zf;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString dsm;
+ int ret = TCL_OK, unmounted = 0;
+
+ Tcl_DStringInit(&dsm);
+
+ WriteLock();
+ if (!ZipFS.initialized) {
+ goto done;
+ }
+
+ /*
+ * Mount point sometimes is a relative or otherwise denormalized path.
+ * But an absolute name is needed as mount point here.
+ */
+
+ if (NormalizeMountPoint(interp, mountPoint, &dsm) != TCL_OK) {
+ goto done;
+ }
+ mountPoint = Tcl_DStringValue(&dsm);
+
+ hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
+ /* don't report no-such-mount as an error */
+ if (!hPtr) {
+ goto done;
+ }
+
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ if (zf->numOpen > 0) {
+ ZIPFS_ERROR(interp, "filesystem is busy");
+ ZIPFS_ERROR_CODE(interp, "BUSY");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * Now no longer mounted - the rest of the code won't find it - but we're
+ * still cleaning things up.
+ */
+
+ CleanupMount(zf);
+ ZipFSCloseArchive(interp, zf);
+
+ ckfree(zf);
+ unmounted = 1;
+
+ done:
+ Unlock();
+ Tcl_DStringFree(&dsm);
+ if (unmounted) {
+ Tcl_FSMountsChanged(NULL);
+ }
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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;
+ int result;
+
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?zipfile? ?mountpoint? ?password?");
+ return TCL_ERROR;
+ }
+ /*
+ * A single argument is treated as the mountpoint. Two arguments
+ * are treated as zipfile and mountpoint.
+ */
+ if (objc > 1) {
+ if (objc == 2) {
+ mountPoint = Tcl_GetString(objv[1]);
+ } else {
+ /* 2 < objc < 4 */
+ zipFile = Tcl_GetString(objv[1]);
+ mountPoint = Tcl_GetString(objv[2]);
+ if (objc > 3) {
+ password = Tcl_GetString(objv[3]);
+ }
+ }
+ }
+
+ result = TclZipfs_Mount(interp, zipFile, mountPoint, password);
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMountBufferObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mount_data] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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 = NULL; /* Mount point path. */
+ unsigned char *data = NULL;
+ Tcl_Size length;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data mountpoint");
+ return TCL_ERROR;
+ }
+ data = Tcl_GetBytesFromObj(interp, objv[1], &length);
+ mountPoint = Tcl_GetString(objv[2]);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
+ return TclZipfs_MountBuffer(interp, data, length, mountPoint, 1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSRootObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs root] command. It
+ * returns the root that all zipfs file systems are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSRootObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSUnmountObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs unmount] command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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, "mountpoint");
+ return TCL_ERROR;
+ }
+ return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkKeyObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs mkkey] command. It
+ * produces a rotated password to be embedded into an image file.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkKeyObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Size len, i = 0;
+ const char *pw;
+ Tcl_Obj *passObj;
+ unsigned char *passBuf;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "password");
+ return TCL_ERROR;
+ }
+ pw = TclGetStringFromObj(objv[1], &len);
+ if (len == 0) {
+ return TCL_OK;
+ }
+ if (IsPasswordValid(interp, pw, len) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ passObj = Tcl_NewByteArrayObj(NULL, 264);
+ passBuf = Tcl_GetByteArrayFromObj(passObj, (Tcl_Size *)NULL);
+ while (len > 0) {
+ int ch = pw[len - 1];
+
+ passBuf[i++] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ len--;
+ }
+ passBuf[i] = i;
+ i++;
+ ZipWriteInt(passBuf, passBuf + 264, passBuf + i, ZIP_PASSWORD_END_SIG);
+ Tcl_SetByteArrayLength(passObj, i + 4);
+ Tcl_SetObjResult(interp, passObj);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * RandomChar --
+ *
+ * Worker for ZipAddFile(). Picks a random character (range: 0..255)
+ * using Tcl's standard PRNG.
+ *
+ * Returns:
+ * Tcl result code. Updates chPtr with random character on success.
+ *
+ * Side effects:
+ * Advances the PRNG state. May reenter the Tcl interpreter if the user
+ * has replaced the PRNG.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+RandomChar(
+ Tcl_Interp *interp,
+ int step,
+ int *chPtr)
+{
+ double r;
+ Tcl_Obj *ret;
+
+ if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", TCL_INDEX_NONE, 0) != TCL_OK) {
+ goto failed;
+ }
+ ret = Tcl_GetObjResult(interp);
+ if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) {
+ goto failed;
+ }
+ *chPtr = (int) (r * 256);
+ return TCL_OK;
+
+ failed:
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (evaluating PRNG step %d for password encoding)",
+ step));
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipAddFile --
+ *
+ * This procedure is used by ZipFSMkZipOrImg() to add a single file to
+ * the output ZIP archive file being written. A ZipEntry struct about the
+ * input file is added to the given fileHash table for later creation of
+ * the central ZIP directory.
+ *
+ * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it
+ * would always encode comments as UTF-8, if it supported comments.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Input file is read and (compressed and) written to the output ZIP
+ * archive file.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipAddFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathObj, /* Actual name of the file to add. */
+ const char *name, /* Name to use in the ZIP archive, in Tcl's
+ * internal encoding. */
+ Tcl_Channel out, /* The open ZIP archive being built. */
+ const char *passwd, /* Password for encoding the file, or NULL if
+ * the file is to be unprotected. */
+ char *buf, /* Working buffer. */
+ int bufsize, /* Size of buf */
+ Tcl_HashTable *fileHash) /* Where to record ZIP entry metdata so we can
+ * built the central directory. */
+{
+ const unsigned char *start = (unsigned char *) buf;
+ const unsigned char *end = (unsigned char *) buf + bufsize;
+ Tcl_Channel in;
+ Tcl_HashEntry *hPtr;
+ ZipEntry *z;
+ z_stream stream;
+ Tcl_DString zpathDs; /* Buffer for the encoded filename. */
+ const char *zpathExt; /* Filename in external encoding (true
+ * UTF-8). */
+ const char *zpathTcl; /* Filename in Tcl's internal encoding. */
+ int crc, flush, zpathlen;
+ size_t nbyte, nbytecompr, len, olen, align = 0;
+ long long headerStartOffset, dataStartOffset, dataEndOffset;
+ int mtime = 0, isNew, compMeth;
+ unsigned long keys[3], keys0[3];
+ char obuf[4096];
+
+ /*
+ * Trim leading '/' characters. If this results in an empty string, we've
+ * nothing to do.
+ */
+
+ zpathTcl = name;
+ while (zpathTcl && zpathTcl[0] == '/') {
+ zpathTcl++;
+ }
+ if (!zpathTcl || (zpathTcl[0] == '\0')) {
+ return TCL_OK;
+ }
+
+ /*
+ * Convert to encoded form. Note that we use strlen() here; if someone's
+ * crazy enough to embed NULs in filenames, they deserve what they get!
+ */
+
+ zpathExt = Tcl_UtfToExternalDString(tclUtf8Encoding, zpathTcl, -1, &zpathDs);
+ zpathlen = strlen(zpathExt);
+ if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "path too long for \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "PATH_LEN");
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0);
+ if (!in) {
+ Tcl_DStringFree(&zpathDs);
+#ifdef _WIN32
+ /* hopefully a directory */
+ if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+#endif /* _WIN32 */
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ } else {
+ Tcl_StatBuf statBuf;
+
+ if (Tcl_FSStat(pathObj, &statBuf) != -1) {
+ mtime = statBuf.st_mtime;
+ }
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ * Compute the CRC.
+ */
+
+ crc = 0;
+ nbyte = nbytecompr = 0;
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ Tcl_DStringFree(&zpathDs);
+ if (nbyte == 0 && errno == EISDIR) {
+ Tcl_Close(interp, in);
+ return TCL_OK;
+ }
+ readErrorWithChannelOpen:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ if (len == 0) {
+ break;
+ }
+ crc = crc32(crc, (unsigned char *) buf, len);
+ nbyte += len;
+ }
+ if (Tcl_Seek(in, 0, SEEK_SET) == -1) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remember where we've got to so far so we can write the header (after
+ * writing the file).
+ */
+
+ headerStartOffset = Tcl_Tell(out);
+
+ /*
+ * Reserve space for the per-file header. Includes writing the file name
+ * as we already know that.
+ */
+
+ memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
+ memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen);
+ len = zpathlen + ZIP_LOCAL_HEADER_LEN;
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ writeErrorWithChannelOpen:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error on \"%s\": %s",
+ Tcl_GetString(pathObj), Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Align payload to next 4-byte boundary (if necessary) using a dummy
+ * extra entry similar to the zipalign tool from Android's SDK.
+ */
+
+ if ((len + headerStartOffset) & 3) {
+ unsigned char abuf[8];
+ const unsigned char *astart = abuf;
+ const unsigned char *aend = abuf + 8;
+
+ align = 4 + ((len + headerStartOffset) & 3);
+ ZipWriteShort(astart, aend, abuf, 0xffff);
+ ZipWriteShort(astart, aend, abuf + 2, align - 4);
+ ZipWriteInt(astart, aend, abuf + 4, 0x03020100);
+ if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) {
+ goto writeErrorWithChannelOpen;
+ }
+ }
+
+ /*
+ * Set up encryption if we were asked to.
+ */
+
+ if (passwd) {
+ int i, ch, tmp;
+ unsigned char kvbuf[2*ZIP_CRYPT_HDR_LEN];
+
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
+ if (RandomChar(interp, i, &ch) != TCL_OK) {
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+ }
+ kvbuf[i + ZIP_CRYPT_HDR_LEN] = UCHAR(zencode(keys, crc32tab, ch, tmp));
+ }
+ Tcl_ResetResult(interp);
+ init_keys(passwd, keys, crc32tab);
+ for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
+ kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + ZIP_CRYPT_HDR_LEN], tmp));
+ }
+ kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
+ kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
+ len = Tcl_Write(out, (char *) kvbuf, ZIP_CRYPT_HDR_LEN);
+ memset(kvbuf, 0, sizeof(kvbuf));
+ if (len != ZIP_CRYPT_HDR_LEN) {
+ goto writeErrorWithChannelOpen;
+ }
+ memcpy(keys0, keys, sizeof(keys0));
+ nbytecompr += ZIP_CRYPT_HDR_LEN;
+ }
+
+ /*
+ * Save where we've got to in case we need to just store this file.
+ */
+
+ Tcl_Flush(out);
+ dataStartOffset = Tcl_Tell(out);
+
+ /*
+ * Compress the stream.
+ */
+
+ compMeth = ZIP_COMPMETH_DEFLATED;
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8,
+ Z_DEFAULT_STRATEGY) != Z_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "compression init error on \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT");
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+
+ do {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ deflateEnd(&stream);
+ goto readErrorWithChannelOpen;
+ }
+ stream.avail_in = len;
+ stream.next_in = (unsigned char *) buf;
+ flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH;
+ do {
+ stream.avail_out = sizeof(obuf);
+ stream.next_out = (unsigned char *) obuf;
+ len = deflate(&stream, flush);
+ if (len == (size_t) Z_STREAM_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "deflate error on \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DEFLATE");
+ deflateEnd(&stream);
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ olen = sizeof(obuf) - stream.avail_out;
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < olen; i++) {
+ obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
+ }
+ }
+ if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) {
+ deflateEnd(&stream);
+ goto writeErrorWithChannelOpen;
+ }
+ nbytecompr += olen;
+ } while (stream.avail_out == 0);
+ } while (flush != Z_FINISH);
+ deflateEnd(&stream);
+
+ /*
+ * Work out where we've got to.
+ */
+
+ Tcl_Flush(out);
+ dataEndOffset = Tcl_Tell(out);
+
+ if (nbyte - nbytecompr <= 0) {
+ /*
+ * Compressed file larger than input, write it again uncompressed.
+ */
+
+ if (Tcl_Seek(in, 0, SEEK_SET) != 0) {
+ goto seekErr;
+ }
+ if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) {
+ seekErr:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ return TCL_ERROR;
+ }
+ nbytecompr = (passwd ? ZIP_CRYPT_HDR_LEN : 0);
+ while (1) {
+ len = Tcl_Read(in, buf, bufsize);
+ if (len == ERROR_LENGTH) {
+ goto readErrorWithChannelOpen;
+ } else if (len == 0) {
+ break;
+ }
+ if (passwd) {
+ size_t i;
+ int tmp;
+
+ for (i = 0; i < len; i++) {
+ buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
+ }
+ }
+ if ((size_t) Tcl_Write(out, buf, len) != len) {
+ goto writeErrorWithChannelOpen;
+ }
+ nbytecompr += len;
+ }
+ compMeth = ZIP_COMPMETH_STORED;
+
+ /*
+ * Chop off everything after this; it's the over-large compressed data
+ * and we don't know if it is going to get overwritten otherwise.
+ */
+
+ Tcl_Flush(out);
+ dataEndOffset = Tcl_Tell(out);
+ Tcl_TruncateChannel(out, dataEndOffset);
+ }
+ Tcl_Close(interp, in);
+ Tcl_DStringFree(&zpathDs);
+ zpathExt = NULL;
+
+ hPtr = Tcl_CreateHashEntry(fileHash, zpathTcl, &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "non-unique path name \"%s\"", Tcl_GetString(pathObj)));
+ ZIPFS_ERROR_CODE(interp, "DUPLICATE_PATH");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Remember that we've written the file (for central directory generation)
+ * and generate the local (per-file) header in the space that we reserved
+ * earlier.
+ */
+
+ z = AllocateZipEntry();
+ Tcl_SetHashValue(hPtr, z);
+ z->isEncrypted = (passwd ? 1 : 0);
+ z->offset = headerStartOffset;
+ z->crc32 = crc;
+ z->timestamp = mtime;
+ z->numBytes = nbyte;
+ z->numCompressedBytes = nbytecompr;
+ z->compressMethod = compMeth;
+ z->name = (char *) Tcl_GetHashKey(fileHash, hPtr);
+
+ /*
+ * Write final local header information.
+ */
+
+ SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z,
+ zpathlen, align);
+ if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ Tcl_Flush(out);
+ if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) {
+ Tcl_DeleteHashEntry(hPtr);
+ ckfree(z);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "seek error: %s", Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFind --
+ *
+ * Worker for ZipFSMkZipOrImg() that discovers the list of files to add.
+ * Simple wrapper around [zipfs find].
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFind(
+ Tcl_Interp *interp,
+ Tcl_Obj *dirRoot)
+{
+ Tcl_Obj *cmd[2];
+ int result;
+
+ cmd[0] = Tcl_NewStringObj("::tcl::zipfs::find", -1);
+ cmd[1] = dirRoot;
+ Tcl_IncrRefCount(cmd[0]);
+ result = Tcl_EvalObjv(interp, 2, cmd, 0);
+ Tcl_DecrRefCount(cmd[0]);
+ if (result != TCL_OK) {
+ return NULL;
+ }
+ return Tcl_GetObjResult(interp);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ComputeNameInArchive --
+ *
+ * Helper for ZipFSMkZipOrImg() that computes what the actual name of a
+ * file in the ZIP archive should be, stripping a prefix (if appropriate)
+ * and any leading slashes. If the result is an empty string, the entry
+ * should be skipped.
+ *
+ * Returns:
+ * Pointer to the name (in Tcl's internal encoding), which will be in
+ * memory owned by one of the argument objects.
+ *
+ * Side effects:
+ * None (if Tcl_Objs have string representations)
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline const char *
+ComputeNameInArchive(
+ Tcl_Obj *pathObj, /* The path to the origin file */
+ Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
+ * archive */
+ const char *strip, /* A prefix to strip; may be NULL if no
+ * stripping need be done. */
+ Tcl_Size slen) /* The length of the prefix; must be 0 if no
+ * stripping need be done. */
+{
+ const char *name;
+ Tcl_Size len;
+
+ if (directNameObj) {
+ name = Tcl_GetString(directNameObj);
+ } else {
+ name = TclGetStringFromObj(pathObj, &len);
+ if (slen > 0) {
+ if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
+ /*
+ * Guaranteed to be a NUL at the end, which will make this
+ * entry be skipped.
+ */
+
+ return name + len;
+ }
+ name += slen;
+ }
+ }
+ while (name[0] == '/') {
+ ++name;
+ }
+ return name;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipOrImg --
+ *
+ * This procedure is creates a new ZIP archive file or image file given
+ * output filename, input directory of files to be archived, optional
+ * password, and optional image to be prepended to the output ZIP archive
+ * file. It's the core of the implementation of [zipfs mkzip], [zipfs
+ * mkimg], [zipfs lmkzip] and [zipfs lmkimg].
+ *
+ * Tcl *always* encodes filenames in the ZIP as UTF-8. Similarly, it
+ * would always encode comments as UTF-8, if it supported comments.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * A new ZIP archive file or image file is written.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMkZipOrImg(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int isImg, /* Are we making an image? */
+ Tcl_Obj *targetFile, /* What file are we making? */
+ Tcl_Obj *dirRoot, /* What directory do we take files from? Do
+ * not specify at the same time as
+ * mappingList (one must be NULL). */
+ Tcl_Obj *mappingList, /* What files are we putting in, and with what
+ * names? Do not specify at the same time as
+ * dirRoot (one must be NULL). */
+ Tcl_Obj *originFile, /* If we're making an image, what file does
+ * the non-ZIP part of the image come from? */
+ Tcl_Obj *stripPrefix, /* Are we going to strip a prefix from
+ * 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, lobjc;
+ size_t 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;
+ ZipEntry *z;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ Tcl_HashTable fileHash;
+ char *strip = NULL, *pw = NULL, passBuf[264], buf[4096];
+ unsigned char *start = (unsigned char *) buf;
+ unsigned char *end = start + sizeof(buf);
+
+ /*
+ * Caller has verified that the number of arguments is correct.
+ */
+
+ passBuf[0] = 0;
+ if (passwordObj != NULL) {
+ pw = TclGetStringFromObj(passwordObj, &pwlen);
+ if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (pwlen <= 0) {
+ pw = NULL;
+ pwlen = 0;
+ }
+ }
+ if (dirRoot != NULL) {
+ list = ZipFSFind(interp, dirRoot);
+ if (!list) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_IncrRefCount(list);
+ if (TclListObjLengthM(interp, list, &lobjc) != 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");
+ return TCL_ERROR;
+ }
+ if (lobjc == 0) {
+ Tcl_DecrRefCount(list);
+ ZIPFS_ERROR(interp, "empty archive");
+ ZIPFS_ERROR_CODE(interp, "EMPTY");
+ return TCL_ERROR;
+ }
+ if (TclListObjGetElementsM(interp, list, &lobjc, &lobjv) != TCL_OK) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+ out = Tcl_FSOpenFileChannel(interp, targetFile, "wb", 0755);
+ if (out == NULL) {
+ Tcl_DecrRefCount(list);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Copy the existing contents from the image if it is an executable image.
+ * Care must be taken because this might include an existing ZIP, which
+ * needs to be stripped.
+ */
+
+ if (isImg) {
+ ZipFile *zf, zf0;
+ int isMounted = 0;
+ const char *imgName;
+
+ // TODO: normalize the origin file name
+ imgName = (originFile != NULL) ? Tcl_GetString(originFile) :
+ Tcl_GetNameOfExecutable();
+ if (pwlen) {
+ i = 0;
+ for (len = pwlen; len-- > 0;) {
+ int ch = pw[len];
+
+ passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
+ i++;
+ }
+ passBuf[i] = i;
+ ++i;
+ passBuf[i++] = (char) ZIP_PASSWORD_END_SIG;
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16);
+ passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24);
+ passBuf[i] = '\0';
+ }
+
+ /*
+ * Check for mounted image.
+ */
+
+ WriteLock();
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ if (strcmp(zf->name, imgName) == 0) {
+ isMounted = 1;
+ zf->numOpen++;
+ break;
+ }
+ }
+ Unlock();
+
+ if (!isMounted) {
+ zf = &zf0;
+ memset(&zf0, 0, sizeof(ZipFile));
+ }
+ if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
+ /*
+ * Copy everything up to the ZIP-related suffix.
+ */
+
+ if ((size_t) Tcl_Write(out, (char *) zf->data,
+ zf->passOffset) != zf->passOffset) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ return TCL_ERROR;
+ }
+ if (zf == &zf0) {
+ ZipFSCloseArchive(interp, zf);
+ } else {
+ WriteLock();
+ zf->numOpen--;
+ Unlock();
+ }
+ } else {
+ /*
+ * Fall back to read it as plain file which hopefully is a static
+ * tclsh or wish binary with proper zipfs infrastructure built in.
+ */
+
+ if (CopyImageFile(interp, imgName, out) != TCL_OK) {
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_DecrRefCount(list);
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Store the password so that the automounter can find it.
+ */
+
+ len = strlen(passBuf);
+ if (len > 0) {
+ i = Tcl_Write(out, passBuf, len);
+ if (i != len) {
+ Tcl_DecrRefCount(list);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_Close(interp, out);
+ return TCL_ERROR;
+ }
+ }
+ memset(passBuf, 0, sizeof(passBuf));
+ Tcl_Flush(out);
+ }
+
+ /*
+ * Prepare the contents of the ZIP archive.
+ */
+
+ Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
+ if (mappingList == NULL && stripPrefix != NULL) {
+ strip = TclGetStringFromObj(stripPrefix, &slen);
+ if (!slen) {
+ strip = NULL;
+ }
+ }
+ for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) {
+ Tcl_Obj *pathObj = lobjv[i];
+ const char *name = ComputeNameInArchive(pathObj,
+ (mappingList ? lobjv[i + 1] : NULL), strip, slen);
+
+ if (name[0] == '\0') {
+ continue;
+ }
+ if (ZipAddFile(interp, pathObj, name, out, pw, buf, sizeof(buf),
+ &fileHash) != TCL_OK) {
+ goto done;
+ }
+ }
+
+ /*
+ * Construct the contents of the ZIP central directory.
+ */
+
+ directoryStartOffset = Tcl_Tell(out);
+ count = 0;
+ for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) {
+ const char *name = ComputeNameInArchive(lobjv[i],
+ (mappingList ? lobjv[i + 1] : NULL), strip, slen);
+ Tcl_DString ds;
+
+ hPtr = Tcl_FindHashEntry(&fileHash, name);
+ if (!hPtr) {
+ continue;
+ }
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ name = Tcl_UtfToExternalDString(tclUtf8Encoding, z->name, TCL_INDEX_NONE, &ds);
+ len = Tcl_DStringLength(&ds);
+ SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf,
+ z, len);
+ if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN)
+ != ZIP_CENTRAL_HEADER_LEN)
+ || ((size_t) Tcl_Write(out, name, len) != len)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ Tcl_DStringFree(&ds);
+ goto done;
+ }
+ Tcl_DStringFree(&ds);
+ count++;
+ }
+
+ /*
+ * Finalize the central directory.
+ */
+
+ Tcl_Flush(out);
+ suffixStartOffset = Tcl_Tell(out);
+ SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf,
+ count, directoryStartOffset, suffixStartOffset);
+ if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "write error: %s", Tcl_PosixError(interp)));
+ goto done;
+ }
+ Tcl_Flush(out);
+ ret = TCL_OK;
+
+ done:
+ if (ret == TCL_OK) {
+ ret = Tcl_Close(interp, out);
+ } else {
+ Tcl_Close(interp, out);
+ }
+ Tcl_DecrRefCount(list);
+ for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+ ckfree(z);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&fileHash);
+ return ret;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * CopyImageFile --
+ *
+ * A simple file copy function that is used (by ZipFSMkZipOrImg) for
+ * anything that is not an image with a ZIP appended.
+ *
+ * Returns:
+ * A Tcl result code.
+ *
+ * Side effects:
+ * Writes to an output channel.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static int
+CopyImageFile(
+ Tcl_Interp *interp, /* For error reporting. */
+ const char *imgName, /* Where to copy from. */
+ Tcl_Channel out) /* Where to copy to; already open for writing
+ * binary data. */
+{
+ size_t i, k;
+ Tcl_Size m, n;
+ Tcl_Channel in;
+ char buf[4096];
+ const char *errMsg;
+
+ Tcl_ResetResult(interp);
+ in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644);
+ if (!in) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the length of the file (and exclude non-files).
+ */
+
+ i = Tcl_Seek(in, 0, SEEK_END);
+ if (i == ERROR_LENGTH) {
+ errMsg = "seek error";
+ goto copyError;
+ }
+ Tcl_Seek(in, 0, SEEK_SET);
+
+ /*
+ * Copy the whole file, 8 blocks at a time (reasonably efficient). Note
+ * that this totally ignores things like Windows's Alternate File Streams.
+ */
+
+ for (k = 0; k < i; k += m) {
+ m = i - k;
+ if (m > (int) sizeof(buf)) {
+ m = (int) sizeof(buf);
+ }
+ n = Tcl_Read(in, buf, m);
+ if (n == -1) {
+ errMsg = "read error";
+ goto copyError;
+ } else if (n == 0) {
+ break;
+ }
+ m = Tcl_Write(out, buf, n);
+ if (m != n) {
+ errMsg = "write error";
+ goto copyError;
+ }
+ }
+ Tcl_Close(interp, in);
+ return TCL_OK;
+
+ copyError:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s: %s", errMsg, Tcl_PosixError(interp)));
+ Tcl_Close(interp, in);
+ return TCL_ERROR;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * SerializeLocalEntryHeader, SerializeCentralDirectoryEntry,
+ * SerializeCentralDirectorySuffix --
+ *
+ * Create serialized forms of the structures that make up the ZIP
+ * metadata. Note that the both the local entry and the central directory
+ * entry need to have the name of the entry written directly afterwards.
+ *
+ * We could write these as structs except we need to guarantee that we
+ * are writing these out as little-endian values.
+ *
+ * Side effects:
+ * Both update their buffer arguments, but otherwise change nothing.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static void
+SerializeLocalEntryHeader(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ ZipEntry *z, /* The description of what to serialize. */
+ int nameLength, /* The length of the name. */
+ int align) /* The number of alignment bytes. */
+{
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_COMPMETH_OFFS,
+ z->compressMethod);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_MTIME_OFFS,
+ ToDosTime(z->timestamp));
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_MDATE_OFFS,
+ ToDosDate(z->timestamp));
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_COMPLEN_OFFS,
+ z->numCompressedBytes);
+ ZipWriteInt(start, end, buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_PATHLEN_OFFS, nameLength);
+ ZipWriteShort(start, end, buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
+}
+
+static void
+SerializeCentralDirectoryEntry(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ ZipEntry *z, /* The description of what to serialize. */
+ size_t nameLength) /* The length of the name. */
+{
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS,
+ ZIP_CENTRAL_HEADER_SIG);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSIONMADE_OFFS,
+ ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMPMETH_OFFS,
+ z->compressMethod);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_MTIME_OFFS,
+ ToDosTime(z->timestamp));
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_MDATE_OFFS,
+ ToDosDate(z->timestamp));
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_COMPLEN_OFFS,
+ z->numCompressedBytes);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_PATHLEN_OFFS, nameLength);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS,
+ z->offset);
+}
+
+static void
+SerializeCentralDirectorySuffix(
+ const unsigned char *start, /* The start of writable memory. */
+ const unsigned char *end, /* The end of writable memory. */
+ unsigned char *buf, /* Where to serialize to */
+ int entryCount, /* The number of entries in the directory */
+ 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). */
+{
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_END_SIG_OFFS,
+ ZIP_CENTRAL_END_SIG);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKNO_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_DISKDIR_OFFS, 0);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_ENTS_OFFS, entryCount);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_TOTALENTS_OFFS, entryCount);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS,
+ suffixStartOffset - directoryStartOffset);
+ ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS,
+ directoryStartOffset);
+ ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkzip] and [zipfs
+ * lmkzip] commands. See description of ZipFSMkZipOrImg().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ stripPrefix = (objc > 3 ? objv[3] : NULL);
+ 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) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ password = (objc > 3 ? objv[3] : NULL);
+ return ZipFSMkZipOrImg(interp, 0, objv[1], NULL, objv[2], NULL,
+ NULL, password);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd --
+ *
+ * These procedures are invoked to process the [zipfs mkimg] and [zipfs
+ * lmkimg] commands. See description of ZipFSMkZipOrImg().
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "outfile indir ?strip? ?password? ?infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ originFile = (objc > 5 ? objv[5] : NULL);
+ stripPrefix = (objc > 3 ? objv[3] : NULL);
+ 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) {
+ Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password? ?infile?");
+ return TCL_ERROR;
+ }
+ if (Tcl_IsSafe(interp)) {
+ ZIPFS_ERROR(interp, "operation not permitted in a safe interpreter");
+ ZIPFS_ERROR_CODE(interp, "SAFE_INTERP");
+ return TCL_ERROR;
+ }
+
+ originFile = (objc > 4 ? objv[4] : NULL);
+ password = (objc > 3 ? objv[3] : NULL);
+ return ZipFSMkZipOrImg(interp, 1, objv[1], NULL, objv[2],
+ originFile, NULL, password);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSCanonicalObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs canonical] command.
+ * It returns the canonical name for a file within zipfs
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSCanonicalObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ const char *mntPoint = NULL;
+ Tcl_DString dsPath, dsMount;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename");
+ return TCL_ERROR;
+ }
+
+ Tcl_DStringInit(&dsPath);
+ Tcl_DStringInit(&dsMount);
+
+ if (objc == 2) {
+ mntPoint = ZIPFS_VOLUME;
+ } else {
+ if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ mntPoint = Tcl_DStringValue(&dsMount);
+ }
+ (void)MapPathToZipfs(interp,
+ mntPoint,
+ Tcl_GetString(objv[objc - 1]),
+ &dsPath);
+ Tcl_SetObjResult(interp, Tcl_DStringToObj(&dsPath));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSExistsObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs exists] command. It
+ * tests for the existence of a file in the ZIP filesystem and places a
+ * boolean into the interp's result.
+ *
+ * Results:
+ * Always TCL_OK provided the right number of arguments are supplied.
+ *
+ * Side effects:
+ * 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;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ filename = Tcl_GetString(objv[1]);
+
+ ReadLock();
+ exists = ZipFSLookup(filename) != NULL;
+ if (!exists) {
+ /* An ancestor directory of a file ? */
+ exists = ContainsMountPoint(filename, -1);
+ }
+
+ Unlock();
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSInfoObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs info] command. On
+ * success, it returns a Tcl list made up of name of ZIP archive file,
+ * size uncompressed, size compressed, and archive offset of a file in
+ * the ZIP filesystem.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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;
+ int ret;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "filename");
+ return TCL_ERROR;
+ }
+ filename = Tcl_GetString(objv[1]);
+ ReadLock();
+ z = ZipFSLookup(filename);
+ if (z) {
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->zipFilePtr->name, -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numBytes));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewWideIntObj(z->numCompressedBytes));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
+ ret = TCL_OK;
+ } else {
+ Tcl_SetErrno(ENOENT);
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("path \"%s\" not found in any zipfs volume",
+ filename));
+ }
+ ret = TCL_ERROR;
+ }
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListObjCmd --
+ *
+ * This procedure is invoked to process the [zipfs list] command. On
+ * success, it returns a Tcl list of files of the ZIP filesystem which
+ * match a search pattern (glob or regexp).
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * 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;
+ Tcl_HashSearch search;
+ Tcl_Obj *result = Tcl_GetObjResult(interp);
+ const char *options[] = {"-glob", "-regexp", NULL};
+ enum list_options { OPT_GLOB, OPT_REGEXP };
+
+ /*
+ * Parse arguments.
+ */
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ int idx;
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option",
+ 0, &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case OPT_GLOB:
+ pattern = Tcl_GetString(objv[2]);
+ break;
+ case OPT_REGEXP:
+ regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
+ if (!regexp) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ } else if (objc == 2) {
+ pattern = Tcl_GetString(objv[1]);
+ }
+
+ /*
+ * Scan for matching entries.
+ */
+
+ ReadLock();
+ if (pattern) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if (Tcl_StringMatch(z->name, pattern)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else if (regexp) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ } else {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
+ hPtr; hPtr = Tcl_NextHashEntry(&search)) {
+ ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
+
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewStringObj(z->name, -1));
+ }
+ }
+ Unlock();
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_TclLibrary --
+ *
+ * This procedure gets (and possibly finds) the root that Tcl's library
+ * files are mounted under.
+ *
+ * Results:
+ * A Tcl object holding the location (with zero refcount), or NULL if no
+ * Tcl library can be found.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+/* Utility routine to centralize housekeeping */
+static Tcl_Obj *
+ScriptLibrarySetup(
+ const char *dirName)
+{
+ Tcl_Obj *libDirObj = Tcl_NewStringObj(dirName, -1);
+ Tcl_Obj *subDirObj, *searchPathObj;
+
+ TclNewLiteralStringObj(subDirObj, "encoding");
+ Tcl_IncrRefCount(subDirObj);
+ TclNewObj(searchPathObj);
+ Tcl_ListObjAppendElement(NULL, searchPathObj,
+ Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
+ Tcl_DecrRefCount(subDirObj);
+ Tcl_IncrRefCount(searchPathObj);
+ Tcl_SetEncodingSearchPath(searchPathObj);
+ Tcl_DecrRefCount(searchPathObj);
+ return libDirObj;
+}
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(STATIC_BUILD)
+# define LIBRARY_SIZE 64
+ HMODULE hModule;
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char dllName[(MAX_PATH + LIBRARY_SIZE) * 3];
+#endif /* _WIN32 */
+
+ /*
+ * Use the cached value if that has been set; we don't want to repeat the
+ * searching and mounting.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+
+ /*
+ * Look for the library file system within the executable.
+ */
+
+ vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
+ -1);
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+
+ /*
+ * Look for the library file system within the DLL/shared library. Note
+ * that we must mount the zip file and dll before releasing to search.
+ */
+
+#if !defined(STATIC_BUILD)
+#if defined(_WIN32) || defined(__CYGWIN__)
+ hModule = (HMODULE)TclWinGetTclInstance();
+ GetModuleFileNameW(hModule, wName, MAX_PATH);
+#ifdef __CYGWIN__
+ cygwin_conv_path(3, wName, dllName, sizeof(dllName));
+#else
+ WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL);
+#endif
+
+ if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+#elif !defined(NO_DLFCN_H)
+ Dl_info dlinfo;
+ if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
+ && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+#else
+ if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+#endif /* _WIN32 */
+#endif /* !defined(STATIC_BUILD) */
+
+ /*
+ * If anything set the cache (but subsequently failed) go with that
+ * anyway.
+ */
+
+ if (zipfs_literal_tcl_library) {
+ return ScriptLibrarySetup(zipfs_literal_tcl_library);
+ }
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSTclLibraryObjCmd --
+ *
+ * This procedure is invoked to process the
+ * [::tcl::zipfs::tcl_library_init] command, usually called during the
+ * execution of Tcl's interpreter startup. It returns the root that Tcl's
+ * library files are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * 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();
+
+ if (!pResult) {
+ TclNewObj(pResult);
+ }
+ Tcl_SetObjResult(interp, pResult);
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelClose --
+ *
+ * This function is called to close a channel.
+ *
+ * Results:
+ * Always TCL_OK.
+ *
+ * Side effects:
+ * Resources are free'd.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelClose(
+ void *instanceData,
+ TCL_UNUSED(Tcl_Interp *),
+ int flags)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
+ if (info->isEncrypted) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ WriteLock();
+ if (ZipChannelWritable(info)) {
+ /*
+ * Copy channel data back into original file in archive.
+ */
+ ZipEntry *z = info->zipEntryPtr;
+ assert(info->ubufToFree && info->ubuf);
+ unsigned char *newdata;
+ newdata = (unsigned char *)attemptckrealloc(
+ info->ubufToFree,
+ info->numBytes ? info->numBytes : 1); /* Bug [23dd83ce7c] */
+ if (newdata == NULL) {
+ /* Could not reallocate, keep existing buffer */
+ newdata = info->ubufToFree;
+ }
+ info->ubufToFree = NULL; /* Now newdata! */
+ info->ubuf = NULL;
+ info->ubufSize = 0;
+
+ /* Replace old content */
+ if (z->data) {
+ ckfree(z->data);
+ }
+ z->data = newdata; /* May be NULL when ubufToFree was NULL */
+ z->numBytes = z->numCompressedBytes = info->numBytes;
+ assert(z->data || z->numBytes == 0);
+ z->compressMethod = ZIP_COMPMETH_STORED;
+ z->timestamp = time(NULL);
+ z->isDirectory = 0;
+ z->isEncrypted = 0;
+ z->offset = 0;
+ z->crc32 = 0;
+ }
+ info->zipFilePtr->numOpen--;
+ Unlock();
+ if (info->ubufToFree) {
+ assert(info->ubuf);
+ ckfree(info->ubufToFree);
+ info->ubuf = NULL;
+ info->ubufToFree = NULL;
+ info->ubufSize = 0;
+ }
+ ckfree(info);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelRead --
+ *
+ * This function is called to read data from channel.
+ *
+ * Results:
+ * Number of bytes read or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is read and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelRead(
+ void *instanceData,
+ char *buf,
+ int toRead,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ Tcl_Size nextpos;
+
+ if (info->isDirectory < 0) {
+ /*
+ * Special case: when executable combined with ZIP archive file read
+ * data in front of ZIP, i.e. the executable itself.
+ */
+
+ nextpos = info->cursor + toRead;
+ if ((size_t)nextpos > info->zipFilePtr->baseOffset) {
+ toRead = info->zipFilePtr->baseOffset - info->cursor;
+ nextpos = info->zipFilePtr->baseOffset;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ memcpy(buf, info->zipFilePtr->data, toRead);
+ info->cursor = nextpos;
+ *errloc = 0;
+ return toRead;
+ }
+ if (info->isDirectory) {
+ *errloc = EISDIR;
+ return -1;
+ }
+ nextpos = info->cursor + toRead;
+ if (nextpos > info->numBytes) {
+ toRead = info->numBytes - info->cursor;
+ nextpos = info->numBytes;
+ }
+ if (toRead == 0) {
+ return 0;
+ }
+ if (info->isEncrypted) {
+ int i;
+ /*
+ * TODO - when is this code ever exercised? Cannot reach it from
+ * tests. In particular, decryption is always done at channel open
+ * to allow for seeks and random reads.
+ */
+ for (i = 0; i < toRead; i++) {
+ int ch = info->ubuf[i + info->cursor];
+
+ buf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ } else {
+ memcpy(buf, info->ubuf + info->cursor, toRead);
+ }
+ info->cursor = nextpos;
+ *errloc = 0;
+ return toRead;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWrite --
+ *
+ * This function is called to write data into channel.
+ *
+ * Results:
+ * Number of bytes written or -1 on error with error number set.
+ *
+ * Side effects:
+ * Data is written and file pointer is advanced.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelWrite(
+ void *instanceData,
+ const char *buf,
+ int toWrite,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ unsigned long nextpos;
+
+ if (!ZipChannelWritable(info)) {
+ *errloc = EINVAL;
+ return -1;
+ }
+
+ assert(info->ubuf == info->ubufToFree);
+ assert(info->ubufToFree && info->ubufSize > 0);
+ assert(info->ubufSize <= info->maxWrite);
+ assert(info->numBytes <= info->ubufSize);
+ assert(info->cursor <= info->numBytes);
+
+ if (toWrite == 0) {
+ *errloc = 0;
+ return 0;
+ }
+
+ if (info->mode & O_APPEND) {
+ info->cursor = info->numBytes;
+ }
+
+ if (toWrite > (info->maxWrite - info->cursor)) {
+ /* File would grow beyond max size permitted */
+ /* Don't do partial writes in error case. Or should we? */
+ *errloc = EFBIG;
+ return -1;
+ }
+
+ if (toWrite > (info->ubufSize - info->cursor)) {
+ /* grow the buffer. We have already checked will not exceed maxWrite */
+ Tcl_Size needed = info->cursor + toWrite;
+ /* Tack on a bit for future growth. */
+ if (needed < (info->maxWrite - needed/2)) {
+ needed += needed / 2;
+ } else {
+ needed = info->maxWrite;
+ }
+ unsigned char *newBuf =
+ (unsigned char *)attemptckrealloc(info->ubufToFree, needed);
+ if (newBuf == NULL) {
+ *errloc = ENOMEM;
+ return -1;
+ }
+ info->ubufToFree = newBuf;
+ info->ubuf = info->ubufToFree;
+ info->ubufSize = needed;
+ }
+ nextpos = info->cursor + toWrite;
+ memcpy(info->ubuf + info->cursor, buf, toWrite);
+ info->cursor = nextpos;
+ if (info->cursor > info->numBytes) {
+ info->numBytes = info->cursor;
+ }
+ *errloc = 0;
+ return toWrite;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelSeek/ZipChannelWideSeek --
+ *
+ * This function is called to position file pointer of channel.
+ *
+ * Results:
+ * New file position or -1 on error with error number set.
+ *
+ * Side effects:
+ * File pointer is repositioned according to offset and mode.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static long long
+ZipChannelWideSeek(
+ void *instanceData,
+ long long offset,
+ int mode,
+ int *errloc)
+{
+ ZipChannel *info = (ZipChannel *) instanceData;
+ Tcl_Size end;
+
+ if (!ZipChannelWritable(info) && (info->isDirectory < 0)) {
+ /*
+ * Special case: when executable combined with ZIP archive file, seek
+ * within front of ZIP, i.e. the executable itself.
+ */
+ end = info->zipFilePtr->baseOffset;
+ } else if (info->isDirectory) {
+ *errloc = EINVAL;
+ return -1;
+ } else {
+ end = info->numBytes;
+ }
+ switch (mode) {
+ case SEEK_CUR:
+ offset += info->cursor;
+ break;
+ case SEEK_END:
+ offset += end;
+ break;
+ case SEEK_SET:
+ break;
+ default:
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (offset < 0 || offset > TCL_SIZE_MAX) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (ZipChannelWritable(info)) {
+ if (offset > info->maxWrite) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ if (offset > info->numBytes) {
+ info->numBytes = offset;
+ }
+ } else if (offset > end) {
+ *errloc = EINVAL;
+ return -1;
+ }
+ info->cursor = (Tcl_Size) offset;
+ return info->cursor;
+}
+
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+static int
+ZipChannelSeek(
+ void *instanceData,
+ long offset,
+ int mode,
+ int *errloc)
+{
+ return ZipChannelWideSeek(instanceData, offset, mode, errloc);
+}
+#endif
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelWatchChannel --
+ *
+ * This function is called for event notifications on channel. Does
+ * nothing.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipChannelWatchChannel(
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*mask*/)
+{
+ return;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelGetFile --
+ *
+ * This function is called to retrieve OS handle for channel.
+ *
+ * Results:
+ * Always TCL_ERROR since there's never an OS handle for a file within a
+ * ZIP archive.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipChannelGetFile(
+ TCL_UNUSED(void *),
+ TCL_UNUSED(int) /*direction*/,
+ TCL_UNUSED(void **) /*handlePtr*/)
+{
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipChannelOpen --
+ *
+ * This function opens a Tcl_Channel on a file from a mounted ZIP archive
+ * according to given open mode (already parsed by caller).
+ *
+ * Results:
+ * Tcl_Channel on success, or NULL on error.
+ *
+ * Side effects:
+ * Memory is allocated, the file from the ZIP archive is uncompressed.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipChannelOpen(
+ Tcl_Interp *interp, /* Current interpreter. */
+ char *filename, /* What are we opening. */
+ int mode) /* O_WRONLY O_RDWR O_TRUNC flags */
+{
+ ZipEntry *z;
+ ZipChannel *info;
+ int flags = 0;
+ char cname[128];
+
+ int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
+
+ /* Check for unsupported modes. */
+
+ if ((ZipFS.wrmax <= 0) && wr) {
+ Tcl_SetErrno(EACCES);
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("writes not permitted: %s",
+ Tcl_PosixError(interp)));
+ }
+ return NULL;
+ }
+
+ if ((mode & (O_APPEND|O_TRUNC)) && !wr) {
+ Tcl_SetErrno(EINVAL);
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("Invalid flags 0x%x. O_APPEND and "
+ "O_TRUNC require write access: %s",
+ mode,
+ Tcl_PosixError(interp)));
+ }
+ return NULL;
+ }
+
+ /*
+ * Is the file there?
+ */
+
+ WriteLock();
+ z = ZipFSLookup(filename);
+ if (!z) {
+ Tcl_SetErrno(wr ? ENOTSUP : ENOENT);
+ if (interp) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("file \"%s\" not %s: %s",
+ filename,
+ wr ? "created" : "found",
+ Tcl_PosixError(interp)));
+ }
+ goto error;
+ }
+
+ if (z->numBytes < 0 || z->numCompressedBytes < 0 ||
+ z->offset >= z->zipFilePtr->length) {
+ /* Normally this should only happen for zip64. */
+ ZIPFS_ERROR(interp, "file size error (may be zip64)");
+ ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
+ goto error;
+ }
+
+ /* Do we support opening the file that way? */
+
+ if (wr && z->isDirectory) {
+ Tcl_SetErrno(EISDIR);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unsupported file type: %s",
+ Tcl_PosixError(interp)));
+ }
+ goto error;
+ }
+ if ((z->compressMethod != ZIP_COMPMETH_STORED)
+ && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) {
+ ZIPFS_ERROR(interp, "unsupported compression method");
+ ZIPFS_ERROR_CODE(interp, "COMP_METHOD");
+ goto error;
+ }
+ if (wr) {
+ if ((mode & O_TRUNC) == 0 && !z->data && (z->numBytes > ZipFS.wrmax)) {
+ Tcl_SetErrno(EFBIG);
+ ZIPFS_POSIX_ERROR(interp, "file size exceeds max writable");
+ goto error;
+ }
+ flags = TCL_WRITABLE;
+ if (mode & O_RDWR)
+ flags |= TCL_READABLE;
+ } else {
+ /* Read-only */
+ flags |= TCL_READABLE;
+ }
+
+ if (z->isEncrypted) {
+ if (z->numCompressedBytes < ZIP_CRYPT_HDR_LEN) {
+ ZIPFS_ERROR(interp,
+ "decryption failed: truncated decryption header");
+ ZIPFS_ERROR_CODE(interp, "DECRYPT");
+ goto error;
+ }
+ if (z->zipFilePtr->passBuf[0] == 0) {
+ ZIPFS_ERROR(interp, "decryption failed - no password provided");
+ ZIPFS_ERROR_CODE(interp, "DECRYPT");
+ goto error;
+ }
+ }
+
+ info = AllocateZipChannel(interp);
+ if (!info) {
+ goto error;
+ }
+ info->zipFilePtr = z->zipFilePtr;
+ info->zipEntryPtr = z;
+ if (wr) {
+ /* Set up a writable channel. */
+
+ if (InitWritableChannel(interp, info, z, mode) == TCL_ERROR) {
+ ckfree(info);
+ goto error;
+ }
+ } else if (z->data) {
+ /* Set up a readable channel for direct data. */
+
+ info->numBytes = z->numBytes;
+ info->ubuf = z->data;
+ info->ubufToFree = NULL; /* Not dynamically allocated */
+ info->ubufSize = 0;
+ } else {
+ /*
+ * Set up a readable channel.
+ */
+
+ if (InitReadableChannel(interp, info, z) == TCL_ERROR) {
+ ckfree(info);
+ goto error;
+ }
+ }
+
+ if (z->crc32) {
+ if (!(z->flags & ZE_F_CRC_COMPARED)) {
+ int crc = crc32(0, NULL, info->numBytes);
+ crc = crc32(crc, info->ubuf, info->numBytes);
+ z->flags |= ZE_F_CRC_COMPARED;
+ if (crc == z->crc32) {
+ z->flags |= ZE_F_CRC_CORRECT;
+ }
+ }
+ if (!(z->flags & ZE_F_CRC_CORRECT)) {
+ ZIPFS_ERROR(interp, "invalid CRC");
+ ZIPFS_ERROR_CODE(interp, "CRC_FAILED");
+ if (info->ubufToFree) {
+ ckfree(info->ubufToFree);
+ info->ubufSize = 0;
+ }
+ ckfree(info);
+ goto error;
+ }
+ }
+
+ /*
+ * Wrap the ZipChannel into a Tcl_Channel.
+ */
+
+ snprintf(cname, sizeof(cname), "zipfs_%" TCL_Z_MODIFIER "x_%d", z->offset,
+ ZipFS.idCount++);
+ z->zipFilePtr->numOpen++;
+ Unlock();
+ return Tcl_CreateChannel(&ZipChannelType, cname, info, flags);
+
+ error:
+ Unlock();
+ return NULL;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitWritableChannel --
+ *
+ * Assistant for ZipChannelOpen() that sets up a writable channel. It's
+ * up to the caller to actually register the channel.
+ *
+ * Returns:
+ * Tcl result code.
+ *
+ * Side effects:
+ * Allocates memory for the implementation of the channel. Writes to the
+ * interpreter's result on error.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+InitWritableChannel(
+ Tcl_Interp *interp, /* Current interpreter, or NULL (when errors
+ * will be silent). */
+ ZipChannel *info, /* The channel to set up. */
+ ZipEntry *z, /* The zipped file that the channel will write
+ * to. */
+ int mode) /* O_APPEND, O_TRUNC */
+{
+ int i, ch;
+ unsigned char *cbuf = NULL;
+
+ /*
+ * Set up a writable channel.
+ */
+
+ info->mode = mode;
+ info->maxWrite = ZipFS.wrmax;
+
+ info->ubufSize = z->numBytes ? z->numBytes : 1;
+ info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize);
+ info->ubuf = info->ubufToFree;
+ if (info->ubufToFree == NULL) {
+ goto memoryError;
+ }
+
+ if (z->isEncrypted) {
+ assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
+ if (DecodeCryptHeader(
+ interp, z, info->keys, z->zipFilePtr->data + z->offset) !=
+ TCL_OK) {
+ goto error_cleanup;
+ }
+ }
+
+ if (mode & O_TRUNC) {
+ /*
+ * Truncate; nothing there.
+ */
+
+ info->numBytes = 0;
+ z->crc32 = 0; /* Truncated, CRC no longer applicable */
+ } else if (z->data) {
+ /*
+ * Already got uncompressed data.
+ */
+ assert(info->ubufSize >= z->numBytes);
+ memcpy(info->ubuf, z->data, z->numBytes);
+ info->numBytes = z->numBytes;
+ } else {
+ /*
+ * Need to uncompress the existing data.
+ */
+
+ unsigned char *zbuf = z->zipFilePtr->data + z->offset;
+
+ if (z->isEncrypted) {
+ zbuf += ZIP_CRYPT_HDR_LEN;
+ }
+
+ if (z->compressMethod == ZIP_COMPMETH_DEFLATED) {
+ z_stream stream;
+ int err;
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (z->isEncrypted) {
+ unsigned int j;
+
+ /* Min length ZIP_CRYPT_HDR_LEN for keys should already been checked. */
+ assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN);
+
+ stream.avail_in -= ZIP_CRYPT_HDR_LEN;
+ cbuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1);
+ if (!cbuf) {
+ goto memoryError;
+ }
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = zbuf[j];
+ cbuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = cbuf;
+ } else {
+ stream.next_in = zbuf;
+ }
+ stream.next_out = info->ubuf;
+ stream.avail_out = info->ubufSize;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto corruptionError;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+ if ((err != Z_STREAM_END) &&
+ ((err != Z_OK) || (stream.avail_in != 0))) {
+ goto corruptionError;
+ }
+ /* Even if decompression succeeded, counts should be as expected */
+ if ((int) stream.total_out != z->numBytes)
+ goto corruptionError;
+ info->numBytes = z->numBytes;
+ if (cbuf) {
+ ckfree(cbuf);
+ }
+ } else if (z->isEncrypted) {
+ /*
+ * Need to decrypt some otherwise-simple stored data.
+ */
+ if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN ||
+ (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes)
+ goto corruptionError;
+ int len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN;
+ assert(len <= info->ubufSize);
+ for (i = 0; i < len; i++) {
+ ch = zbuf[i];
+ info->ubuf[i] = zdecode(info->keys, crc32tab, ch);
+ }
+ info->numBytes = len;
+ }
+ else {
+ /*
+ * Simple stored data. Copy into our working buffer.
+ */
+ assert(info->ubufSize >= z->numBytes);
+ memcpy(info->ubuf, zbuf, z->numBytes);
+ info->numBytes = z->numBytes;
+ }
+ memset(info->keys, 0, sizeof(info->keys));
+ }
+ if (mode & O_APPEND) {
+ info->cursor = info->numBytes;
+ }
+
+ return TCL_OK;
+
+ memoryError:
+ ZIPFS_MEM_ERROR(interp);
+ goto error_cleanup;
+
+ corruptionError:
+ if (cbuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(cbuf);
+ }
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+
+ error_cleanup:
+ if (info->ubufToFree) {
+ ckfree(info->ubufToFree);
+ info->ubufToFree = NULL;
+ info->ubuf = NULL;
+ info->ubufSize = 0;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitReadableChannel --
+ *
+ * Assistant for ZipChannelOpen() that sets up a readable channel. It's
+ * up to the caller to actually register the channel. Caller should have
+ * validated the passed ZipEntry (byte counts in particular)
+ *
+ * Returns:
+ * Tcl result code.
+ *
+ * Side effects:
+ * Allocates memory for the implementation of the channel. Writes to the
+ * interpreter's result on error.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+InitReadableChannel(
+ Tcl_Interp *interp, /* Current interpreter, or NULL (when errors
+ * will be silent). */
+ ZipChannel *info, /* The channel to set up. */
+ ZipEntry *z) /* The zipped file that the channel will read
+ * from. */
+{
+ unsigned char *ubuf = NULL;
+ int ch;
+
+ info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
+ info->ubuf = z->zipFilePtr->data + z->offset;
+ info->ubufToFree = NULL; /* ubuf memory not allocated */
+ info->ubufSize = 0;
+ info->isDirectory = z->isDirectory;
+ info->isEncrypted = z->isEncrypted;
+ info->mode = O_RDONLY;
+
+ /* Caller must validate - bug [6ed3447a7e] */
+ assert(z->numBytes >= 0 && z->numCompressedBytes >= 0);
+ info->numBytes = z->numBytes;
+
+ if (info->isEncrypted) {
+ assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
+ if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) {
+ goto error_cleanup;
+ }
+ info->ubuf += ZIP_CRYPT_HDR_LEN;
+ }
+
+ if (info->iscompr) {
+ z_stream stream;
+ int err;
+ unsigned int j;
+
+ /*
+ * Data to decode is compressed, and possibly encrpyted too. If
+ * encrypted, local variable ubuf is used to hold the decrypted but
+ * still compressed data.
+ */
+
+ memset(&stream, 0, sizeof(z_stream));
+ stream.zalloc = Z_NULL;
+ stream.zfree = Z_NULL;
+ stream.opaque = Z_NULL;
+ stream.avail_in = z->numCompressedBytes;
+ if (info->isEncrypted) {
+ assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN);
+ stream.avail_in -= ZIP_CRYPT_HDR_LEN;
+ ubuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1);
+ if (!ubuf) {
+ goto memoryError;
+ }
+
+ for (j = 0; j < stream.avail_in; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ stream.next_in = ubuf;
+ } else {
+ stream.next_in = info->ubuf;
+ }
+
+ info->ubufSize = info->numBytes ? info->numBytes : 1;
+ info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize);
+ info->ubuf = info->ubufToFree;
+ stream.next_out = info->ubuf;
+ if (!info->ubuf) {
+ goto memoryError;
+ }
+ stream.avail_out = info->numBytes;
+ if (inflateInit2(&stream, -15) != Z_OK) {
+ goto corruptionError;
+ }
+ err = inflate(&stream, Z_SYNC_FLUSH);
+ inflateEnd(&stream);
+
+ /*
+ * Decompression was successful if we're either in the END state, or
+ * in the OK state with no buffered bytes.
+ */
+
+ if ((err != Z_STREAM_END)
+ && ((err != Z_OK) || (stream.avail_in != 0))) {
+ goto corruptionError;
+ }
+ /* Even if decompression succeeded, counts should be as expected */
+ if ((int) stream.total_out != z->numBytes)
+ goto corruptionError;
+
+ if (ubuf) {
+ info->isEncrypted = 0;
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ } else if (info->isEncrypted) {
+ unsigned int j, len;
+
+ /*
+ * Decode encrypted but uncompressed file, since we support Tcl_Seek()
+ * on it, and it can be randomly accessed later.
+ */
+ if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN ||
+ (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes)
+ goto corruptionError;
+ len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN;
+ ubuf = (unsigned char *) attemptckalloc(len);
+ if (ubuf == NULL) {
+ goto memoryError;
+ }
+ for (j = 0; j < len; j++) {
+ ch = info->ubuf[j];
+ ubuf[j] = zdecode(info->keys, crc32tab, ch);
+ }
+ info->ubufSize = len;
+ info->ubufToFree = ubuf;
+ info->ubuf = info->ubufToFree;
+ ubuf = NULL; /* So it does not inadvertently get free on future changes */
+ info->isEncrypted = 0;
+ }
+ return TCL_OK;
+
+ corruptionError:
+ ZIPFS_ERROR(interp, "decompression error");
+ ZIPFS_ERROR_CODE(interp, "CORRUPT");
+ goto error_cleanup;
+
+ memoryError:
+ ZIPFS_MEM_ERROR(interp);
+
+ error_cleanup:
+ if (ubuf) {
+ memset(info->keys, 0, sizeof(info->keys));
+ ckfree(ubuf);
+ }
+ if (info->ubufToFree) {
+ ckfree(info->ubufToFree);
+ info->ubufToFree = NULL;
+ info->ubuf = NULL;
+ info->ubufSize = 0;
+ }
+
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryStat --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryStat(
+ char *path,
+ Tcl_StatBuf *buf)
+{
+ ZipEntry *z;
+ int ret;
+
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (z) {
+ memset(buf, 0, sizeof(Tcl_StatBuf));
+ if (z->isDirectory) {
+ buf->st_mode = S_IFDIR | 0555;
+ } else {
+ buf->st_mode = S_IFREG | 0555;
+ }
+ buf->st_size = z->numBytes;
+ buf->st_mtime = z->timestamp;
+ buf->st_ctime = z->timestamp;
+ buf->st_atime = z->timestamp;
+ ret = 0;
+ } else if (ContainsMountPoint(path, -1)) {
+ /* An intermediate dir under which a mount exists */
+ memset(buf, 0, sizeof(Tcl_StatBuf));
+ Tcl_Time t;
+ Tcl_GetTime(&t);
+ buf->st_atime = buf->st_mtime = buf->st_ctime = t.sec;
+ buf->st_mode = S_IFDIR | 0555;
+ ret = 0;
+ } else {
+ Tcl_SetErrno(ENOENT);
+ ret = -1;
+ }
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipEntryAccess --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipEntryAccess(
+ char *path,
+ int mode)
+{
+ if (mode & X_OK) {
+ return -1;
+ }
+
+ ReadLock();
+ int access;
+ ZipEntry *z = ZipFSLookup(path);
+ if (z) {
+ /* Currently existing files read/write but dirs are read-only */
+ access = (z->isDirectory && (mode & W_OK)) ? -1 : 0;
+ } else {
+ if (mode & W_OK) {
+ access = -1;
+ } else {
+ /*
+ * Even if entry does not exist, could be intermediate dir
+ * containing a mount point
+ */
+ access = ContainsMountPoint(path, -1) ? 0 : -1;
+ }
+ }
+ Unlock();
+ return access;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSOpenFileChannelProc --
+ *
+ * Open a channel to a file in a mounted ZIP archive. Delegates to
+ * ZipChannelOpen().
+ *
+ * Results:
+ * Tcl_Channel on success, or NULL on error.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+ZipFSOpenFileChannelProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *pathPtr,
+ int mode,
+ TCL_UNUSED(int) /* permissions */)
+{
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return NULL;
+ }
+
+ return ZipChannelOpen(interp, Tcl_GetString(pathPtr), mode);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSStatProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of stat.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSStatProc(
+ Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf)
+{
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryStat(Tcl_GetString(pathPtr), buf);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSAccessProc --
+ *
+ * This function implements the ZIP filesystem specific version of the
+ * library version of access.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSAccessProc(
+ Tcl_Obj *pathPtr,
+ int mode)
+{
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ return ZipEntryAccess(Tcl_GetString(pathPtr), mode);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemSeparatorProc --
+ *
+ * This function returns the separator to be used for a given path. The
+ * object returned should have a refCount of zero
+ *
+ * Results:
+ * A Tcl object, with a refCount of zero. If the caller needs to retain a
+ * reference to the object, it should call Tcl_IncrRefCount, and should
+ * otherwise free the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemSeparatorProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
+{
+ return Tcl_NewStringObj("/", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * AppendWithPrefix --
+ *
+ * Worker for ZipFSMatchInDirectoryProc() that is a wrapper around
+ * Tcl_ListObjAppendElement() which knows about handling prefixes.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static inline void
+AppendWithPrefix(
+ Tcl_Obj *result, /* Where to append a list element to. */
+ Tcl_DString *prefix, /* The prefix to add to the element, or NULL
+ * for don't do that. */
+ const char *name, /* The name to append. */
+ int nameLen) /* The length of the name. May be -1 for
+ * append-up-to-NUL-byte. */
+{
+ if (prefix) {
+ int prefixLength = Tcl_DStringLength(prefix);
+
+ Tcl_DStringAppend(prefix, name, nameLen);
+ Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
+ Tcl_DStringValue(prefix), Tcl_DStringLength(prefix)));
+ Tcl_DStringSetLength(prefix, prefixLength);
+ } else {
+ Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(name, nameLen));
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMatchInDirectoryProc --
+ *
+ * This routine is used by the globbing code to search a directory for
+ * all files which match a given pattern.
+ *
+ * Results:
+ * The return value is a standard Tcl result indicating whether an error
+ * occurred in globbing. Errors are left in interp, good results are
+ * lappend'ed to resultPtr (which must be a valid object).
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSMatchInDirectoryProc(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *result, /* Where to append matched items to. */
+ Tcl_Obj *pathPtr, /* Where we are looking. */
+ const char *pattern, /* What names we are looking for. */
+ Tcl_GlobTypeData *types) /* What types we are looking for. */
+{
+ Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ int scnt, l, dirOnly = -1, mounts = 0;
+ Tcl_Size prefixLen, len, strip = 0;
+ char *pat, *prefix, *path;
+ Tcl_DString dsPref, *prefixBuf = NULL;
+ int foundInHash, notDuplicate;
+ ZipEntry *z;
+
+ if (!normPathPtr) {
+ return -1;
+ }
+ if (types) {
+ dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
+ mounts = (types->type == TCL_GLOB_TYPE_MOUNT);
+ }
+
+ /*
+ * The prefix that gets prepended to results.
+ */
+
+ prefix = TclGetStringFromObj(pathPtr, &prefixLen);
+
+ /*
+ * The (normalized) path we're searching.
+ */
+
+ path = TclGetStringFromObj(normPathPtr, &len);
+
+ Tcl_DStringInit(&dsPref);
+ if (strcmp(prefix, path) == 0) {
+ prefixBuf = NULL;
+ } else {
+ /*
+ * We need to strip the normalized prefix of the filenames and replace
+ * it with the official prefix that we were expecting to get.
+ */
+
+ strip = len + 1;
+ Tcl_DStringAppend(&dsPref, prefix, prefixLen);
+ Tcl_DStringAppend(&dsPref, "/", 1);
+ prefix = Tcl_DStringValue(&dsPref);
+ prefixBuf = &dsPref;
+ }
+
+ ReadLock();
+
+ /*
+ * Are we globbing the mount points?
+ */
+
+ if (mounts) {
+ ZipFSMatchMountPoints(result, normPathPtr, pattern, prefixBuf);
+ goto end;
+ }
+
+ /* Does the path exist in the hash table? */
+ z = ZipFSLookup(path);
+ if (z) {
+ /*
+ * Can we skip the complexity of actual globbing? Without a pattern,
+ * yes; it's a directory existence test.
+ */
+ if (!pattern || (pattern[0] == '\0')) {
+ /* TODO - can't seem to get to this code from script for tests. */
+ /* Follow logic of what tclUnixFile.c does */
+ if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) ||
+ (dirOnly && z->isDirectory)) {
+ Tcl_ListObjAppendElement(NULL, result, pathPtr);
+ }
+ goto end;
+ }
+ } else {
+ /* Not in the hash table but could be an intermediate dir in a mount */
+ if (!pattern || (pattern[0] == '\0')) {
+ /* TODO - can't seem to get to this code from script for tests. */
+ if (dirOnly && ContainsMountPoint(path, len)) {
+ Tcl_ListObjAppendElement(NULL, result, pathPtr);
+ }
+ goto end;
+ }
+ }
+
+ foundInHash = (z != NULL);
+
+ /*
+ * We've got to work for our supper and do the actual globbing. And all
+ * we've got really is an undifferentiated pile of all the filenames we've
+ * got from all our ZIP mounts.
+ */
+
+ l = strlen(pattern);
+ pat = (char *) ckalloc(len + l + 2);
+ memcpy(pat, path, len);
+ while ((len > 1) && (pat[len - 1] == '/')) {
+ --len;
+ }
+ if ((len > 1) || (pat[0] != '/')) {
+ pat[len] = '/';
+ ++len;
+ }
+ memcpy(pat + len, pattern, l + 1);
+ scnt = CountSlashes(pat);
+
+ Tcl_HashTable duplicates;
+ notDuplicate = 0;
+ Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS);
+
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ if (foundInHash) {
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ z = (ZipEntry *)Tcl_GetHashValue(hPtr);
+
+ if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) ||
+ (!dirOnly && z->isDirectory))) {
+ continue;
+ }
+ if ((z->depth == scnt) &&
+ ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */
+ && Tcl_StringCaseMatch(z->name, pat, 0)) {
+ Tcl_CreateHashEntry(&duplicates, z->name + strip, &notDuplicate);
+ assert(notDuplicate);
+ AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
+ }
+ }
+ }
+ if (dirOnly) {
+ /*
+ * Also check paths that are ancestors of a mount. e.g. glob
+ * //zipfs:/a/? with mount at //zipfs:/a/b/c. Also have to be
+ * careful about duplicates, such as when another mount is
+ * //zipfs:/a/b/d
+ */
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
+ if (Tcl_StringCaseMatch(zf->mountPoint, pat, 0)) {
+ const char *tail = zf->mountPoint + len;
+ if (*tail == '\0')
+ continue;
+ const char *end = strchr(tail, '/');
+ Tcl_DStringAppend(&ds,
+ zf->mountPoint + strip,
+ end ? (Tcl_Size)(end - zf->mountPoint) : -1);
+ const char *matchedPath = Tcl_DStringValue(&ds);
+ (void)Tcl_CreateHashEntry(
+ &duplicates, matchedPath, &notDuplicate);
+ if (notDuplicate) {
+ AppendWithPrefix(
+ result, prefixBuf, matchedPath, Tcl_DStringLength(&ds));
+ }
+ Tcl_DStringFree(&ds);
+ }
+ }
+ }
+ Tcl_DeleteHashTable(&duplicates);
+ ckfree(pat);
+
+ end:
+ Unlock();
+ Tcl_DStringFree(&dsPref);
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSMatchMountPoints --
+ *
+ * This routine is a worker for ZipFSMatchInDirectoryProc, used by the
+ * globbing code to search for all mount points files which match a given
+ * pattern.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adds the matching mounts to the list in result, uses prefix as working
+ * space if it is non-NULL.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static void
+ZipFSMatchMountPoints(
+ Tcl_Obj *result, /* The list of matches being built. */
+ Tcl_Obj *normPathPtr, /* Where we're looking from. */
+ const char *pattern, /* What we're looking for. NULL for a full
+ * list. */
+ Tcl_DString *prefix) /* Workspace filled with a prefix for all the
+ * filenames, or NULL if no prefix is to be
+ * used. */
+{
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int l;
+ Tcl_Size normLength;
+ const char *path = TclGetStringFromObj(normPathPtr, &normLength);
+ Tcl_Size len = (size_t) normLength;
+
+ if (len < 1) {
+ /*
+ * Shouldn't happen. But "shouldn't"...
+ */
+
+ return;
+ }
+ l = CountSlashes(path);
+ if (path[len - 1] == '/') {
+ len--;
+ } else {
+ l++;
+ }
+ if (!pattern || (pattern[0] == '\0')) {
+ pattern = "*";
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+
+ if (zf->mountPointLen == 0) {
+ ZipEntry *z;
+
+ /*
+ * Enumerate the contents of the ZIP; it's mounted on the root.
+ * TODO - a holdover from androwish? Tcl does not allow mounting
+ * outside of the //zipfs:/ area.
+ */
+
+ for (z = zf->topEnts; z; z = z->tnext) {
+ Tcl_Size lenz = strlen(z->name);
+
+ if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0)
+ && (z->name[len] == '/')
+ && (CountSlashes(z->name) == l)
+ && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) {
+ AppendWithPrefix(result, prefix, z->name, lenz);
+ }
+ }
+ } else if ((zf->mountPointLen > len + 1)
+ && (strncmp(zf->mountPoint, path, len) == 0)
+ && (zf->mountPoint[len] == '/')
+ && (CountSlashes(zf->mountPoint) == l)
+ && Tcl_StringCaseMatch(zf->mountPoint + len + 1,
+ pattern, 0)) {
+ /*
+ * Standard mount; append if it matches.
+ */
+
+ AppendWithPrefix(result, prefix, zf->mountPoint, zf->mountPointLen);
+ }
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSPathInFilesystemProc --
+ *
+ * This function determines if the given path object is in the ZIP
+ * filesystem.
+ *
+ * Results:
+ * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSPathInFilesystemProc(
+ Tcl_Obj *pathPtr,
+ TCL_UNUSED(void **))
+{
+ Tcl_Size len;
+ char *path;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = TclGetStringFromObj(pathPtr, &len);
+
+ /*
+ * Claim any path under ZIPFS_VOLUME as ours. This is both a necessary
+ * and sufficient condition as zipfs mounts at arbitrary paths are
+ * not permitted (unlike Androwish).
+ */
+ return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? -1 : TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSListVolumesProc --
+ *
+ * Lists the currently mounted ZIP filesystem volumes.
+ *
+ * Results:
+ * The list of volumes.
+ *
+ * Side effects:
+ * None
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSListVolumesProc(void)
+{
+ return Tcl_NewStringObj(ZIPFS_VOLUME, -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrStringsProc --
+ *
+ * This function implements the ZIP filesystem dependent 'file
+ * attributes' subcommand, for listing the set of possible attribute
+ * strings.
+ *
+ * Results:
+ * An array of strings
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+enum ZipFileAttrs {
+ ZIP_ATTR_UNCOMPSIZE,
+ ZIP_ATTR_COMPSIZE,
+ ZIP_ATTR_OFFSET,
+ ZIP_ATTR_MOUNT,
+ ZIP_ATTR_ARCHIVE,
+ ZIP_ATTR_PERMISSIONS,
+ ZIP_ATTR_CRC
+};
+
+static const char *const *
+ZipFSFileAttrStringsProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
+ TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/)
+{
+ /*
+ * Must match up with ZipFileAttrs enum above.
+ */
+
+ static const char *const attrs[] = {
+ "-uncompsize",
+ "-compsize",
+ "-offset",
+ "-mount",
+ "-archive",
+ "-permissions",
+ "-crc",
+ NULL,
+ };
+
+ return attrs;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsGetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'get' operations.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK
+ * was returned) is likely to have a refCount of zero. Either way we must
+ * either store it somewhere (e.g. the Tcl result), or Incr/Decr its
+ * refCount to ensure it is properly freed.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsGetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int index,
+ Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef)
+{
+ Tcl_Size len;
+ int ret = TCL_OK;
+ char *path;
+ ZipEntry *z;
+
+ pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (!pathPtr) {
+ return -1;
+ }
+ path = TclGetStringFromObj(pathPtr, &len);
+ ReadLock();
+ z = ZipFSLookup(path);
+ if (!z && !ContainsMountPoint(path, -1)) {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_POSIX_ERROR(interp, "file not found");
+ ret = TCL_ERROR;
+ goto done;
+ }
+ /* z == NULL for intermediate directories that are ancestors of mounts */
+ switch (index) {
+ case ZIP_ATTR_UNCOMPSIZE:
+ TclNewIntObj(*objPtrRef, z ? z->numBytes : 0);
+ break;
+ case ZIP_ATTR_COMPSIZE:
+ TclNewIntObj(*objPtrRef, z ? z->numCompressedBytes : 0);
+ break;
+ case ZIP_ATTR_OFFSET:
+ TclNewIntObj(*objPtrRef, z ? z->offset : 0);
+ break;
+ case ZIP_ATTR_MOUNT:
+ if (z) {
+ *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
+ z->zipFilePtr->mountPointLen);
+ } else {
+ *objPtrRef = Tcl_NewStringObj("", 0);
+ }
+ break;
+ case ZIP_ATTR_ARCHIVE:
+ *objPtrRef = Tcl_NewStringObj(z ? z->zipFilePtr->name : "", -1);
+ break;
+ case ZIP_ATTR_PERMISSIONS:
+ *objPtrRef = Tcl_NewStringObj("0o555", -1);
+ break;
+ case ZIP_ATTR_CRC:
+ TclNewIntObj(*objPtrRef, z ? z->crc32 : 0);
+ break;
+ default:
+ ZIPFS_ERROR(interp, "unknown attribute");
+ ZIPFS_ERROR_CODE(interp, "FILE_ATTR");
+ ret = TCL_ERROR;
+ }
+
+ done:
+ Unlock();
+ return ret;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFileAttrsSetProc --
+ *
+ * This function implements the ZIP filesystem specific 'file attributes'
+ * subcommand, for 'set' operations.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSFileAttrsSetProc(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*index*/,
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
+ TCL_UNUSED(Tcl_Obj *) /*objPtr*/)
+{
+ ZIPFS_ERROR(interp, "unsupported operation");
+ ZIPFS_ERROR_CODE(interp, "UNSUPPORTED_OP");
+ return TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSFilesystemPathTypeProc --
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ZipFSFilesystemPathTypeProc(
+ TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
+{
+ return Tcl_NewStringObj("zip", -1);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * ZipFSLoadFile --
+ *
+ * This functions deals with loading native object code. If the given
+ * path object refers to a file within the ZIP filesystem, an approriate
+ * error code is returned to delegate loading to the caller (by copying
+ * the file to temp store and loading from there). As fallback when the
+ * file refers to the ZIP file system but is not present, it is looked up
+ * relative to the executable and loaded from there when available.
+ *
+ * Results:
+ * TCL_OK on success, TCL_ERROR otherwise with error message left.
+ *
+ * Side effects:
+ * Loads native code into the process address space.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSLoadFile(
+ Tcl_Interp *interp, /* Current interpreter. */
+ Tcl_Obj *path,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr,
+ int flags)
+{
+ Tcl_FSLoadFileProc2 *loadFileProc;
+#ifdef ANDROID
+ /*
+ * Force loadFileProc to native implementation since the package manager
+ * already extracted the shared libraries from the APK at install time.
+ */
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ }
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return TCL_ERROR;
+#else /* !ANDROID */
+ Tcl_Obj *altPath = NULL;
+ int ret = TCL_ERROR;
+ Tcl_Obj *objs[2] = { NULL, NULL };
+
+ if (Tcl_FSAccess(path, R_OK) == 0) {
+ /*
+ * EXDEV should trigger loading by copying to temp store.
+ */
+
+ Tcl_SetErrno(EXDEV);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ return ret;
+ }
+
+ objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME);
+ if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) {
+ const char *execName = Tcl_GetNameOfExecutable();
+
+ /*
+ * Shared object is not in ZIP but its path prefix is, thus try to
+ * load from directory where the executable came from.
+ */
+
+ TclDecrRefCount(objs[1]);
+ objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL);
+
+ /*
+ * Get directory name of executable manually to deal with cases where
+ * [file dirname [info nameofexecutable]] is equal to [info
+ * nameofexecutable] due to VFS effects.
+ */
+
+ if (execName) {
+ const char *p = strrchr(execName, '/');
+
+ if (p && p > execName + 1) {
+ --p;
+ objs[0] = Tcl_NewStringObj(execName, p - execName);
+ }
+ }
+ if (!objs[0]) {
+ objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(),
+ TCL_PATH_DIRNAME);
+ }
+ if (objs[0]) {
+ altPath = TclJoinPath(2, objs, 0);
+ if (altPath) {
+ Tcl_IncrRefCount(altPath);
+ if (Tcl_FSAccess(altPath, R_OK) == 0) {
+ path = altPath;
+ }
+ }
+ }
+ }
+ if (objs[0]) {
+ Tcl_DecrRefCount(objs[0]);
+ }
+ if (objs[1]) {
+ Tcl_DecrRefCount(objs[1]);
+ }
+
+ loadFileProc = (Tcl_FSLoadFileProc2 *) (void *)
+ tclNativeFilesystem.loadFileProc;
+ if (loadFileProc) {
+ ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
+ } else {
+ Tcl_SetErrno(ENOENT);
+ ZIPFS_ERROR(interp, Tcl_PosixError(interp));
+ }
+ if (altPath) {
+ Tcl_DecrRefCount(altPath);
+ }
+ return ret;
+#endif /* ANDROID */
+}
+
+#endif /* HAVE_ZLIB */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Init --
+ *
+ * Perform per interpreter initialization of this module.
+ *
+ * Results:
+ * The return value is a standard Tcl result.
+ *
+ * Side effects:
+ * Initializes this module if not already initialized, and adds module
+ * related commands to the given interpreter.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Init(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+#ifdef HAVE_ZLIB
+ static const EnsembleImplMap initMap[] = {
+ {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
+ {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1},
+ {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1},
+ /* The 4 entries above are not available in safe interpreters */
+ {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1},
+ {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1},
+ {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1},
+ {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1},
+ {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0},
+ {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0},
+ {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0},
+ {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0},
+ {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ static const char findproc[] =
+ "namespace eval ::tcl::zipfs {}\n"
+ "proc ::tcl::zipfs::Find dir {\n"
+ " set result {}\n"
+ " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n"
+ " return $result\n"
+ " }\n"
+ " foreach file $list {\n"
+ " if {[file tail $file] in {. ..}} {\n"
+ " continue\n"
+ " }\n"
+ " lappend result $file {*}[Find $file]\n"
+ " }\n"
+ " return $result\n"
+ "}\n"
+ "proc ::tcl::zipfs::find {directoryName} {\n"
+ " return [lsort [Find $directoryName]]\n"
+ "}\n";
+
+ /*
+ * One-time initialization.
+ */
+
+ WriteLock();
+ if (!ZipFS.initialized) {
+ ZipfsSetup();
+ }
+ Unlock();
+
+ if (interp) {
+ Tcl_Command ensemble;
+ Tcl_Obj *mapObj;
+
+ Tcl_EvalEx(interp, findproc, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
+ if (!Tcl_IsSafe(interp)) {
+ Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax,
+ TCL_LINK_INT);
+ Tcl_LinkVar(interp, "::tcl::zipfs::fallbackEntryEncoding",
+ (char *) &ZipFS.fallbackEntryEncoding, TCL_LINK_STRING);
+ }
+ ensemble = TclMakeEnsemble(interp, "zipfs",
+ Tcl_IsSafe(interp) ? (initMap + 4) : initMap);
+
+ /*
+ * Add the [zipfs find] subcommand.
+ */
+
+ Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
+ Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
+ Tcl_NewStringObj("::tcl::zipfs::find", -1));
+ Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
+ ZipFSTclLibraryObjCmd, NULL, NULL);
+ Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
+ }
+ return TCL_OK;
+#else /* !HAVE_ZLIB */
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+#endif /* HAVE_ZLIB */
+}
+
+#ifdef HAVE_ZLIB
+
+#if !defined(STATIC_BUILD)
+static int
+ZipfsAppHookFindTclInit(
+ const char *archive)
+{
+ Tcl_Obj *vfsInitScript;
+ int found;
+
+ if (zipfs_literal_tcl_library) {
+ return TCL_ERROR;
+ }
+ if (TclZipfs_Mount(NULL, archive, ZIPFS_ZIP_MOUNT, NULL)) {
+ /* Either the file doesn't exist or it is not a zip archive */
+ return TCL_ERROR;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT;
+ return TCL_OK;
+ }
+
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == 0) {
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+#endif
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclZipfsFinalize --
+ *
+ * Frees all zipfs resources IRRESPECTIVE of open channels (there should
+ * not be any!) etc. To be called at process exit time (from
+ * Tcl_Finalize->TclFinalizeFilesystem)
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up archives loaded into memory.
+ *
+ *------------------------------------------------------------------------
+ */
+void TclZipfsFinalize(void)
+{
+ WriteLock();
+ if (!ZipFS.initialized) {
+ Unlock();
+ return;
+ }
+
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch zipSearch;
+ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &zipSearch); hPtr;
+ hPtr = Tcl_NextHashEntry(&zipSearch)) {
+ ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ CleanupMount(zf); /* Frees file entries belonging to the archive */
+ ZipFSCloseArchive(NULL, zf);
+ ckfree(zf);
+ }
+
+ Tcl_FSUnregister(&zipfsFilesystem);
+ Tcl_DeleteHashTable(&ZipFS.fileHash);
+ Tcl_DeleteHashTable(&ZipFS.zipHash);
+ if (ZipFS.fallbackEntryEncoding) {
+ ckfree(ZipFS.fallbackEntryEncoding);
+ ZipFS.fallbackEntryEncoding = NULL;
+ }
+
+ ZipFS.initialized = 0;
+ Unlock();
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_AppHook --
+ *
+ * Performs the argument munging for the shell
+ *
+ *-------------------------------------------------------------------------
+ */
+
+const char *
+TclZipfs_AppHook(
+#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
+ int *argcPtr, /* Pointer to argc */
+#else
+ TCL_UNUSED(int *), /*argcPtr*/
+#endif
+#ifdef _WIN32
+ TCL_UNUSED(WCHAR ***)) /* argvPtr */
+#else /* !_WIN32 */
+ char ***argvPtr) /* Pointer to argv */
+#endif /* _WIN32 */
+{
+ const char *archive;
+ const char *version = Tcl_InitSubsystems();
+
+#ifdef _WIN32
+ Tcl_FindExecutable(NULL);
+#else
+ Tcl_FindExecutable((*argvPtr)[0]);
+#endif
+ archive = Tcl_GetNameOfExecutable();
+ TclZipfs_Init(NULL);
+
+ /*
+ * Look for init.tcl in one of the locations mounted later in this
+ * function.
+ */
+
+ if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+
+ /*
+ * Set Tcl Encodings
+ */
+
+ if (!zipfs_literal_tcl_library) {
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return version;
+ }
+ }
+#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
+ } else if (*argcPtr > 1) {
+ /*
+ * If the first argument is "install", run the supplied installer
+ * script.
+ */
+
+#ifdef _WIN32
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ archive = Tcl_WCharToUtfDString((*argvPtr)[1], TCL_INDEX_NONE, &ds);
+#else /* !_WIN32 */
+ archive = (*argvPtr)[1];
+#endif /* _WIN32 */
+ if (strcmp(archive, "install") == 0) {
+ Tcl_Obj *vfsInitScript;
+
+ /*
+ * Run this now to ensure the file is present by the time Tcl_Main
+ * wants it.
+ */
+
+ TclZipfs_TclLibrary();
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ }
+ return version;
+ } else if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
+ int found;
+ Tcl_Obj *vfsInitScript;
+
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
+ /*
+ * Startup script should be set before calling Tcl_AppInit
+ */
+
+ Tcl_SetStartupScript(vfsInitScript, NULL);
+ } else {
+ Tcl_DecrRefCount(vfsInitScript);
+ }
+ /* Set Tcl Encodings */
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
+ if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
+ return version;
+ }
+ }
+#ifdef _WIN32
+ Tcl_DStringFree(&ds);
+#endif /* _WIN32 */
+#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */
+ }
+ return version;
+}
+
+#else /* !HAVE_ZLIB */
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
+ *
+ * Dummy version when no ZLIB support available.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+TclZipfs_Mount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(const char *), /* Path to ZIP file to mount. */
+ TCL_UNUSED(const char *), /* Mount point path. */
+ TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if
+ * the ZIP is unprotected. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_MountBuffer(
+ Tcl_Interp *interp, /* Current interpreter. NULLable. */
+ TCL_UNUSED(const void *),
+ TCL_UNUSED(size_t),
+ TCL_UNUSED(const char *), /* Mount point path. */
+ TCL_UNUSED(int))
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+int
+TclZipfs_Unmount(
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(const char *)) /* Mount point path. */
+{
+ ZIPFS_ERROR(interp, "no zlib available");
+ ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
+ return TCL_ERROR;
+}
+
+const char *
+TclZipfs_AppHook(
+ TCL_UNUSED(int *), /*argcPtr*/
+#ifdef _WIN32
+ TCL_UNUSED(WCHAR ***)) /* argvPtr */
+#else /* !_WIN32 */
+ TCL_UNUSED(char ***)) /* Pointer to argv */
+#endif /* _WIN32 */
+{
+ return NULL;
+}
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
+ return NULL;
+}
+
+int TclIsZipfsPath (const char *path)
+{
+ return 0;
+}
+
+#endif /* !HAVE_ZLIB */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index c0922f4..e951060 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -3,9 +3,9 @@
*
* This file provides the interface to the Zlib library.
*
- * Copyright (C) 2004-2005 Pascal Scheffers <pascal@scheffers.net>
- * Copyright (C) 2005 Unitas Software B.V.
- * Copyright (c) 2008-2012 Donal K. Fellows
+ * Copyright © 2004-2005 Pascal Scheffers <pascal@scheffers.net>
+ * Copyright © 2005 Unitas Software B.V.
+ * Copyright © 2008-2012 Donal K. Fellows
*
* Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the
* public domain March 2003.
@@ -64,7 +64,7 @@ typedef struct {
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
- int outPos;
+ Tcl_Size outPos;
int mode; /* Either TCL_ZLIB_STREAM_DEFLATE or
* TCL_ZLIB_STREAM_INFLATE. */
int format; /* Flags from the TCL_ZLIB_FORMAT_* */
@@ -110,14 +110,14 @@ typedef struct {
int format; /* What format of data is going on the wire.
* Needed so that the correct [fconfigure]
* options can be enabled. */
- int readAheadLimit; /* The maximum number of bytes to read from
+ unsigned int readAheadLimit;/* The maximum number of bytes to read from
* the underlying stream in one go. */
z_stream inStream; /* Structure used by zlib for decompression of
* input. */
z_stream outStream; /* Structure used by zlib for compression of
* output. */
char *inBuffer, *outBuffer; /* Working buffers. */
- int inAllocated, outAllocated;
+ size_t inAllocated, outAllocated;
/* Sizes of working buffers. */
GzipHeader inHeader; /* Header read from input stream, when
* decompressing a gzip stream. */
@@ -163,7 +163,7 @@ typedef struct {
static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
-static Tcl_DriverCloseProc ZlibTransformClose;
+static Tcl_DriverClose2Proc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
static Tcl_DriverHandlerProc ZlibTransformEventHandler;
@@ -197,7 +197,7 @@ static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
-static void ZlibTransformTimerRun(ClientData clientData);
+static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
@@ -206,7 +206,7 @@ static void ZlibTransformTimerRun(ClientData clientData);
static const Tcl_ChannelType zlibChannelType = {
"zlib",
TCL_CHANNEL_VERSION_5,
- ZlibTransformClose,
+ TCL_CLOSE2PROC,
ZlibTransformInput,
ZlibTransformOutput,
NULL, /* seekProc */
@@ -214,7 +214,7 @@ static const Tcl_ChannelType zlibChannelType = {
ZlibTransformGetOption,
ZlibTransformWatch,
ZlibTransformGetHandle,
- NULL, /* close2Proc */
+ ZlibTransformClose, /* close2Proc */
ZlibTransformBlockMode,
NULL, /* flushProc */
ZlibTransformEventHandler,
@@ -320,7 +320,7 @@ ConvertError(
* type is known).
*/
- Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZLIB", codeStr, codeStr2, (void *)NULL);
}
static Tcl_Obj *
@@ -354,7 +354,7 @@ ConvertErrorToList(
return Tcl_NewListObj(4, objv);
case Z_NEED_DICT:
TclNewLiteralStringObj(objv[2], "NEED_DICT");
- objv[3] = Tcl_NewWideIntObj((Tcl_WideInt) adler);
+ TclNewIntObj(objv[3], (Tcl_WideInt)adler);
return Tcl_NewListObj(4, objv);
/*
@@ -423,6 +423,7 @@ GenerateHeader(
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
+ Tcl_WideInt wideValue = 0;
const char *valueStr;
Tcl_Encoding latin1enc;
static const char *const types[] = {
@@ -442,18 +443,21 @@ GenerateHeader(
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len,
- TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR, &state,
+ TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
if (result != TCL_OK) {
- if (result == TCL_CONVERT_UNKNOWN) {
- Tcl_AppendResult(interp, "Comment contains characters > 0xFF", NULL);
- } else {
- Tcl_AppendResult(interp, "Comment too large for zip", NULL);
+ if (interp) {
+ if (result == TCL_CONVERT_UNKNOWN) {
+ Tcl_AppendResult(
+ interp, "Comment contains characters > 0xFF", (void *)NULL);
+ } else {
+ Tcl_AppendResult(interp, "Comment too large for zip", (void *)NULL);
+ }
}
- result = TCL_ERROR;
+ result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR*/
goto error;
}
headerPtr->nativeCommentBuf[len] = '\0';
@@ -474,18 +478,22 @@ GenerateHeader(
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
- valueStr = Tcl_GetStringFromObj(value, &len);
+ valueStr = TclGetStringFromObj(value, &len);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len,
- TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR, &state,
+ TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state,
headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len,
NULL);
if (result != TCL_OK) {
- if (result == TCL_CONVERT_UNKNOWN) {
- Tcl_AppendResult(interp, "Filename contains characters > 0xFF", NULL);
- } else {
- Tcl_AppendResult(interp, "Filename too large for zip", NULL);
+ if (interp) {
+ if (result == TCL_CONVERT_UNKNOWN) {
+ Tcl_AppendResult(
+ interp, "Filename contains characters > 0xFF", (void *)NULL);
+ } else {
+ Tcl_AppendResult(
+ interp, "Filename too large for zip", (void *)NULL);
+ }
}
- result = TCL_ERROR;
+ result = TCL_ERROR; /* TCL_CONVERT_* -> TCL_ERROR*/
goto error;
}
headerPtr->nativeFilenameBuf[len] = '\0';
@@ -509,10 +517,11 @@ GenerateHeader(
if (GetValue(interp, dictObj, "time", &value) != TCL_OK) {
goto error;
- } else if (value != NULL && Tcl_GetLongFromObj(interp, value,
- (long *) &headerPtr->header.time) != TCL_OK) {
+ } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value,
+ &wideValue) != TCL_OK) {
goto error;
}
+ headerPtr->header.time = wideValue;
if (GetValue(interp, dictObj, "type", &value) != TCL_OK) {
goto error;
@@ -567,9 +576,9 @@ ExtractHeader(
}
}
- Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
+ Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, TCL_INDEX_NONE,
&tmp);
- SetValue(dictObj, "comment", TclDStringToObj(&tmp));
+ SetValue(dictObj, "comment", Tcl_DStringToObj(&tmp));
}
SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
if (headerPtr->name != Z_NULL) {
@@ -584,15 +593,15 @@ ExtractHeader(
}
}
- Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
+ Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, TCL_INDEX_NONE,
&tmp);
- SetValue(dictObj, "filename", TclDStringToObj(&tmp));
+ SetValue(dictObj, "filename", Tcl_DStringToObj(&tmp));
}
if (headerPtr->os != 255) {
- SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os));
+ SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os));
}
if (headerPtr->time != 0 /* magic - no time */) {
- SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time));
+ SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time));
}
if (headerPtr->text != Z_UNKNOWN) {
SetValue(dictObj, "type",
@@ -824,7 +833,7 @@ Tcl_ZlibStreamInit(
*/
if (interp != NULL) {
- if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) {
+ if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", TCL_INDEX_NONE, 0) != TCL_OK) {
goto error;
}
Tcl_DStringInit(&cmdname);
@@ -834,7 +843,7 @@ Tcl_ZlibStreamInit(
NULL, 0) != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"BUG: Stream command name already exists", -1));
- Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", (void *)NULL);
Tcl_DStringFree(&cmdname);
goto error;
}
@@ -906,7 +915,7 @@ Tcl_ZlibStreamInit(
static void
ZlibStreamCmdDelete(
- ClientData cd)
+ void *cd)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
@@ -1174,6 +1183,11 @@ Tcl_ZlibStreamSetCompressionDictionary(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
+ if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL,
+ compressionDictionaryObj, NULL))) {
+ /* Missing or invalid compression dictionary */
+ compressionDictionaryObj = NULL;
+ }
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
@@ -1214,18 +1228,24 @@ Tcl_ZlibStreamPut(
char *dataTmp = NULL;
int e;
int size, outSize, toStore;
+ unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
- Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
+ Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", (void *)NULL);
}
return TCL_ERROR;
}
+ bytes = Tcl_GetBytesFromObj(zshPtr->interp, data, &size);
+ if (bytes == NULL) {
+ return TCL_ERROR;
+ }
+
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
- zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size);
+ zshPtr->stream.next_in = bytes;
zshPtr->stream.avail_in = size;
/*
@@ -1337,10 +1357,10 @@ Tcl_ZlibStreamGet(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
int e;
- int i, listLen, itemLen, dataPos = 0;
+ Tcl_Size listLen, i, itemLen, dataPos = 0;
Tcl_Obj *itemObj;
unsigned char *dataPtr, *itemPtr;
- int existing;
+ Tcl_Size existing;
/*
* Getting beyond the of stream, just return empty string.
@@ -1350,7 +1370,9 @@ Tcl_ZlibStreamGet(
return TCL_OK;
}
- (void) Tcl_GetByteArrayFromObj(data, &existing);
+ if (NULL == Tcl_GetBytesFromObj(zshPtr->interp, data, &existing)) {
+ return TCL_ERROR;
+ }
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
@@ -1380,7 +1402,7 @@ Tcl_ZlibStreamGet(
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = NULL;
}
- TclListObjLength(NULL, zshPtr->inData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->inData, &listLen);
if (listLen > 0) {
/*
* There is more input available, get it from the list and
@@ -1429,7 +1451,7 @@ Tcl_ZlibStreamGet(
e = inflate(&zshPtr->stream, zshPtr->flush);
}
};
- TclListObjLength(NULL, zshPtr->inData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->inData, &listLen);
while ((zshPtr->stream.avail_out > 0)
&& (e == Z_OK || e == Z_BUF_ERROR) && (listLen > 0)) {
@@ -1444,7 +1466,7 @@ Tcl_ZlibStreamGet(
"unexpected zlib internal state during"
" decompression", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
- NULL);
+ (void *)NULL);
}
Tcl_SetByteArrayLength(data, existing);
return TCL_ERROR;
@@ -1509,7 +1531,7 @@ Tcl_ZlibStreamGet(
inflateEnd(&zshPtr->stream);
}
} else {
- TclListObjLength(NULL, zshPtr->outData, &listLen);
+ TclListObjLengthM(NULL, zshPtr->outData, &listLen);
if (count == -1) {
count = 0;
for (i=0; i<listLen; i++) {
@@ -1531,7 +1553,7 @@ Tcl_ZlibStreamGet(
dataPtr += existing;
while ((count > dataPos) &&
- (TclListObjLength(NULL, zshPtr->outData, &listLen) == TCL_OK)
+ (TclListObjLengthM(NULL, zshPtr->outData, &listLen) == TCL_OK)
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
@@ -1541,7 +1563,7 @@ Tcl_ZlibStreamGet(
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (itemLen-zshPtr->outPos >= count-dataPos) {
- unsigned len = count - dataPos;
+ size_t len = count - dataPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
zshPtr->outPos += len;
@@ -1550,7 +1572,7 @@ Tcl_ZlibStreamGet(
zshPtr->outPos = 0;
}
} else {
- unsigned len = itemLen - zshPtr->outPos;
+ size_t len = itemLen - zshPtr->outPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
dataPos += len;
@@ -1587,7 +1609,7 @@ Tcl_ZlibDeflate(
Tcl_Obj *gzipHeaderDictObj)
{
int wbits = 0, e = 0, extraSize = 0;
- int inLen = 0;
+ Tcl_Size inLen = 0;
Byte *inData = NULL;
z_stream stream;
GzipHeader header;
@@ -1599,6 +1621,16 @@ Tcl_ZlibDeflate(
}
/*
+ * Obtain the pointer to the byte array, we'll pass this pointer straight
+ * to the deflate command.
+ */
+
+ inData = Tcl_GetBytesFromObj(interp, data, &inLen);
+ if (inData == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
@@ -1642,12 +1674,6 @@ Tcl_ZlibDeflate(
TclNewObj(obj);
- /*
- * Obtain the pointer to the byte array, we'll pass this pointer straight
- * to the deflate command.
- */
-
- inData = Tcl_GetByteArrayFromObj(data, &inLen);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = (uInt) inLen;
stream.next_in = inData;
@@ -1734,11 +1760,11 @@ Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
- int bufferSize,
+ Tcl_Size bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
int wbits = 0, e = 0;
- int inLen = 0, newBufferSize;
+ Tcl_Size inLen = 0, newBufferSize;
Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
z_stream stream;
gz_header header, *headerPtr = NULL;
@@ -1749,6 +1775,11 @@ Tcl_ZlibInflate(
return TCL_ERROR;
}
+ inData = Tcl_GetBytesFromObj(interp, data, &inLen);
+ if (inData == NULL) {
+ return TCL_ERROR;
+ }
+
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
@@ -1786,7 +1817,6 @@ Tcl_ZlibInflate(
header.comm_max = MAX_COMMENT_LEN - 1;
}
- inData = Tcl_GetByteArrayFromObj(data, &inLen);
if (bufferSize < 1) {
/*
* Start with a buffer (up to) 3 times the size of the input data.
@@ -1886,7 +1916,7 @@ Tcl_ZlibInflate(
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
SetValue(gzipHeaderDictObj, "size",
- Tcl_NewLongObj(stream.total_out));
+ Tcl_NewWideIntObj(stream.total_out));
ckfree(nameBuf);
ckfree(commentBuf);
}
@@ -1919,7 +1949,7 @@ unsigned int
Tcl_ZlibCRC32(
unsigned int crc,
const unsigned char *buf,
- int len)
+ Tcl_Size len)
{
/* Nothing much to do, just wrap the crc32(). */
return crc32(crc, (Bytef *) buf, len);
@@ -1929,7 +1959,7 @@ unsigned int
Tcl_ZlibAdler32(
unsigned int adler,
const unsigned char *buf,
- int len)
+ Tcl_Size len)
{
return adler32(adler, (Bytef *) buf, len);
}
@@ -1946,7 +1976,7 @@ Tcl_ZlibAdler32(
static int
ZlibCmd(
- ClientData notUsed,
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1982,6 +2012,10 @@ ZlibCmd(
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
+ data = Tcl_GetBytesFromObj(interp, objv[2], &dlen);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
@@ -1989,7 +2023,6 @@ ZlibCmd(
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
- data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibAdler32(start, data, dlen)));
return TCL_OK;
@@ -1999,6 +2032,10 @@ ZlibCmd(
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
+ data = Tcl_GetBytesFromObj(interp, objv[2], &dlen);
+ if (data == NULL) {
+ return TCL_ERROR;
+ }
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
@@ -2006,7 +2043,6 @@ ZlibCmd(
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
- data = Tcl_GetByteArrayFromObj(objv[2], &dlen);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibCRC32(start, data, dlen)));
return TCL_OK;
@@ -2190,7 +2226,7 @@ ZlibCmd(
badLevel:
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (void *)NULL);
if (extraInfoStr) {
Tcl_AddErrorInfo(interp, extraInfoStr);
}
@@ -2199,7 +2235,7 @@ ZlibCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be %d to %d",
MIN_NONSTREAM_BUFFER_SIZE, MAX_BUFFER_SIZE));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL);
return TCL_ERROR;
}
@@ -2334,11 +2370,17 @@ ZlibStreamSubcmd(
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (void *)NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
+ if (compDictObj) {
+ if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL)) {
+ return TCL_ERROR;
+ }
+ }
+
/*
* Construct the stream now we know its configuration.
*/
@@ -2390,10 +2432,10 @@ ZlibPushSubcmd(
"-dictionary", "-header", "-level", "-limit", NULL
};
const char *const *pushOptions = pushDecompressOptions;
- enum pushOptions {poDictionary, poHeader, poLevel, poLimit};
+ enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit};
Tcl_Obj *headerObj = NULL, *compDictObj = NULL;
int limit = DEFAULT_BUFFER_SIZE;
- int dummy;
+ Tcl_Size dummy;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "mode channel ?options...?");
@@ -2447,13 +2489,13 @@ ZlibPushSubcmd(
if (mode == TCL_ZLIB_STREAM_DEFLATE && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"compression may only be applied to writable channels", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", (void *)NULL);
return TCL_ERROR;
}
if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "decompression may only be applied to readable channels",-1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
+ "decompression may only be applied to readable channels", TCL_INDEX_NONE));
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", (void *)NULL);
return TCL_ERROR;
}
@@ -2470,10 +2512,10 @@ ZlibPushSubcmd(
if (++i > objc-1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value missing for %s option", pushOptions[option]));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL);
return TCL_ERROR;
}
- switch ((enum pushOptions) option) {
+ switch ((enum pushOptionsEnum) option) {
case poHeader:
headerObj = objv[i];
if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) {
@@ -2488,7 +2530,7 @@ ZlibPushSubcmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"level must be 0 to 9", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL",
- NULL);
+ (void *)NULL);
goto genericOptionError;
}
break;
@@ -2500,7 +2542,7 @@ ZlibPushSubcmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"read ahead limit must be 1 to %d",
MAX_BUFFER_SIZE));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL);
goto genericOptionError;
}
break;
@@ -2509,7 +2551,7 @@ ZlibPushSubcmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"a compression dictionary may not be set in the "
"gzip format", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", (void *)NULL);
goto genericOptionError;
}
compDictObj = objv[i];
@@ -2517,6 +2559,10 @@ ZlibPushSubcmd(
}
}
+ if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL))) {
+ return TCL_ERROR;
+ }
+
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
@@ -2543,7 +2589,7 @@ ZlibPushSubcmd(
static int
ZlibStreamCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2646,7 +2692,7 @@ ZlibStreamCmd(
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream)));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream)));
return TCL_OK;
case zs_checksum: /* $strm checksum */
if (objc != 2) {
@@ -2669,7 +2715,7 @@ ZlibStreamCmd(
static int
ZlibStreamAddCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2717,7 +2763,7 @@ ZlibStreamAddCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-buffer\" option must be followed by integer "
"decompression buffersize", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[++i], &buffersize) != TCL_OK) {
@@ -2727,7 +2773,7 @@ ZlibStreamAddCmd(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"buffer size must be 1 to %d",
MAX_BUFFER_SIZE));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", (void *)NULL);
return TCL_ERROR;
}
break;
@@ -2736,7 +2782,7 @@ ZlibStreamAddCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
@@ -2747,7 +2793,7 @@ ZlibStreamAddCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (void *)NULL);
return TCL_ERROR;
}
}
@@ -2760,9 +2806,12 @@ ZlibStreamAddCmd(
*/
if (compDictObj != NULL) {
- int len;
+ Tcl_Size len;
+
+ if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) {
+ return TCL_ERROR;
+ }
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
if (len == 0) {
compDictObj = NULL;
}
@@ -2793,7 +2842,7 @@ ZlibStreamAddCmd(
static int
ZlibStreamPutCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2841,7 +2890,7 @@ ZlibStreamPutCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-dictionary\" option must be followed by"
" compression dictionary bytes", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (void *)NULL);
return TCL_ERROR;
}
compDictObj = objv[++i];
@@ -2851,7 +2900,7 @@ ZlibStreamPutCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-flush\", \"-fullflush\" and \"-finalize\" options"
" are mutually exclusive", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", (void *)NULL);
return TCL_ERROR;
}
}
@@ -2864,9 +2913,11 @@ ZlibStreamPutCmd(
*/
if (compDictObj != NULL) {
- int len;
+ Tcl_Size len;
- (void) Tcl_GetByteArrayFromObj(compDictObj, &len);
+ if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) {
+ return TCL_ERROR;
+ }
if (len == 0) {
compDictObj = NULL;
}
@@ -2882,7 +2933,7 @@ ZlibStreamPutCmd(
static int
ZlibStreamHeaderCmd(
- ClientData cd,
+ void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2897,7 +2948,7 @@ ZlibStreamHeaderCmd(
|| zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only gunzip streams can produce header information", -1));
- Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOP", (void *)NULL);
return TCL_ERROR;
}
@@ -2921,13 +2972,18 @@ ZlibStreamHeaderCmd(
static int
ZlibTransformClose(
- ClientData instanceData,
- Tcl_Interp *interp)
+ void *instanceData,
+ Tcl_Interp *interp,
+ int flags)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
int e, result = TCL_OK;
int written;
+ if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
+ return EINVAL;
+ }
+
/*
* Delete the support timer.
*/
@@ -2961,7 +3017,7 @@ ZlibTransformClose(
result = TCL_ERROR;
break;
}
- if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) {
+ if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) {
/* TODO: is this the right way to do errors on close?
* Note: when close is called from FinalizeIOSubsystem then
* interp may be NULL */
@@ -3021,7 +3077,7 @@ ZlibTransformClose(
static int
ZlibTransformInput(
- ClientData instanceData,
+ void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
@@ -3039,7 +3095,7 @@ ZlibTransformInput(
gotBytes = 0;
readBytes = cd->inStream.avail_in; /* how many bytes in buffer now */
while (!(cd->flags & STREAM_DONE) && toRead > 0) {
- int n, decBytes;
+ unsigned int n; int decBytes;
/* if starting from scratch or continuation after full decompression */
if (!cd->inStream.avail_in) {
@@ -3156,7 +3212,7 @@ copyDecompressed:
static int
ZlibTransformOutput(
- ClientData instanceData,
+ void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
@@ -3189,7 +3245,7 @@ ZlibTransformOutput(
break;
}
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
+ if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) {
*errorCodePtr = Tcl_GetErrno();
return -1;
}
@@ -3245,7 +3301,7 @@ ZlibTransformFlush(
* Write the bytes we've received to the next layer.
*/
- if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
+ if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
Tcl_PosixError(interp)));
@@ -3277,7 +3333,7 @@ ZlibTransformFlush(
static int
ZlibTransformSetOption( /* not used */
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
@@ -3298,7 +3354,10 @@ ZlibTransformSetOption( /* not used */
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
- (void) Tcl_GetByteArrayFromObj(compDictObj, NULL);
+ if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL)) {
+ Tcl_DecrRefCount(compDictObj);
+ return TCL_ERROR;
+ }
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
@@ -3332,7 +3391,7 @@ ZlibTransformSetOption( /* not used */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown -flush type \"%s\": must be full or sync",
value));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", (void *)NULL);
return TCL_ERROR;
}
@@ -3351,7 +3410,7 @@ ZlibTransformSetOption( /* not used */
} else if (newLimit < 1 || newLimit > MAX_BUFFER_SIZE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-limit must be between 1 and 65536", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "READLIMIT", (void *)NULL);
return TCL_ERROR;
}
}
@@ -3390,7 +3449,7 @@ ZlibTransformSetOption( /* not used */
static int
ZlibTransformGetOption(
- ClientData instanceData,
+ void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
@@ -3445,10 +3504,10 @@ ZlibTransformGetOption(
}
} else {
if (cd->compDictObj) {
- int len;
- const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len);
+ Tcl_Size length;
+ const char *str = TclGetStringFromObj(cd->compDictObj, &length);
- Tcl_DStringAppend(dsPtr, str, len);
+ Tcl_DStringAppend(dsPtr, str, length);
}
return TCL_OK;
}
@@ -3511,7 +3570,7 @@ ZlibTransformGetOption(
static void
ZlibTransformWatch(
- ClientData instanceData,
+ void *instanceData,
int mask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3534,7 +3593,7 @@ ZlibTransformWatch(
static int
ZlibTransformEventHandler(
- ClientData instanceData,
+ void *instanceData,
int interestMask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3555,7 +3614,7 @@ ZlibTransformEventTimerKill(
static void
ZlibTransformTimerRun(
- ClientData clientData)
+ void *clientData)
{
ZlibChannelData *cd = (ZlibChannelData *)clientData;
@@ -3576,9 +3635,9 @@ ZlibTransformTimerRun(
static int
ZlibTransformGetHandle(
- ClientData instanceData,
+ void *instanceData,
int direction,
- ClientData *handlePtr)
+ void **handlePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3597,7 +3656,7 @@ ZlibTransformGetHandle(
static int
ZlibTransformBlockMode(
- ClientData instanceData,
+ void *instanceData,
int mode)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
@@ -3686,7 +3745,7 @@ ZlibStackChannelTransform(
if (compDictObj != NULL) {
cd->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(cd->compDictObj);
- Tcl_GetByteArrayFromObj(cd->compDictObj, NULL);
+ Tcl_GetByteArrayFromObj(cd->compDictObj, (Tcl_Size *)NULL);
}
if (format == TCL_ZLIB_FORMAT_RAW) {
@@ -3904,7 +3963,7 @@ TclZlibInit(
* commands.
*/
- Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0);
+ Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", TCL_INDEX_NONE, 0);
/*
* Create the public scripted interface to this file's functionality.
@@ -3922,13 +3981,22 @@ TclZlibInit(
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
- Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
+ Tcl_RegisterConfig(interp, "zlib", cfg, "utf-8");
+
+ /*
+ * Allow command type introspection to do something sensible with streams.
+ */
+
+ TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
/*
* Formally provide the package as a Tcl built-in.
*/
- return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
+ Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
+#endif
+ return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION);
}
/*
@@ -4003,7 +4071,7 @@ int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle,
Tcl_Obj *data,
- int count)
+ Tcl_Size count)
{
return TCL_OK;
}
@@ -4028,7 +4096,7 @@ Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
- int bufferSize,
+ Tcl_Size bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
if (interp) {
@@ -4040,18 +4108,18 @@ Tcl_ZlibInflate(
unsigned int
Tcl_ZlibCRC32(
- unsigned int crc,
- const char *buf,
- int len)
+ TCL_UNUSED(unsigned int),
+ TCL_UNUSED(const unsigned char *),
+ TCL_UNUSED(Tcl_Size))
{
return 0;
}
unsigned int
Tcl_ZlibAdler32(
- unsigned int adler,
- const char *buf,
- int len)
+ TCL_UNUSED(unsigned int),
+ TCL_UNUSED(const unsigned char *),
+ TCL_UNUSED(Tcl_Size))
{
return 0;
}
diff --git a/generic/tommath.h b/generic/tommath.h
deleted file mode 100644
index 028a84d..0000000
--- a/generic/tommath.h
+++ /dev/null
@@ -1 +0,0 @@
-#include "tclTomMathInt.h"
diff --git a/library/auto.tcl b/library/auto.tcl
index f998b45..9aa4da3 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -3,8 +3,8 @@
# utility procs formerly in init.tcl dealing with auto execution of commands
# and can be auto loaded themselves.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1998 Sun Microsystems, Inc.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 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.
@@ -74,6 +74,67 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
lappend dirs $env($enVarName)
}
+ catch {
+ set found 0
+ set root [zipfs root]
+ set mountpoint [file join $root lib $basename]
+ lappend dirs [file join $root app ${basename}_library]
+ lappend dirs [file join $root lib ${basename} ${basename}_library]
+ lappend dirs [file join $root lib ${basename}]
+ if {![zipfs exists [file join $root app ${basename}_library]] \
+ && ![zipfs exists $mountpoint]} {
+ set found 0
+ foreach pkgdat [info loaded] {
+ lassign $pkgdat dllfile dllpkg
+ if {$dllpkg ne $basename} continue
+ if {$dllfile eq {}} {
+ # Loaded statically
+ break
+ }
+ set found 1
+ zipfs mount $dllfile $mountpoint
+ break
+ }
+ if {!$found} {
+ set paths {}
+ if {![catch {::${basename}::pkgconfig get libdir,runtime} dir]} {
+ lappend paths $dir
+ } else {
+ catch {lappend paths [::tcl::pkgconfig get libdir,runtime]}
+ }
+ if {![catch {::${basename}::pkgconfig get bindir,runtime} dir]} {
+ lappend paths $dir
+ } else {
+ catch {lappend paths [::tcl::pkgconfig get bindir,runtime]}
+ }
+ if {[catch {::${basename}::pkgconfig get dllfile,runtime} dllfile]} {
+ set dllfile "lib${basename}${version}[info sharedlibextension]"
+ }
+ set dir [file dirname [file join [pwd] [info nameofexecutable]]]
+ lappend paths $dir
+ lappend paths [file join [file dirname $dir] lib]
+ foreach path $paths {
+ set archive [file join $path $dllfile]
+ if {![file exists $archive]} {
+ continue
+ }
+ zipfs mount $archive $mountpoint
+ if {[zipfs exists [file join $mountpoint ${basename}_library $initScript]]} {
+ lappend dirs [file join $mountpoint ${basename}_library]
+ set found 1
+ break
+ } elseif {[zipfs exists [file join $mountpoint $initScript]]} {
+ lappend dirs [file join $mountpoint $initScript]
+ set found 1
+ break
+ } else {
+ catch {zipfs unmount $mountpoint}
+ }
+ }
+ }
+ }
+ }
+
# 2. In the package script directory registered within the
# configuration of the package itself.
@@ -140,13 +201,13 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# source everything when in a safe interpreter because we have a
# source command, but no file exists command
- if {[interp issafe] || [file exists $file]} {
- if {![catch {uplevel #0 [list source $file]} msg opts]} {
- return
- }
+ if {[interp issafe] || [file exists $file]} {
+ if {![catch {uplevel #0 [list source $file]} msg opts]} {
+ return
+ }
append errors "$file: $msg\n"
append errors [dict get $opts -errorinfo]\n
- }
+ }
}
unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
@@ -214,6 +275,7 @@ proc auto_mkindex {dir args} {
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
+ fconfigure $fid -encoding utf-8 -translation lf
puts -nonewline $fid $index
close $fid
cd $oldDir
@@ -240,7 +302,7 @@ proc auto_mkindex_old {dir args} {
set f ""
set error [catch {
set f [open $file]
- fconfigure $f -eofchar "\032 {}"
+ fconfigure $f -encoding utf-8 -eofchar "\x1A {}"
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
@@ -259,6 +321,7 @@ proc auto_mkindex_old {dir args} {
set f ""
set error [catch {
set f [open tclIndex w]
+ fconfigure $f -encoding utf-8 -translation lf
puts -nonewline $f $index
close $f
cd $oldDir
@@ -351,7 +414,7 @@ proc auto_mkindex_parser::mkindex {file} {
set scriptFile $file
set fid [open $file]
- fconfigure $fid -eofchar "\032 {}"
+ fconfigure $fid -encoding utf-8 -eofchar "\x1A {}"
set contents [read $fid]
close $fid
@@ -389,13 +452,13 @@ proc auto_mkindex_parser::hook {cmd} {
lappend initCommands $cmd
}
-# auto_mkindex_parser::slavehook command
+# auto_mkindex_parser::childhook command
#
# Registers a Tcl command to evaluate when initializing the child interpreter
# used by the mkindex parser. The command is evaluated in the child
# interpreter.
-proc auto_mkindex_parser::slavehook {cmd} {
+proc auto_mkindex_parser::childhook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the child interpreter
diff --git a/library/clock.tcl b/library/clock.tcl
index b9bbc2c..d1a76e7 100644
--- a/library/clock.tcl
+++ b/library/clock.tcl
@@ -9,7 +9,7 @@
#
#----------------------------------------------------------------------
#
-# Copyright (c) 2004-2007 Kevin B. Kenny
+# Copyright © 2004-2007 Kevin B. Kenny
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
@@ -3316,7 +3316,7 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
"time zone \":$fileName\" not valid"
}
try {
- source -encoding utf-8 [file join $DataDir $fileName]
+ source [file join $DataDir $fileName]
} on error {} {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
diff --git a/library/cookiejar/cookiejar.tcl b/library/cookiejar/cookiejar.tcl
new file mode 100644
index 0000000..85f73b4
--- /dev/null
+++ b/library/cookiejar/cookiejar.tcl
@@ -0,0 +1,746 @@
+# cookiejar.tcl --
+#
+# Implementation of an HTTP cookie storage engine using SQLite. The
+# implementation is done as a TclOO class, and includes a punycode
+# encoder and decoder (though only the encoder is currently used).
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Dependencies
+package require Tcl 8.6
+package require http 2.8.4
+package require sqlite3
+package require tcl::idna 1.0
+
+#
+# Configuration for the cookiejar package, plus basic support procedures.
+#
+
+# This is the class that we are creating
+if {![llength [info commands ::http::cookiejar]]} {
+ ::oo::class create ::http::cookiejar
+}
+
+namespace eval [info object namespace ::http::cookiejar] {
+ proc setInt {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {incr dummy $val} msg]} {
+ return -code error $msg
+ }
+ set var $val
+ }
+ proc setInterval {trigger *var val} {
+ upvar 1 ${*var} var
+ if {![string is integer -strict $val] || $val < 1} {
+ return -code error "expected positive integer but got \"$val\""
+ }
+ set var $val
+ {*}$trigger
+ }
+ proc setBool {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {if {$val} {}} msg]} {
+ return -code error $msg
+ }
+ set var [expr {!!$val}]
+ }
+
+ proc setLog {*var val} {
+ upvar 1 ${*var} var
+ set var [::tcl::prefix match -message "log level" \
+ {debug info warn error} $val]
+ }
+
+ # Keep this in sync with pkgIndex.tcl and with the install directories in
+ # Makefiles
+ variable version 0.2.0
+
+ variable domainlist \
+ https://publicsuffix.org/list/public_suffix_list.dat
+ variable domainfile \
+ [file join [file dirname [info script]] public_suffix_list.dat.gz]
+ # The list is directed to from http://publicsuffix.org/list/
+ variable loglevel info
+ variable vacuumtrigger 200
+ variable retainlimit 100
+ variable offline false
+ variable purgeinterval 60000
+ variable refreshinterval 10000000
+ variable domaincache {}
+
+ # Some support procedures, none particularly useful in general
+ namespace eval support {
+ # Set up a logger if the http package isn't actually loaded yet.
+ if {![llength [info commands ::http::Log]]} {
+ proc ::http::Log args {
+ # Do nothing by default...
+ }
+ }
+
+ namespace export *
+ proc locn {secure domain path {key ""}} {
+ if {$key eq ""} {
+ format "%s://%s%s" [expr {$secure?"https":"http"}] \
+ [::tcl::idna encode $domain] $path
+ } else {
+ format "%s://%s%s?%s" \
+ [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \
+ $path $key
+ }
+ }
+ proc splitDomain domain {
+ set pieces [split $domain "."]
+ for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
+ lappend result [join [lrange $pieces $i end] "."]
+ }
+ return $result
+ }
+ proc splitPath path {
+ set pieces [split [string trimleft $path "/"] "/"]
+ set result /
+ for {set j 0} {$j < [llength $pieces]} {incr j} {
+ lappend result /[join [lrange $pieces 0 $j] "/"]
+ }
+ return $result
+ }
+ proc isoNow {} {
+ set ms [clock milliseconds]
+ set ts [expr {$ms / 1000}]
+ set ms [format %03d [expr {$ms % 1000}]]
+ clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
+ }
+ proc log {level msg args} {
+ namespace upvar [info object namespace ::http::cookiejar] \
+ loglevel loglevel
+ set who [uplevel 1 self class]
+ set mth [uplevel 1 self method]
+ set map {debug 0 info 1 warn 2 error 3}
+ if {[string map $map $level] >= [string map $map $loglevel]} {
+ set msg [format $msg {*}$args]
+ set LVL [string toupper $level]
+ ::http::Log "[isoNow] $LVL $who $mth - $msg"
+ }
+ }
+ }
+}
+
+# Now we have enough information to provide the package.
+package provide cookiejar \
+ [set [info object namespace ::http::cookiejar]::version]
+
+# The implementation of the cookiejar package
+::oo::define ::http::cookiejar {
+ self {
+ method configure {{optionName "\x00\x00"} {optionValue "\x00\x00"}} {
+ set tbl {
+ -domainfile {domainfile set}
+ -domainlist {domainlist set}
+ -domainrefresh {refreshinterval setInterval}
+ -loglevel {loglevel setLog}
+ -offline {offline setBool}
+ -purgeold {purgeinterval setInterval}
+ -retain {retainlimit setInt}
+ -vacuumtrigger {vacuumtrigger setInt}
+ }
+ dict lappend tbl -domainrefresh [namespace code {
+ my IntervalTrigger PostponeRefresh
+ }]
+ dict lappend tbl -purgeold [namespace code {
+ my IntervalTrigger PostponePurge
+ }]
+ if {$optionName eq "\x00\x00"} {
+ return [dict keys $tbl]
+ }
+ set opt [::tcl::prefix match -message "option" \
+ [dict keys $tbl] $optionName]
+ set setter [lassign [dict get $tbl $opt] varname]
+ namespace upvar [namespace current] $varname var
+ if {$optionValue ne "\x00\x00"} {
+ {*}$setter var $optionValue
+ }
+ return $var
+ }
+
+ method IntervalTrigger {method} {
+ # TODO: handle subclassing
+ foreach obj [info class instances [self]] {
+ [info object namespace $obj]::my $method
+ }
+ }
+ }
+
+ variable purgeTimer deletions refreshTimer
+ constructor {{path ""}} {
+ namespace import [info object namespace [self class]]::support::*
+
+ if {$path eq ""} {
+ sqlite3 [namespace current]::db :memory:
+ set storeorigin "constructed cookie store in memory"
+ } else {
+ sqlite3 [namespace current]::db $path
+ db timeout 500
+ set storeorigin "loaded cookie store from $path"
+ }
+
+ set deletions 0
+ db transaction {
+ db eval {
+ --;# Store the persistent cookies in this table.
+ --;# Deletion policy: once they expire, or if explicitly
+ --;# killed.
+ CREATE TABLE IF NOT EXISTS persistentCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ value TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ expiry INTEGER NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
+ ON persistentCookies (domain, path, key);
+ CREATE INDEX IF NOT EXISTS persistentLookup
+ ON persistentCookies (domain, path);
+
+ --;# Store the session cookies in this table.
+ --;# Deletion policy: at cookiejar instance deletion, if
+ --;# explicitly killed, or if the number of session cookies is
+ --;# too large and the cookie has not been used recently.
+ CREATE TEMP TABLE sessionCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ value TEXT NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX sessionUnique
+ ON sessionCookies (domain, path, key);
+ CREATE INDEX sessionLookup ON sessionCookies (domain, path);
+
+ --;# View to allow for simple looking up of a cookie.
+ --;# Deletion policy: NOT SUPPORTED via this view.
+ CREATE TEMP VIEW cookies AS
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 1 AS persistent
+ FROM persistentCookies
+ UNION
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 0 AS persistent
+ FROM sessionCookies;
+
+ --;# Encoded domain permission policy; if forbidden is 1, no
+ --;# cookie may be ever set for the domain, and if forbidden
+ --;# is 0, cookies *may* be created for the domain (overriding
+ --;# the forbiddenSuper table).
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS domains (
+ domain TEXT PRIMARY KEY NOT NULL,
+ forbidden INTEGER NOT NULL);
+
+ --;# Domains that may not have a cookie defined for direct
+ --;# child domains of them.
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS forbiddenSuper (
+ domain TEXT PRIMARY KEY);
+
+ --;# When we last retrieved the domain list.
+ CREATE TABLE IF NOT EXISTS domainCacheMetadata (
+ id INTEGER PRIMARY KEY,
+ retrievalDate INTEGER,
+ installDate INTEGER);
+ }
+
+ set cookieCount "no"
+ db eval {
+ SELECT COUNT(*) AS cookieCount FROM persistentCookies
+ }
+ log info "%s with %s entries" $storeorigin $cookieCount
+
+ my PostponePurge
+
+ if {$path ne ""} {
+ if {[db exists {SELECT 1 FROM domains}]} {
+ my RefreshDomains
+ } else {
+ my InitDomainList
+ my PostponeRefresh
+ }
+ } else {
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ my PostponeRefresh
+ }
+ }
+ }
+
+ method PostponePurge {} {
+ namespace upvar [info object namespace [self class]] \
+ purgeinterval interval
+ catch {after cancel $purgeTimer}
+ set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
+ }
+
+ method PostponeRefresh {} {
+ namespace upvar [info object namespace [self class]] \
+ refreshinterval interval
+ catch {after cancel $refreshTimer}
+ set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
+ }
+
+ method RefreshDomains {} {
+ # TODO: domain list refresh policy
+ my PostponeRefresh
+ }
+
+ method HttpGet {url {timeout 0} {maxRedirects 5}} {
+ for {set r 0} {$r < $maxRedirects} {incr r} {
+ set tok [::http::geturl $url -timeout $timeout]
+ try {
+ if {[::http::status $tok] eq "timeout"} {
+ return -code error "connection timed out"
+ } elseif {[::http::ncode $tok] == 200} {
+ return [::http::data $tok]
+ } elseif {[::http::ncode $tok] >= 400} {
+ return -code error [::http::error $tok]
+ } elseif {[dict exists [::http::meta $tok] Location]} {
+ set url [dict get [::http::meta $tok] Location]
+ continue
+ }
+ return -code error \
+ "unexpected state: [::http::code $tok]"
+ } finally {
+ ::http::cleanup $tok
+ }
+ }
+ return -code error "too many redirects"
+ }
+ method GetDomainListOnline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainlist url domaincache cache
+ lassign $cache when data
+ if {$when > [clock seconds] - 3600} {
+ log debug "using cached value created at %s" \
+ [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
+ dict set meta retrievalDate $when
+ return $data
+ }
+ log debug "loading domain list from %s" $url
+ try {
+ set when [clock seconds]
+ set data [my HttpGet $url]
+ set cache [list $when $data]
+ # TODO: Should we use the Last-Modified header instead?
+ dict set meta retrievalDate $when
+ return $data
+ } on error msg {
+ log error "failed to fetch list of forbidden cookie domains from %s: %s" \
+ $url $msg
+ return {}
+ }
+ }
+ method GetDomainListOffline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainfile filename
+ log debug "loading domain list from %s" $filename
+ try {
+ set f [open $filename]
+ try {
+ if {[string match *.gz $filename]} {
+ zlib push gunzip $f
+ }
+ fconfigure $f -encoding utf-8
+ dict set meta retrievalDate [file mtime $filename]
+ return [read $f]
+ } finally {
+ close $f
+ }
+ } on error {msg opt} {
+ log error "failed to read list of forbidden cookie domains from %s: %s" \
+ $filename $msg
+ return -options $opt $msg
+ }
+ }
+ method InitDomainList {} {
+ namespace upvar [info object namespace [self class]] \
+ offline offline
+ if {!$offline} {
+ try {
+ set data [my GetDomainListOnline metadata]
+ if {[string length $data]} {
+ my InstallDomainData $data $metadata
+ return
+ }
+ } on error {} {
+ log warn "attempting to fall back to built in version"
+ }
+ }
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ }
+
+ method InstallDomainData {data meta} {
+ set n [db total_changes]
+ db transaction {
+ foreach line [split $data "\n"] {
+ if {[string trim $line] eq ""} {
+ continue
+ } elseif {[string match //* $line]} {
+ continue
+ } elseif {[string match !* $line]} {
+ set line [string range $line 1 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 0);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 0);
+ }
+ }
+ } else {
+ if {[string match {\*.*} $line]} {
+ set line [string range $line 2 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($utf);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($idna);
+ }
+ }
+ } else {
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ }
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 1);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 1);
+ }
+ }
+ }
+ if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
+ log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
+ $idna $line $utf [::tcl::idna decode $idna]
+ }
+ }
+
+ dict with meta {
+ set installDate [clock seconds]
+ db eval {
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, $retrievalDate, $installDate);
+ }
+ }
+ }
+ set n [expr {[db total_changes] - $n}]
+ log info "constructed domain info with %d entries" $n
+ }
+
+ # This forces the rebuild of the domain data, loading it from
+ method forceLoadDomainData {} {
+ db transaction {
+ db eval {
+ DELETE FROM domains;
+ DELETE FROM forbiddenSuper;
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, -1, -1);
+ }
+ my InitDomainList
+ }
+ }
+
+ destructor {
+ catch {
+ after cancel $purgeTimer
+ }
+ catch {
+ after cancel $refreshTimer
+ }
+ catch {
+ db close
+ }
+ return
+ }
+
+ method GetCookiesForHostAndPath {listVar secure host path fullhost} {
+ upvar 1 $listVar result
+ log debug "check for cookies for %s" [locn $secure $host $path]
+ set exact [expr {$host eq $fullhost}]
+ db eval {
+ SELECT key, value FROM persistentCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE persistentCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ set now [clock seconds]
+ db eval {
+ SELECT id, key, value FROM sessionCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE sessionCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ }
+
+ method getCookies {proto host path} {
+ set result {}
+ set paths [splitPath $path]
+ if {[regexp {[^0-9.]} $host]} {
+ set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
+ } else {
+ # Ugh, it's a numeric domain! Restrict it to just itself...
+ set domains [list $host]
+ }
+ set secure [string equal -nocase $proto "https"]
+ # Open question: how to move these manipulations into the database
+ # engine (if that's where they *should* be).
+ #
+ # Suggestion from kbk:
+ #LENGTH(theColumn) <= LENGTH($queryStr) AND
+ #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
+ #
+ # However, we instead do most of the work in Tcl because that lets us
+ # do the splitting exactly right, and it's far easier to work with
+ # strings in Tcl than in SQL.
+ db transaction {
+ foreach domain $domains {
+ foreach p $paths {
+ my GetCookiesForHostAndPath result $secure $domain $p $host
+ }
+ }
+ return $result
+ }
+ }
+
+ method BadDomain options {
+ if {![dict exists $options domain]} {
+ log error "no domain present in options"
+ return 0
+ }
+ dict with options {}
+ if {$domain ne $origin} {
+ log debug "cookie domain varies from origin (%s, %s)" \
+ $domain $origin
+ if {[string match .* $domain]} {
+ set dotd $domain
+ } else {
+ set dotd .$domain
+ }
+ if {![string equal -length [string length $dotd] \
+ [string reverse $dotd] [string reverse $origin]]} {
+ log warn "bad cookie: domain not suffix of origin"
+ return 1
+ }
+ }
+ if {![regexp {[^0-9.]} $domain]} {
+ if {$domain eq $origin} {
+ # May set for itself
+ return 0
+ }
+ log warn "bad cookie: for a numeric address"
+ return 1
+ }
+ db eval {
+ SELECT forbidden FROM domains WHERE domain = $domain
+ } {
+ if {$forbidden} {
+ log warn "bad cookie: for a forbidden address"
+ }
+ return $forbidden
+ }
+ if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
+ SELECT 1 FROM forbiddenSuper WHERE domain = $super
+ }]} then {
+ log warn "bad cookie: for a forbidden address"
+ return 1
+ }
+ return 0
+ }
+
+ # A defined extension point to allow users to easily impose extra policies
+ # on whether to accept cookies from a particular domain and path.
+ method policyAllow {operation domain path} {
+ return true
+ }
+
+ method storeCookie {options} {
+ db transaction {
+ if {[my BadDomain $options]} {
+ return
+ }
+ set now [clock seconds]
+ set persistent [dict exists $options expires]
+ dict with options {}
+ if {!$persistent} {
+ if {![my policyAllow session $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO sessionCookies (
+ secure, domain, path, key, value, originonly, creation,
+ lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $now, $now);
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined session cookie for %s" \
+ [locn $secure $domain $path $key]
+ } elseif {$expires < $now} {
+ if {![my policyAllow delete $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ set del [db changes]
+ db eval {
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [incr del [db changes]]
+ log debug "deleted %d cookies for %s" \
+ $del [locn $secure $domain $path $key]
+ } else {
+ if {![my policyAllow set $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO persistentCookies (
+ secure, domain, path, key, value, originonly, expiry,
+ creation, lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $expires, $now, $now);
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined persistent cookie for %s, expires at %s" \
+ [locn $secure $domain $path $key] \
+ [clock format $expires]
+ }
+ }
+ }
+
+ method PurgeCookies {} {
+ namespace upvar [info object namespace [self class]] \
+ vacuumtrigger trigger retainlimit retain
+ my PostponePurge
+ set now [clock seconds]
+ log debug "purging cookies that expired before %s" [clock format $now]
+ db transaction {
+ db eval {
+ DELETE FROM persistentCookies WHERE expiry < $now
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM persistentCookies WHERE id IN (
+ SELECT id FROM persistentCookies ORDER BY lastuse ASC
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM sessionCookies WHERE id IN (
+ SELECT id FROM sessionCookies ORDER BY lastuse
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ }
+
+ # Once we've deleted a fair bit, vacuum the database. Must be done
+ # outside a transaction.
+ if {$deletions > $trigger} {
+ set deletions 0
+ log debug "vacuuming cookie database"
+ catch {
+ db eval {
+ VACUUM
+ }
+ }
+ }
+ }
+
+ forward Database db
+
+ method lookup {{host ""} {key ""}} {
+ set host [string tolower [::tcl::idna encode $host]]
+ db transaction {
+ if {$host eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT domain FROM cookies
+ ORDER BY domain
+ } {
+ lappend result [::tcl::idna decode [string tolower $domain]]
+ }
+ return $result
+ } elseif {$key eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT key FROM cookies
+ WHERE domain = $host
+ ORDER BY key
+ } {
+ lappend result $key
+ }
+ return $result
+ } else {
+ db eval {
+ SELECT value FROM cookies
+ WHERE domain = $host AND key = $key
+ LIMIT 1
+ } {
+ return $value
+ }
+ return -code error "no such key for that host"
+ }
+ }
+ }
+}
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/cookiejar/idna.tcl b/library/cookiejar/idna.tcl
new file mode 100644
index 0000000..dc25cd8
--- /dev/null
+++ b/library/cookiejar/idna.tcl
@@ -0,0 +1,292 @@
+# idna.tcl --
+#
+# Implementation of IDNA (Internationalized Domain Names for
+# Applications) encoding/decoding system, built on a punycode engine
+# developed directly from the code in RFC 3492, Appendix C (with
+# substantial modifications).
+#
+# This implementation includes code from that RFC, translated to Tcl; the
+# other parts are:
+# Copyright © 2014 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tcl::idna {
+ namespace ensemble create -command puny -map {
+ encode punyencode
+ decode punydecode
+ }
+ namespace ensemble create -command ::tcl::idna -map {
+ encode IDNAencode
+ decode IDNAdecode
+ puny puny
+ version {::apply {{} {package present tcl::idna} ::}}
+ }
+
+ proc IDNAencode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] {
+ if {[regexp {[^-A-Za-z0-9]} $part]} {
+ if {[regexp {[^-A-Za-z0-9\xA1-\uFFFF]} $part ch]} {
+ scan $ch %c c
+ if {$ch < "!" || $ch > "~"} {
+ set ch [format "\\u%04x" $c]
+ }
+ throw [list IDNA INVALID_NAME_CHARACTER $ch] \
+ "bad character \"$ch\" in DNS name"
+ }
+ set part xn--[punyencode $part]
+ # Length restriction from RFC 5890, Sec 2.3.1
+ if {[string length $part] > 63} {
+ throw [list IDNA OVERLONG_PART $part] \
+ "hostname part too long"
+ }
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+ proc IDNAdecode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\x2E\u3002\uFF0E\uFF61"] {
+ if {[string match -nocase "xn--*" $part]} {
+ set part [punydecode [string range $part 4 end]]
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+
+ variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
+ # Bootstring parameters for Punycode
+ variable base 36
+ variable tmin 1
+ variable tmax 26
+ variable skew 38
+ variable damp 700
+ variable initial_bias 72
+ variable initial_n 0x80
+
+ variable max_codepoint 0x10FFFF
+
+ proc adapt {delta first numchars} {
+ variable base
+ variable tmin
+ variable tmax
+ variable damp
+ variable skew
+
+ set delta [expr {$delta / ($first ? $damp : 2)}]
+ incr delta [expr {$delta / $numchars}]
+ set k 0
+ while {$delta > ($base - $tmin) * $tmax / 2} {
+ set delta [expr {$delta / ($base-$tmin)}]
+ incr k $base
+ }
+ return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
+ }
+
+ # Main punycode encoding function
+ proc punyencode {string {case ""}} {
+ variable digits
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ set in {}
+ foreach char [set string [split $string ""]] {
+ scan $char "%c" ch
+ lappend in $ch
+ }
+ set output {}
+
+ # Initialize the state:
+ set n $initial_n
+ set delta 0
+ set bias $initial_bias
+
+ # Handle the basic code points:
+ foreach ch $string {
+ if {$ch < "\x80"} {
+ if {$case eq ""} {
+ append output $ch
+ } elseif {[string is true $case]} {
+ append output [string toupper $ch]
+ } elseif {[string is false $case]} {
+ append output [string tolower $ch]
+ }
+ }
+ }
+
+ set b [string length $output]
+
+ # h is the number of code points that have been handled, b is the
+ # number of basic code points.
+
+ if {$b > 0} {
+ append output "-"
+ }
+
+ # Main encoding loop:
+
+ for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
+ # All non-basic code points < n have been handled already. Find
+ # the next larger one:
+
+ set m inf
+ foreach ch $in {
+ if {$ch >= $n && $ch < $m} {
+ set m $ch
+ }
+ }
+
+ # Increase delta enough to advance the decoder's <n,i> state to
+ # <m,0>, but guard against overflow:
+
+ if {$m-$n > (0xFFFFFFFF-$delta)/($h+1)} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+ incr delta [expr {($m-$n) * ($h+1)}]
+ set n $m
+
+ foreach ch $in {
+ if {$ch < $n && ([incr delta] & 0xFFFFFFFF) == 0} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+
+ if {$ch != $n} {
+ continue
+ }
+
+ # Represent delta as a generalized variable-length integer:
+
+ for {set q $delta; set k $base} true {incr k $base} {
+ set t [expr {min(max($k-$bias, $tmin), $tmax)}]
+ if {$q < $t} {
+ break
+ }
+ append output \
+ [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
+ set q [expr {($q-$t) / ($base-$t)}]
+ }
+
+ append output [lindex $digits $q]
+ set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
+ set delta 0
+ incr h
+ }
+ }
+
+ return $output
+ }
+
+ # Main punycode decode function
+ proc punydecode {string {case ""}} {
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+ variable max_codepoint
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ # Initialize the state:
+
+ set n $initial_n
+ set i 0
+ set first 1
+ set bias $initial_bias
+
+ # Split the string into the "real" ASCII characters and the ones to
+ # feed into the main decoder. Note that we don't need to check the
+ # result of [regexp] because that RE will technically match any string
+ # at all.
+
+ regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
+ if {[string is true -strict $case]} {
+ set pre [string toupper $pre]
+ } elseif {[string is false -strict $case]} {
+ set pre [string tolower $pre]
+ }
+ set output [split $pre ""]
+ set out [llength $output]
+
+ # Main decoding loop:
+
+ for {set in 0} {$in < [string length $post]} {incr in} {
+ # Decode a generalized variable-length integer into delta, which
+ # gets added to i. The overflow checking is easier if we increase
+ # i as we go, then subtract off its starting value at the end to
+ # obtain delta.
+
+ for {set oldi $i; set w 1; set k $base} 1 {incr in} {
+ if {[set ch [string index $post $in]] eq ""} {
+ throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
+ }
+ if {[string match -nocase {[a-z]} $ch]} {
+ scan [string toupper $ch] %c digit
+ incr digit -65
+ } elseif {[string match {[0-9]} $ch]} {
+ set digit [expr {$ch + 26}]
+ } else {
+ throw {PUNYCODE BAD_INPUT CHAR} \
+ "bad decode character \"$ch\""
+ }
+ incr i [expr {$digit * $w}]
+ set t [expr {min(max($tmin, $k-$bias), $tmax)}]
+ if {$digit < $t} {
+ set bias [adapt [expr {$i-$oldi}] $first [incr out]]
+ set first 0
+ break
+ }
+ if {[set w [expr {$w * ($base - $t)}]] > 0x7FFFFFFF} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in digit decode"
+ }
+ incr k $base
+ }
+
+ # i was supposed to wrap around from out+1 to 0, incrementing n
+ # each time, so we'll fix that now:
+
+ if {[incr n [expr {$i / $out}]] > 0x7FFFFFFF} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in character choice"
+ } elseif {$n > $max_codepoint} {
+ if {$n >= 0x00D800 && $n < 0x00E000} {
+ # Bare surrogate?!
+ throw {PUNYCODE NON_BMP} \
+ [format "unsupported character U+%06x" $n]
+ }
+ throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
+ }
+ set i [expr {$i % $out}]
+
+ # Insert n at position i of the output:
+
+ set output [linsert $output $i [format "%c" $n]]
+ incr i
+ }
+
+ return [join $output ""]
+ }
+}
+
+package provide tcl::idna 1.0.1
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/cookiejar/pkgIndex.tcl b/library/cookiejar/pkgIndex.tcl
new file mode 100644
index 0000000..b1853aa
--- /dev/null
+++ b/library/cookiejar/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
+package ifneeded cookiejar 0.2.0 [list source [file join $dir cookiejar.tcl]]
+package ifneeded tcl::idna 1.0.1 [list source [file join $dir idna.tcl]]
diff --git a/library/cookiejar/public_suffix_list.dat.gz b/library/cookiejar/public_suffix_list.dat.gz
new file mode 100644
index 0000000..65bf75a
--- /dev/null
+++ b/library/cookiejar/public_suffix_list.dat.gz
Binary files differ
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 18ac517..ace1681 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,12 +1,12 @@
if {[info sharedlibextension] != ".dll"} return
if {[package vsatisfies [package provide Tcl] 9.0-]} {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcl9dde14.dll] Dde]
} elseif {![package vsatisfies [package provide Tcl] 8.7]
&& [::tcl::pkgconfig get debug]} {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcldde14g.dll] Dde]
} else {
- package ifneeded dde 1.4.4 \
+ package ifneeded dde 1.4.5 \
[list load [file join $dir tcldde14.dll] Dde]
}
diff --git a/library/encoding/ascii.enc b/library/encoding/ascii.enc
index e0320b8..284a9f5 100644
--- a/library/encoding/ascii.enc
+++ b/library/encoding/ascii.enc
@@ -9,7 +9,7 @@ S
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
-0070007100720073007400750076007700780079007A007B007C007D007E0000
+0070007100720073007400750076007700780079007A007B007C007D007E007F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/big5.enc b/library/encoding/big5.enc
index 26179f4..d6ff760 100644
--- a/library/encoding/big5.enc
+++ b/library/encoding/big5.enc
@@ -10,8 +10,8 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/cp1250.enc b/library/encoding/cp1250.enc
index 070ad90..f40b485 100644
--- a/library/encoding/cp1250.enc
+++ b/library/encoding/cp1250.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0083201E2026202020210088203001602039015A0164017D0179
-009020182019201C201D202220132014009821220161203A015B0165017E017A
+20AC0000201A0000201E2026202020210000203001602039015A0164017D0179
+000020182019201C201D202220132014000021220161203A015B0165017E017A
00A002C702D8014100A4010400A600A700A800A9015E00AB00AC00AD00AE017B
00B000B102DB014200B400B500B600B700B80105015F00BB013D02DD013E017C
015400C100C2010200C40139010600C7010C00C9011800CB011A00CD00CE010E
diff --git a/library/encoding/cp1251.enc b/library/encoding/cp1251.enc
index 376b1b4..f9513c2 100644
--- a/library/encoding/cp1251.enc
+++ b/library/encoding/cp1251.enc
@@ -11,7 +11,7 @@ S
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
04020403201A0453201E20262020202120AC203004092039040A040C040B040F
-045220182019201C201D202220132014009821220459203A045A045C045B045F
+045220182019201C201D202220132014000021220459203A045A045C045B045F
00A0040E045E040800A4049000A600A7040100A9040400AB00AC00AD00AE0407
00B000B104060456049100B500B600B704512116045400BB0458040504550457
0410041104120413041404150416041704180419041A041B041C041D041E041F
diff --git a/library/encoding/cp1252.enc b/library/encoding/cp1252.enc
index dd525ea..b45a7f8 100644
--- a/library/encoding/cp1252.enc
+++ b/library/encoding/cp1252.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0192201E20262020202102C62030016020390152008D017D008F
-009020182019201C201D20222013201402DC21220161203A0153009D017E0178
+20AC0000201A0192201E20262020202102C620300160203901520000017D0000
+000020182019201C201D20222013201402DC21220161203A01530000017E0178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
diff --git a/library/encoding/cp1253.enc b/library/encoding/cp1253.enc
index a8754c3..dcc8084 100644
--- a/library/encoding/cp1253.enc
+++ b/library/encoding/cp1253.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0192201E20262020202100882030008A2039008C008D008E008F
-009020182019201C201D20222013201400982122009A203A009C009D009E009F
+20AC0000201A0192201E20262020202100002030000020390000000000000000
+000020182019201C201D202220132014000021220000203A0000000000000000
00A00385038600A300A400A500A600A700A800A9000000AB00AC00AD00AE2015
00B000B100B200B3038400B500B600B703880389038A00BB038C00BD038E038F
0390039103920393039403950396039703980399039A039B039C039D039E039F
diff --git a/library/encoding/cp1254.enc b/library/encoding/cp1254.enc
index b9e3b3c..4922f3c 100644
--- a/library/encoding/cp1254.enc
+++ b/library/encoding/cp1254.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0192201E20262020202102C62030016020390152008D008E008F
-009020182019201C201D20222013201402DC21220161203A0153009D009E0178
+20AC0000201A0192201E20262020202102C62030016020390152000000000000
+000020182019201C201D20222013201402DC21220161203A0153000000000178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
diff --git a/library/encoding/cp1255.enc b/library/encoding/cp1255.enc
index 6e78b95..74ef0c1 100644
--- a/library/encoding/cp1255.enc
+++ b/library/encoding/cp1255.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0192201E20262020202102C62030008A2039008C008D008E008F
-009020182019201C201D20222013201402DC2122009A203A009C009D009E009F
+20AC0000201A0192201E20262020202102C62030000020390000000000000000
+000020182019201C201D20222013201402DC21220000203A0000000000000000
00A000A100A200A320AA00A500A600A700A800A900D700AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900F700BB00BC00BD00BE00BF
05B005B105B205B305B405B505B605B705B805B9000005BB05BC05BD05BE05BF
diff --git a/library/encoding/cp1257.enc b/library/encoding/cp1257.enc
index 4aa135d..42c6905 100644
--- a/library/encoding/cp1257.enc
+++ b/library/encoding/cp1257.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0083201E20262020202100882030008A2039008C00A802C700B8
-009020182019201C201D20222013201400982122009A203A009C00AF02DB009F
+20AC0000201A0000201E2026202020210000203000002039000000A802C700B8
+000020182019201C201D202220132014000021220000203A000000AF02DB0000
00A0000000A200A300A4000000A600A700D800A9015600AB00AC00AD00AE00C6
00B000B100B200B300B400B500B600B700F800B9015700BB00BC00BD00BE00E6
0104012E0100010600C400C501180112010C00C90179011601220136012A013B
diff --git a/library/encoding/cp1258.enc b/library/encoding/cp1258.enc
index 95fdef8..bbe2b12 100644
--- a/library/encoding/cp1258.enc
+++ b/library/encoding/cp1258.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC0081201A0192201E20262020202102C62030008A20390152008D008E008F
-009020182019201C201D20222013201402DC2122009A203A0153009D009E0178
+20AC0000201A0192201E20262020202102C62030000020390152000000000000
+000020182019201C201D20222013201402DC21220000203A0153000000000178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C2010200C400C500C600C700C800C900CA00CB030000CD00CE00CF
diff --git a/library/encoding/cp864.enc b/library/encoding/cp864.enc
index 71f9e62..dad7c20 100644
--- a/library/encoding/cp864.enc
+++ b/library/encoding/cp864.enc
@@ -11,7 +11,7 @@ S
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
00B000B72219221A259225002502253C2524252C251C25342510250C25142518
-03B2221E03C600B100BD00BC224800AB00BBFEF7FEF8009B009CFEFBFEFC009F
+03B2221E03C600B100BD00BC224800AB00BBFEF7FEF800000000FEFBFEFC0000
00A000ADFE8200A300A4FE8400000000FE8EFE8FFE95FE99060CFE9DFEA1FEA5
0660066106620663066406650666066706680669FED1061BFEB1FEB5FEB9061F
00A2FE80FE81FE83FE85FECAFE8BFE8DFE91FE93FE97FE9BFE9FFEA3FEA7FEA9
diff --git a/library/encoding/cp869.enc b/library/encoding/cp869.enc
index 9fd2929..4670826 100644
--- a/library/encoding/cp869.enc
+++ b/library/encoding/cp869.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850386008700B700AC00A620182019038820150389
-038A03AA038C00930094038E03AB00A9038F00B200B303AC00A303AD03AE03AF
+0000000000000000000000000386000000B700AC00A620182019038820150389
+038A03AA038C00000000038E03AB00A9038F00B200B303AC00A303AD03AE03AF
03CA039003CC03CD039103920393039403950396039700BD0398039900AB00BB
25912592259325022524039A039B039C039D256325512557255D039E039F2510
25142534252C251C2500253C03A003A1255A25542569256625602550256C03A3
diff --git a/library/encoding/cp874.enc b/library/encoding/cp874.enc
index 0487b97..e2e8433 100644
--- a/library/encoding/cp874.enc
+++ b/library/encoding/cp874.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-20AC008100820083008420260086008700880089008A008B008C008D008E008F
-009020182019201C201D20222013201400980099009A009B009C009D009E009F
+20AC000000000000000020260000000000000000000000000000000000000000
+000020182019201C201D20222013201400000000000000000000000000000000
00A00E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F
0E100E110E120E130E140E150E160E170E180E190E1A0E1B0E1C0E1D0E1E0E1F
0E200E210E220E230E240E250E260E270E280E290E2A0E2B0E2C0E2D0E2E0E2F
diff --git a/library/encoding/cp932.enc b/library/encoding/cp932.enc
index 8da8cd6..0699000 100644
--- a/library/encoding/cp932.enc
+++ b/library/encoding/cp932.enc
@@ -10,7 +10,7 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080000000000000000000850086000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
diff --git a/library/encoding/cp949.enc b/library/encoding/cp949.enc
index 2f3ec39..459dbd9 100644
--- a/library/encoding/cp949.enc
+++ b/library/encoding/cp949.enc
@@ -10,7 +10,7 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/cp950.enc b/library/encoding/cp950.enc
index f33d785..f582bd9 100644
--- a/library/encoding/cp950.enc
+++ b/library/encoding/cp950.enc
@@ -10,8 +10,8 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/dingbats.enc b/library/encoding/dingbats.enc
index 9729487..bd466b2 100644
--- a/library/encoding/dingbats.enc
+++ b/library/encoding/dingbats.enc
@@ -10,8 +10,8 @@ S
2730273127322733273427352736273727382739273A273B273C273D273E273F
2740274127422743274427452746274727482749274A274B25CF274D25A0274F
27502751275225B225BC25C6275625D727582759275A275B275C275D275E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000276127622763276427652766276726632666266526602460246124622463
2464246524662467246824692776277727782779277A277B277C277D277E277F
2780278127822783278427852786278727882789278A278B278C278D278E278F
diff --git a/library/encoding/ebcdic.enc b/library/encoding/ebcdic.enc
index f451de5..f83ce7d 100644
--- a/library/encoding/ebcdic.enc
+++ b/library/encoding/ebcdic.enc
@@ -1,3 +1,4 @@
+# Encoding file: ebcdic, single-byte
S
006F 0 1
00
diff --git a/library/encoding/euc-cn.enc b/library/encoding/euc-cn.enc
index 4b2f8c7..ff0f984 100644
--- a/library/encoding/euc-cn.enc
+++ b/library/encoding/euc-cn.enc
@@ -10,8 +10,8 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/euc-jp.enc b/library/encoding/euc-jp.enc
index db56c88..d4337d9 100644
--- a/library/encoding/euc-jp.enc
+++ b/library/encoding/euc-jp.enc
@@ -10,8 +10,8 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850086008700880089008A008B008C008D0000008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/euc-kr.enc b/library/encoding/euc-kr.enc
index 5e9bb93..0433260 100644
--- a/library/encoding/euc-kr.enc
+++ b/library/encoding/euc-kr.enc
@@ -10,8 +10,8 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
diff --git a/library/encoding/gb1988.enc b/library/encoding/gb1988.enc
index 298732c..8254684 100644
--- a/library/encoding/gb1988.enc
+++ b/library/encoding/gb1988.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D203E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
diff --git a/library/encoding/jis0201.enc b/library/encoding/jis0201.enc
index 64f423f..70e099d 100644
--- a/library/encoding/jis0201.enc
+++ b/library/encoding/jis0201.enc
@@ -10,8 +10,8 @@ S
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D203E007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
diff --git a/library/encoding/macDingbats.enc b/library/encoding/macDingbats.enc
index 28449cd..9fa47b5 100644
--- a/library/encoding/macDingbats.enc
+++ b/library/encoding/macDingbats.enc
@@ -10,8 +10,8 @@ S
2730273127322733273427352736273727382739273A273B273C273D273E273F
2740274127422743274427452746274727482749274A274B25CF274D25A0274F
27502751275225B225BC25C6275625D727582759275A275B275C275D275E007F
-F8D7F8D8F8D9F8DAF8DBF8DCF8DDF8DEF8DFF8E0F8E1F8E2F8E3F8E4008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+F8D7F8D8F8D9F8DAF8DBF8DCF8DDF8DEF8DFF8E0F8E1F8E2F8E3F8E400000000
+0000000000000000000000000000000000000000000000000000000000000000
0000276127622763276427652766276726632666266526602460246124622463
2464246524662467246824692776277727782779277A277B277C277D277E277F
2780278127822783278427852786278727882789278A278B278C278D278E278F
diff --git a/library/encoding/macJapan.enc b/library/encoding/macJapan.enc
index dba24bd..9f3f03b 100644
--- a/library/encoding/macJapan.enc
+++ b/library/encoding/macJapan.enc
@@ -10,7 +10,7 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00A0FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
diff --git a/library/encoding/shiftjis.enc b/library/encoding/shiftjis.enc
index 140aec4..3ba972e 100644
--- a/library/encoding/shiftjis.enc
+++ b/library/encoding/shiftjis.enc
@@ -10,7 +10,7 @@ M
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080000000000000000000850086008700000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
diff --git a/library/encoding/symbol.enc b/library/encoding/symbol.enc
index ffda9e3..ebd2f49 100644
--- a/library/encoding/symbol.enc
+++ b/library/encoding/symbol.enc
@@ -10,8 +10,8 @@ S
03A0039803A103A303A403A503C203A9039E03A80396005B2234005D22A5005F
F8E503B103B203C703B403B503C603B303B703B903D503BA03BB03BC03BD03BF
03C003B803C103C303C403C503D603C903BE03C803B6007B007C007D223C007F
-0080008100820083008400850086008700880089008A008B008C008D008E008F
-0090009100920093009400950096009700980099009A009B009C009D009E009F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
000003D2203222642044221E0192266326662665266021942190219121922193
00B000B12033226500D7221D2202202200F72260226122482026F8E6F8E721B5
21352111211C21182297229522052229222A2283228722842282228622082209
diff --git a/library/encoding/tis-620.enc b/library/encoding/tis-620.enc
index 2e9142a..af77326 100644
--- a/library/encoding/tis-620.enc
+++ b/library/encoding/tis-620.enc
@@ -9,7 +9,7 @@ S
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
-0070007100720073007400750076007700780079007A007B007C007D007E0000
+0070007100720073007400750076007700780079007A007B007C007D007E007F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F
diff --git a/library/foreachline.tcl b/library/foreachline.tcl
new file mode 100644
index 0000000..aacbd5b
--- /dev/null
+++ b/library/foreachline.tcl
@@ -0,0 +1,25 @@
+# foreachLine:
+# Iterate over the contents of a file, a line at a time.
+# The body script is run for each, with variable varName set to the line
+# contents.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc foreachLine {varName filename body} {
+ upvar 1 $varName line
+ set f [open $filename "r"]
+ try {
+ while {[gets $f line] >= 0} {
+ uplevel 1 $body
+ }
+ } on return {msg opt} {
+ dict incr opt -level
+ return -options $opt $msg
+ } finally {
+ close $f
+ }
+}
diff --git a/library/history.tcl b/library/history.tcl
index 8505c10..5dd6b06 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -2,7 +2,7 @@
#
# Implementation of the history command.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/library/http/http.tcl b/library/http/http.tcl
index fb256a3..6c3c068 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.9.8
+package provide http 2.10b1
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -20,12 +20,16 @@ namespace eval http {
if {![info exists http]} {
array set http {
-accept */*
+ -cookiejar {}
-pipeline 1
-postfresh 0
-proxyhost {}
-proxyport {}
-proxyfilter http::ProxyRequired
+ -proxynot {}
+ -proxyauth {}
-repost 0
+ -threadlevel 0
-urlencoding utf-8
-zip 1
}
@@ -69,8 +73,11 @@ namespace eval http {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
if {[info exists socketMapping]} {
# Close open sockets on re-init. Do not permit retries.
foreach {url sock} [array get socketMapping] {
@@ -91,21 +98,28 @@ namespace eval http {
array unset socketWrState
array unset socketRdQueue
array unset socketWrQueue
+ array unset socketPhQueue
array unset socketClosing
array unset socketPlayCmd
+ array unset socketCoEvent
+ array unset socketProxyId
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 {}
+ array set socketProxyId {}
+ return
}
init
variable urlTypes
if {![info exists urlTypes]} {
- set urlTypes(http) [list 80 ::socket]
+ set urlTypes(http) [list 80 ::http::socket]
}
variable encodings [string tolower [encoding names]]
@@ -127,13 +141,130 @@ namespace eval http {
set defaultKeepalive 0
}
- namespace export geturl config reset wait formatQuery quoteString
+ # Regular expression used to parse cookies
+ variable CookieRE {(?x) # EXPANDED SYNTAX
+ \s* # Ignore leading spaces
+ ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name
+ = # LITERAL: Equal sign
+ ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
+ (?:
+ \s* ; \s* # LITERAL: semicolon
+ ([^\u0000]+) # Match the options
+ )?
+ }
+
+ variable TmpSockCounter 0
+ variable ThreadCounter 0
+
+ variable reasonDict [dict create {*}{
+ 100 Continue
+ 101 {Switching Protocols}
+ 102 Processing
+ 103 {Early Hints}
+ 200 OK
+ 201 Created
+ 202 Accepted
+ 203 {Non-Authoritative Information}
+ 204 {No Content}
+ 205 {Reset Content}
+ 206 {Partial Content}
+ 207 Multi-Status
+ 208 {Already Reported}
+ 226 {IM Used}
+ 300 {Multiple Choices}
+ 301 {Moved Permanently}
+ 302 Found
+ 303 {See Other}
+ 304 {Not Modified}
+ 305 {Use Proxy}
+ 306 (Unused)
+ 307 {Temporary Redirect}
+ 308 {Permanent Redirect}
+ 400 {Bad Request}
+ 401 Unauthorized
+ 402 {Payment Required}
+ 403 Forbidden
+ 404 {Not Found}
+ 405 {Method Not Allowed}
+ 406 {Not Acceptable}
+ 407 {Proxy Authentication Required}
+ 408 {Request Timeout}
+ 409 Conflict
+ 410 Gone
+ 411 {Length Required}
+ 412 {Precondition Failed}
+ 413 {Content Too Large}
+ 414 {URI Too Long}
+ 415 {Unsupported Media Type}
+ 416 {Range Not Satisfiable}
+ 417 {Expectation Failed}
+ 418 (Unused)
+ 421 {Misdirected Request}
+ 422 {Unprocessable Content}
+ 423 Locked
+ 424 {Failed Dependency}
+ 425 {Too Early}
+ 426 {Upgrade Required}
+ 428 {Precondition Required}
+ 429 {Too Many Requests}
+ 431 {Request Header Fields Too Large}
+ 451 {Unavailable For Legal Reasons}
+ 500 {Internal Server Error}
+ 501 {Not Implemented}
+ 502 {Bad Gateway}
+ 503 {Service Unavailable}
+ 504 {Gateway Timeout}
+ 505 {HTTP Version Not Supported}
+ 506 {Variant Also Negotiates}
+ 507 {Insufficient Storage}
+ 508 {Loop Detected}
+ 510 {Not Extended (OBSOLETED)}
+ 511 {Network Authentication Required}
+ }]
+
+ variable failedProxyValues {
+ binary
+ body
+ charset
+ coding
+ connection
+ connectionRespFlag
+ currentsize
+ host
+ http
+ httpResponse
+ meta
+ method
+ querylength
+ queryoffset
+ reasonPhrase
+ requestHeaders
+ requestLine
+ responseCode
+ state
+ status
+ tid
+ totalsize
+ transfer
+ type
+ }
+
+ namespace export geturl config reset wait formatQuery postError 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
- # of the internals: getTextLine, make-transformation-chunked.
+ namespace export requestLine requestHeaders requestHeaderValue
+ namespace export responseLine responseHeaders responseHeaderValue
+ namespace export responseCode responseBody responseInfo reasonPhrase
+ # - Legacy aliases, were never exported:
+ # data, code, mapReply, meta, ncode
+ # - Callable from outside (e.g. from TLS) by fully-qualified name, but
+ # not exported:
+ # socket
+ # - Useful, but never exported (and likely to have naming collisions):
+ # size, status, cleanup, error, init
+ # Comments suggest that "init" can be used for re-initialisation,
+ # although the command is undocumented.
+ # - Never exported, renamed from lower-case names:
+ # GetTextLine, MakeTransformationChunked.
}
# http::Log --
@@ -210,14 +341,48 @@ proc http::config {args} {
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
+ }
+}
+
+# ------------------------------------------------------------------------------
+# Proc http::reasonPhrase
+# ------------------------------------------------------------------------------
+# Command to return the IANA-recommended "reason phrase" for a HTTP Status Code.
+# Information obtained from:
+# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
+#
+# Arguments:
+# code - A valid HTTP Status Code (integer from 100 to 599)
+#
+# Return Value: the reason phrase
+# ------------------------------------------------------------------------------
+
+proc http::reasonPhrase {code} {
+ variable reasonDict
+ if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
+ set msg {argument must be a three-digit integer from 100 to 599}
+ return -code error $msg
}
+ if {[dict exists $reasonDict $code]} {
+ set reason [dict get $reasonDict $code]
+ } else {
+ set reason Unassigned
+ }
+ return $reason
}
# http::Finish --
@@ -241,8 +406,11 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -252,16 +420,29 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
- if {[info commands ${token}EventCoroutine] ne {}} {
- rename ${token}EventCoroutine {}
+ 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)}]
+ [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")
@@ -269,8 +450,22 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
} {
set closeQueue 1
set connId $state(socketinfo)
- set sock $state(sock)
- CloseSocket $state(sock) $token
+ 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
@@ -287,8 +482,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
} {
set closeQueue 1
set connId $state(socketinfo)
- set sock $state(sock)
- CloseSocket $state(sock) $token
+ 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)))
@@ -302,7 +503,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
if {[info exists state(-command)] && (!$skipCB)
&& (![info exists state(done-command-cb)])} {
set state(done-command-cb) yes
- if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} {
+ if { [catch {namespace eval :: $state(-command) $token} err]
+ && ($errormsg eq "")
+ } {
set state(error) [list $err $errorInfo $errorCode]
set state(status) error
}
@@ -313,7 +516,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
&& ($socketMapping($connId) eq $sock)
} {
http::CloseQueuedQueries $connId $token
+ # This calls Unset. Other cases do not need the call.
}
+ return
}
# http::KeepSocket -
@@ -335,8 +540,11 @@ proc http::KeepSocket {token} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -371,9 +579,6 @@ proc http::KeepSocket {token} {
# queued, arrange to read it.
set token3 [lindex $socketRdQueue($connId) 0]
set socketRdQueue($connId) [lrange $socketRdQueue($connId) 1 end]
- variable $token3
- upvar 0 $token3 state3
- set tk2 [namespace tail $token3]
#Log pipelined, GRANT read access to $token3 in KeepSocket
set socketRdState($connId) $token3
@@ -412,8 +617,7 @@ proc http::KeepSocket {token} {
# 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.
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -457,8 +661,7 @@ proc http::KeepSocket {token} {
# Code:
# - The code is the same as the code below for the nonpipelined
# case with a queued request.
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -479,8 +682,7 @@ proc http::KeepSocket {token} {
# 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]
- variable $token3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in KeepSocket
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -499,6 +701,7 @@ proc http::KeepSocket {token} {
# There is no socketMapping($state(socketinfo)), so it does not matter
# that CloseQueuedQueries is not called.
}
+ return
}
# http::CheckEof -
@@ -524,6 +727,7 @@ proc http::CheckEof {sock} {
# will then be error-handled.
CloseSocket $sock
}
+ return
}
# http::CloseSocket -
@@ -539,8 +743,11 @@ proc http::CloseSocket {s {token {}}} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
set tk [namespace tail $token]
@@ -567,18 +774,22 @@ proc http::CloseSocket {s {token {}}} {
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
@@ -595,9 +806,13 @@ proc http::CloseQueuedQueries {connId {token {}}} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+ ##Log CloseQueuedQueries $connId $token
if {![info exists socketMapping($connId)]} {
# Command has already been called.
# Don't come here again - especially recursively.
@@ -621,6 +836,7 @@ proc http::CloseQueuedQueries {connId {token {}}} {
# - 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) {}
@@ -632,9 +848,11 @@ proc http::CloseQueuedQueries {connId {token {}}} {
if {$unfinished ne {}} {
Log ^R$tk Any unfinished transactions (excluding $token) failed \
- - token $token
+ - token $token - unfinished $unfinished
{*}$unfinished
+ # Calls ReplayIfClose.
}
+ return
}
# http::Unset
@@ -650,8 +868,11 @@ proc http::Unset {connId} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
unset socketMapping($connId)
unset socketRdState($connId)
@@ -660,6 +881,8 @@ proc http::Unset {connId} {
unset -nocomplain socketWrQueue($connId)
unset -nocomplain socketClosing($connId)
unset -nocomplain socketPlayCmd($connId)
+ unset -nocomplain socketProxyId($connId)
+ return
}
# http::reset --
@@ -684,7 +907,9 @@ proc http::reset {token {why reset}} {
set errorlist $state(error)
unset state
eval ::error $errorlist
+ # i.e. error msg errorInfo errorCode
}
+ return
}
# http::geturl --
@@ -700,15 +925,102 @@ proc http::reset {token {why reset}} {
# array that the caller should unset to garbage collect the state.
proc http::geturl {url args} {
+ variable urlTypes
+
+ # - If ::tls::socketCmd has its default value "::socket", change it to the
+ # new value ::http::socketForTls.
+ # - 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::socketForTls into its own "new"
+ # command, if it wishes to do so.
+ # - Commands that open a socket:
+ # - ::socket - basic
+ # - ::http::socket - can use a thread to avoid blockage by slow DNS
+ # lookup. See http::config option -threadlevel.
+ # - ::http::socketForTls - as ::http::socket, but can also open a socket
+ # for HTTPS/TLS through a proxy.
+
+ if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
+ set ::tls::socketCmd ::http::socketForTls
+ }
+
+ 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
}
@@ -732,6 +1044,7 @@ proc http::geturl {url args} {
-type application/x-www-form-urlencoded
-queryprogress {}
-protocol 1.1
+ -guesstype 0
binary 0
state created
meta {}
@@ -741,11 +1054,19 @@ proc http::geturl {url args} {
totalsize 0
querylength 0
queryoffset 0
- type text/html
+ type application/octet-stream
body {}
status ""
http ""
+ httpResponse {}
+ responseCode {}
+ reasonPhrase {}
connection keep-alive
+ tid {}
+ requestHeaders {}
+ requestLine {}
+ transfer {}
+ proxyUsed none
}
set state(-keepalive) $defaultKeepalive
set state(-strict) $strict
@@ -753,6 +1074,7 @@ proc http::geturl {url args} {
array set type {
-binary boolean
-blocksize integer
+ -guesstype boolean
-queryblocksize integer
-strict boolean
-timeout integer
@@ -761,7 +1083,7 @@ proc http::geturl {url args} {
}
set state(charset) $defaultCharset
set options {
- -binary -blocksize -channel -command -handler -headers -keepalive
+ -binary -blocksize -channel -command -guesstype -handler -headers -keepalive
-method -myaddr -progress -protocol -query -queryblocksize
-querychannel -queryprogress -strict -timeout -type -validate
}
@@ -780,8 +1102,8 @@ proc http::geturl {url args} {
}
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"
+ return -code error "Bad value for $flag ($value), number\
+ of list elements must be even"
}
set state($flag) $value
} else {
@@ -833,6 +1155,9 @@ proc http::geturl {url args} {
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
+ # RFC 9110 Sec 4.2.4 goes further than this, and deprecates the format
+ # "user:password@". It is retained here for backward compatibility,
+ # but its use is not recommended.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded. This is only
@@ -945,6 +1270,9 @@ proc http::geturl {url args} {
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
@@ -958,20 +1286,9 @@ proc http::geturl {url args} {
append url : $port
}
append url $srvurl
- # Don't append the fragment!
+ # Don't append the fragment! RFC 7230 Sec 5.1
set state(url) $url
- set sockopts [list -async]
-
- # If we are using the proxy, we must pass in the full URL that includes
- # the server name.
-
- if {[info exists phost] && ($phost ne "")} {
- set srvurl $url
- set targetAddr [list $phost $pport]
- } else {
- set targetAddr [list $host $port]
- }
# Proxy connections aren't shared among different hosts.
set state(socketinfo) $host:$port
@@ -987,6 +1304,7 @@ proc http::geturl {url args} {
[GetFieldValue $state(-headers) Upgrade]]
set state(upgradeRequest) [expr { "upgrade" in $connectionValues
&& [llength $upgradeValues] >= 1}]
+ set state(connectionValues) $connectionValues
if {$isQuery || $isQueryChannel} {
# It's a POST.
@@ -1025,6 +1343,35 @@ proc http::geturl {url args} {
set state(-keepalive) 0
}
+ # Handle proxy requests here for http:// but not for https://
+ # The proxying for https is done in the ::http::socketForTls command.
+ # A proxy request for http:// needs the full URL in the HTTP request line,
+ # including the server name.
+ # The *tls* test below attempts to describe protocols in addition to
+ # "https on port 443" that use HTTP over TLS.
+ if {($phost ne "") && (![string match -nocase *tls* $defcmd])} {
+ set srvurl $url
+ set targetAddr [list $phost $pport]
+ set state(proxyUsed) HttpProxy
+ # The value of state(proxyUsed) none|HttpProxy depends only on the
+ # all-transactions http::config settings and on the target URL.
+ # Even if this is a persistent socket there is no need to change the
+ # value of state(proxyUsed) for other transactions that use the socket:
+ # they have the same value already.
+ } 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 -type $token {*}$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
@@ -1034,15 +1381,19 @@ proc http::geturl {url args} {
# $state(socketinfo). This property simplifies the mapping of open
# channels.
set reusing 0
- set alreadyQueued 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
+ variable socketProxyId
if {[info exists socketMapping($state(socketinfo))]} {
# - If the connection is idle, it has a "fileevent readable" binding
@@ -1065,14 +1416,21 @@ proc http::geturl {url args} {
# causes a call to Finish.
set reusing 1
set sock $socketMapping($state(socketinfo))
- Log "reusing socket $sock for $state(socketinfo) - token $token"
+ set state(proxyUsed) $socketProxyId($state(socketinfo))
+ Log "reusing closing socket $sock for $state(socketinfo) - token $token"
- set alreadyQueued 1
+ 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
- } elseif {[catch {fconfigure $socketMapping($state(socketinfo))}]} {
+ ##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.
@@ -1086,43 +1444,115 @@ proc http::geturl {url args} {
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 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))
- Log "reusing socket $sock for $state(socketinfo) - token $token"
-
+ set state(proxyUsed) $socketProxyId($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
}
}
- if {$reusing} {
- # Define state(tmpState) and state(tmpOpenCmd) for use
- # by http::ReplayIfDead if the persistent connection has died.
- set state(tmpState) [array get state]
+ set state(reusing) $reusing
+ unset reusing
- # Pass -myaddr directly to the socket command
- if {[info exists state(-myaddr)]} {
- lappend sockopts -myaddr $state(-myaddr)
- }
+ 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
- set state(tmpOpenCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr]
+ 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
+}
- set state(reusing) $reusing
- # Excluding ReplayIfDead and the decision whether to call it, there are four
- # places outside http::geturl 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::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
+ variable socketProxyId
+
+ set sock $state(sock)
# See comments above re the start of this timeout in other cases.
if {(!$state(reusing)) && ($state(-timeout) > 0)} {
@@ -1130,26 +1560,183 @@ proc http::geturl {url args} {
[list http::reset $token timeout]]
}
- if {![info exists sock]} {
- # Pass -myaddr directly to the socket command
- if {[info exists state(-myaddr)]} {
- lappend sockopts -myaddr $state(-myaddr)
- }
- set pre [clock milliseconds]
- ##Log pre socket opened, - token $token
- ##Log [concat $defcmd $sockopts $targetAddr] - token $token
- if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
- # 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.
+ 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
+ variable socketProxyId
+
+ set DoLater {-traceread 0 -tracewrite 0}
+ set socketMapping($state(socketinfo)) $state(sock)
+ set socketProxyId($state(socketinfo)) $state(proxyUsed)
+ # - The value of state(proxyUsed) was set in http::CreateToken to either
+ # "none" or "HttpProxy".
+ # - $token is the first transaction to use this placeholder, so there are
+ # no other tokens whose (proxyUsed) must be modified.
+
+ 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
+ }
+
+ # Value of socketPhQueue() may have already been set by ReplayCore.
+ if {![info exists socketPhQueue($state(sock))]} {
+ set socketPhQueue($state(sock)) {}
+ }
+ set socketRdQueue($state(socketinfo)) {}
+ set socketWrQueue($state(socketinfo)) {}
+ set socketClosing($state(socketinfo)) 0
+ set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
+ set socketCoEvent($state(socketinfo)) {}
+ set socketProxyId($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
+ variable socketProxyId
+
+ 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)
+
+ if {[catch {
+ if {$state(reusing)} {
+ # If ($state(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
+ set sock [namespace eval :: $state(openCmd)]
+ set state(sock) $sock
+ # Normal return from $state(openCmd) always returns a valid socket.
+ # A TLS proxy connection with 407 or other failure from the
+ # proxy server raises an error.
- set state(sock) NONE
- Finish $token $sock 1
- cleanup $token
- dict unset errdict -level
- return -options $errdict $sock
- } else {
# Initialisation of a new socket.
##Log post socket opened, - token $token
##Log socket opened, now fconfigure - token $token
@@ -1159,86 +1746,270 @@ proc http::geturl {url args} {
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
##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 OpenSocket success $sock - token $token
+ } result errdict]} {
+ ##Log OpenSocket failed $result - token $token
+ # There may be other requests in the socketPhQueue.
+ # Prepare socketPlayCmd so that Finish will replay them.
+ if { ($state(-keepalive)) && (!$state(reusing))
+ && [info exists socketPhQueue($sockOld)]
+ && ($socketPhQueue($sockOld) ne {})
+ } {
+ if {$socketMapping($state(socketinfo)) ne $sockOld} {
+ Log "WARNING: this code should not be reached.\
+ {$socketMapping($state(socketinfo)) ne $sockOld}"
+ }
+ set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
+ set socketPhQueue($sockOld) {}
+ }
+ if {[string range $result 0 20] eq {proxy connect failed:}} {
+ # - The HTTPS proxy did not create a socket. The pre-existing value
+ # (a "placeholder socket") is unchanged.
+ # - The proxy returned a valid HTTP response to the failed CONNECT
+ # request, and http::SecureProxyConnect copied this to $token,
+ # and also set ${token}(connection) set to "close".
+ # - Remove the error message $result so that Finish delivers this
+ # HTTP response to the caller.
+ set result {}
}
+ Finish $token $result
+ # Because socket creation failed, the placeholder "socket" must be
+ # "closed" and (if persistent) removed from the persistent sockets
+ # table. In the {proxy connect failed:} case Finish does this because
+ # the value of ${token}(connection) is "close". In the other cases here,
+ # it does so because $result is non-empty.
}
- # Command [socket] is called with -async, but takes 5s to 5.1s to return,
- # with probability of order 1 in 10,000. This may be a bizarre scheduling
- # issue with my (KJN's) system (Fedora Linux).
- # This does not cause a problem (unless the request times out when this
- # command returns).
+ ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token
+ return
+}
- set state(sock) $sock
- Log "Using $sock for $state(socketinfo) - token $token" \
- [expr {$state(-keepalive)?"keepalive":""}]
- if { $state(-keepalive)
- && (![info exists socketMapping($state(socketinfo))])
- } {
- # Freshly-opened socket that we would like to become persistent.
- set socketMapping($state(socketinfo)) $sock
+# ------------------------------------------------------------------------------
+# 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]
- if {![info exists socketRdState($state(socketinfo))]} {
- set socketRdState($state(socketinfo)) {}
+ variable socketMapping
+ variable socketRdState
+ variable socketWrState
+ variable socketRdQueue
+ variable socketWrQueue
+ variable socketPhQueue
+ variable socketClosing
+ variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
+
+ set reusing $state(reusing)
+ set sock $state(sock)
+ set proxyUsed $state(proxyUsed)
+ ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed
+
+ 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
+ set socketProxyId($state(socketinfo)) $proxyUsed
+ # tokens that use the placeholder $sockOld are updated below.
+ ##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 {![info exists socketWrState($state(socketinfo))]} {
- set socketWrState($state(socketinfo)) {}
+ }
+ if {[dict get $DoLater -tracewrite]} {
set varName ::http::socketWrState($state(socketinfo))
trace add variable $varName unset ::http::CancelWritePipeline
- }
+ }
+ }
- 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
- }
+ # Do this in all cases.
+ ScheduleRequest $token
- set socketRdQueue($state(socketinfo)) {}
- set socketWrQueue($state(socketinfo)) {}
- set socketClosing($state(socketinfo)) 0
- set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
- }
+ # 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
+ set ${tok}(proxyUsed) $proxyUsed
- if {![info exists phost]} {
- set phost ""
- }
- if {$reusing} {
- # For use by http::ReplayIfDead if the persistent connection has died.
- # Also used by NextPipelinedWrite.
- set state(tmpConnArgs) [list $proto $phost $srvurl]
+ # 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
- # 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.
+ return
+}
- if {$alreadyQueued} {
+
+# ------------------------------------------------------------------------------
+# 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($sock) 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.
+# socketProxyId($connId) The type of proxy that this socket uses: values are
+# those of state(proxyUsed) i.e. none, HttpProxy,
+# SecureProxy, and SecureProxyFailed.
+# The value is not used for anything by http, its purpose
+# is to set the value of state() for caller information.
+# ------------------------------------------------------------------------------
+
+
+# ------------------------------------------------------------------------------
+# 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
+ variable socketProxyId
+
+ 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
@@ -1271,53 +2042,78 @@ proc http::geturl {url args} {
# 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 re-use pipelined, GRANT write access to $token in geturl
- set socketWrState($state(socketinfo)) $token
-
- } elseif {$reusing} {
- # Cf tests above - both are ready.
- #Log re-use nonpipeline, GRANT r/w access to $token in geturl
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
- }
-
- # All (!$reusing) cases come here, and also some $reusing cases if the
- # connection is ready.
+ 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.
- fileevent $sock writable \
- [list http::Connect $token $proto $phost $srvurl]
- }
- # Wait for the connection to complete.
- 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
+ lassign $state(connArgs) proto phost srvurl
- 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
+ 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
}
+
}
- ##Log Leaving http::geturl - token $token
- return $token
+
+ return
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SendHeader
+# ------------------------------------------------------------------------------
+# Command to send a request header, and keep a copy in state(requestHeaders)
+# for debugging purposes.
+#
+# Arguments:
+# token - connection token (name of an array)
+# key - header name
+# value - header value
+#
+# Return Value: none
+# ------------------------------------------------------------------------------
+
+proc http::SendHeader {token key value} {
+ variable $token
+ upvar 0 $token state
+ set tk [namespace tail $token]
+ set sock $state(sock)
+ lappend state(requestHeaders) [string tolower $key] $value
+ puts $sock "$key: $value"
+ return
}
# http::Connected --
@@ -1341,8 +2137,11 @@ proc http::Connected {token proto phost srvurl} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -1368,6 +2167,9 @@ proc http::Connected {token proto phost srvurl} {
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list $trRead crlf] \
-buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
@@ -1401,44 +2203,58 @@ proc http::Connected {token proto phost srvurl} {
Log ^B$tk begin sending request - token $token
if {[catch {
- set state(method) $how
- puts $sock "$how $srvurl HTTP/$state(-protocol)"
+ if {[info exists state(bypass)]} {
+ set state(method) [lindex [split $state(bypass) { }] 0]
+ set state(requestHeaders) {}
+ set state(requestLine) $state(bypass)
+ } else {
+ set state(method) $how
+ set state(requestHeaders) {}
+ set state(requestLine) "$how $srvurl HTTP/$state(-protocol)"
+ }
+ puts $sock $state(requestLine)
set hostValue [GetFieldValue $state(-headers) Host]
if {$hostValue ne {}} {
# Allow Host spoofing. [Bug 928154]
regexp {^[^:]+} $hostValue state(host)
- puts $sock "Host: $hostValue"
+ SendHeader $token 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"
+ SendHeader $token Host $host
} else {
set state(host) $host
- puts $sock "Host: $host:$port"
+ SendHeader $token Host "$host:$port"
}
- puts $sock "User-Agent: $http(-useragent)"
+ SendHeader $token User-Agent $http(-useragent)
if {($state(-protocol) > 1.0) && $state(-keepalive)} {
# Send this header, because a 1.1 server is not compelled to treat
# this as the default.
- puts $sock "Connection: keep-alive"
- }
- if {($state(-protocol) > 1.0) && !$state(-keepalive)} {
- puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
- }
- if {($state(-protocol) < 1.1)} {
+ set ConnVal keep-alive
+ } elseif {($state(-protocol) > 1.0)} {
+ # RFC2616 sec 8.1.2.1
+ set ConnVal close
+ } else {
+ # ($state(-protocol) <= 1.0)
# RFC7230 A.1
# Some server implementations of HTTP/1.0 have a faulty
# implementation of RFC 2068 Keep-Alive.
# Don't leave this to chance.
# For HTTP/1.0 we have already "set state(connection) close"
# and "state(-keepalive) 0".
- puts $sock "Connection: close"
+ set ConnVal close
}
+ # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
+ # Pat Thoyts).
+ if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
+ SendHeader $token Proxy-Authorization $http(-proxyauth)
+ }
# 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
+ set connection_seen 0
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string map {" " -} [string trim $key]]
@@ -1458,20 +2274,49 @@ proc http::Connected {token proto phost srvurl} {
set contDone 1
set state(querylength) $value
}
+ if { [string equal -nocase $key "connection"]
+ && [info exists state(bypass)]
+ } {
+ # Value supplied in -headers overrides $ConnVal.
+ set connection_seen 1
+ } elseif {[string equal -nocase $key "connection"]} {
+ # Remove "close" or "keep-alive" and use our own value.
+ # In an upgrade request, the upgrade is not guaranteed.
+ # Value "close" or "keep-alive" tells the server what to do
+ # if it refuses the upgrade. We send a single "Connection"
+ # header because some websocket servers, e.g. civetweb, reject
+ # multiple headers. Bug [d01de3281f] of tcllib/websocket.
+ set connection_seen 1
+ set listVal $state(connectionValues)
+ if {[set pos [lsearch $listVal close]] != -1} {
+ set listVal [lreplace $listVal $pos $pos]
+ }
+ if {[set pos [lsearch $listVal keep-alive]] != -1} {
+ set listVal [lreplace $listVal $pos $pos]
+ }
+ lappend listVal $ConnVal
+ set value [join $listVal {, }]
+ }
if {[string length $key]} {
- puts $sock "$key: $value"
+ SendHeader $token $key $value
}
}
# Allow overriding the Accept header on a per-connection basis. Useful
# for working with REST services. [Bug c11a51c482]
if {!$accept_types_seen} {
- puts $sock "Accept: $state(accept-types)"
+ SendHeader $token Accept $state(accept-types)
}
if { (!$accept_encoding_seen)
&& (![info exists state(-handler)])
&& $http(-zip)
} {
- puts $sock "Accept-Encoding: gzip,deflate,compress"
+ SendHeader $token Accept-Encoding gzip,deflate
+ } elseif {!$accept_encoding_seen} {
+ SendHeader $token Accept-Encoding identity
+ } else {
+ }
+ if {!$connection_seen} {
+ SendHeader $token Connection $ConnVal
}
if {$isQueryChannel && ($state(querylength) == 0)} {
# Try to determine size of data in channel. If we cannot seek, the
@@ -1484,6 +2329,22 @@ proc http::Connected {token proto phost srvurl} {
seek $state(-querychannel) $start
}
+ # Note that we don't do Cookie2; that's much nastier and not normally
+ # observed in practice either. It also doesn't fix the multitude of
+ # bugs in the basic cookie spec.
+ if {$http(-cookiejar) ne ""} {
+ set cookies ""
+ set separator ""
+ foreach {key value} [{*}$http(-cookiejar) \
+ getCookies $proto $host $state(path)] {
+ append cookies $separator $key = $value
+ set separator "; "
+ }
+ if {$cookies ne ""} {
+ SendHeader $token Cookie $cookies
+ }
+ }
+
# Flush the request header and set up the fileevent that will either
# push the POST data or read the response.
#
@@ -1504,10 +2365,10 @@ proc http::Connected {token proto phost srvurl} {
if {$isQuery || $isQueryChannel} {
# POST method.
if {!$content_type_seen} {
- puts $sock "Content-Type: $state(-type)"
+ SendHeader $token Content-Type $state(-type)
}
if {!$contDone} {
- puts $sock "Content-Length: $state(querylength)"
+ SendHeader $token Content-Length $state(querylength)
}
puts $sock ""
flush $sock
@@ -1561,7 +2422,8 @@ proc http::Connected {token proto phost srvurl} {
# If any other requests are in flight or pipelined/queued, they will
# be discarded.
} elseif {$state(status) eq ""} {
- # ...https handshake errors come here.
+ # https handshake errors come here, for
+ # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6.
set msg [registerError $sock]
registerError $sock {}
if {$msg eq {}} {
@@ -1572,6 +2434,7 @@ proc http::Connected {token proto phost srvurl} {
Finish $token $err
}
}
+ return
}
# http::registerError
@@ -1617,8 +2480,11 @@ proc http::DoneRequest {token} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -1677,6 +2543,7 @@ proc http::DoneRequest {token} {
# In the nonpipeline case, connection for reading always occurs.
ReceiveResponse $token
}
+ return
}
# http::ReceiveResponse
@@ -1693,13 +2560,16 @@ proc http::ReceiveResponse {token} {
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize)
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ fconfigure $sock -profile tcl8
+ }
Log ^D$tk begin receiving response - token $token
- coroutine ${token}EventCoroutine http::Event $sock $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
+ fileevent $sock readable ${token}--EventCoroutine
}
return
}
@@ -1723,14 +2593,14 @@ 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 {}} {
+ 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.
+ # http::MakeTransformationChunked.
#
# Catch in case the coroutine has closed the socket.
catch {fileevent $sock readable [list http::EventGateway $sock $token]}
@@ -1792,7 +2662,7 @@ proc http::NextPipelinedWrite {token} {
} {
# - 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}(tmpConnArgs)]
+ set conn [set ${token2}(connArgs)]
set socketWrState($connId) $token2
set socketWrQueue($connId) [lrange $socketWrQueue($connId) 1 end]
# Connect does its own fconfigure.
@@ -1817,9 +2687,7 @@ proc http::NextPipelinedWrite {token} {
# 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.
- variable $token3
- upvar 0 $token3 state3
- set conn [set ${token3}(tmpConnArgs)]
+ set conn [set ${token3}(connArgs)]
#Log nonpipeline, GRANT r/w access to $token3 in NextPipelinedWrite
set socketRdState($connId) $token3
set socketWrState($connId) $token3
@@ -1851,6 +2719,7 @@ proc http::NextPipelinedWrite {token} {
#Log re-use nonpipeline, GRANT delayed write access to $token in NextP..
set socketWrState($connId) peNding
}
+ return
}
# http::CancelReadPipeline
@@ -1883,6 +2752,7 @@ proc http::CancelReadPipeline {name1 connId op} {
}
set socketRdQueue($connId) {}
}
+ return
}
# http::CancelWritePipeline
@@ -1916,6 +2786,7 @@ proc http::CancelWritePipeline {name1 connId op} {
}
set socketWrQueue($connId) {}
}
+ return
}
# http::ReplayIfDead --
@@ -1938,19 +2809,22 @@ proc http::CancelWritePipeline {name1 connId op} {
# Side Effects:
# Use the same token, but try to open a new socket.
-proc http::ReplayIfDead {tokenArg doing} {
+proc http::ReplayIfDead {token doing} {
variable socketMapping
variable socketRdState
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
- variable $tokenArg
- upvar 0 $tokenArg stateArg
+ variable $token
+ upvar 0 $token state
- Log running http::ReplayIfDead for $tokenArg $doing
+ Log running http::ReplayIfDead for $token $doing
# 1. Merge the tokens for transactions in flight, the read (response) queue,
# and the write (request) queue.
@@ -1959,85 +2833,86 @@ proc http::ReplayIfDead {tokenArg doing} {
set InFlightW {}
# Obtain the tokens for transactions in flight.
- if {$stateArg(-pipeline)} {
+ 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($stateArg(socketinfo))]
- && ($socketRdState($stateArg(socketinfo)) ne "Rready")
+ if { [info exists socketRdState($state(socketinfo))]
+ && ($socketRdState($state(socketinfo)) ne "Rready")
} {
- lappend InFlightR $socketRdState($stateArg(socketinfo))
+ lappend InFlightR $socketRdState($state(socketinfo))
} elseif {($doing eq "read")} {
- lappend InFlightR $tokenArg
+ lappend InFlightR $token
}
- if { [info exists socketWrState($stateArg(socketinfo))]
- && $socketWrState($stateArg(socketinfo)) ni {Wready peNding}
+ if { [info exists socketWrState($state(socketinfo))]
+ && $socketWrState($state(socketinfo)) ni {Wready peNding}
} {
- lappend InFlightW $socketWrState($stateArg(socketinfo))
+ lappend InFlightW $socketWrState($state(socketinfo))
} elseif {($doing eq "write")} {
- lappend InFlightW $tokenArg
+ lappend InFlightW $token
}
- # Report any inconsistency of $tokenArg with socket*state.
+ # Report any inconsistency of $token with socket*state.
if { ($doing eq "read")
- && [info exists socketRdState($stateArg(socketinfo))]
- && ($tokenArg ne $socketRdState($stateArg(socketinfo)))
+ && [info exists socketRdState($state(socketinfo))]
+ && ($token ne $socketRdState($state(socketinfo)))
} {
- Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
- ne socketRdState($stateArg(socketinfo)) \
- $socketRdState($stateArg(socketinfo))
+ Log WARNING - ReplayIfDead pipelined token $token $doing \
+ ne socketRdState($state(socketinfo)) \
+ $socketRdState($state(socketinfo))
} elseif {
($doing eq "write")
- && [info exists socketWrState($stateArg(socketinfo))]
- && ($tokenArg ne $socketWrState($stateArg(socketinfo)))
+ && [info exists socketWrState($state(socketinfo))]
+ && ($token ne $socketWrState($state(socketinfo)))
} {
- Log WARNING - ReplayIfDead pipelined tokenArg $tokenArg $doing \
- ne socketWrState($stateArg(socketinfo)) \
- $socketWrState($stateArg(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 $tokenArg with socket*state.
- if {$tokenArg ne $socketRdState($stateArg(socketinfo))} {
- Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
- ne socketRdState($stateArg(socketinfo)) \
- $socketRdState($stateArg(socketinfo))
+ # 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($stateArg(socketinfo))]
- && ($socketRdQueue($stateArg(socketinfo)) ne {})
+ if { [info exists socketRdQueue($state(socketinfo))]
+ && ($socketRdQueue($state(socketinfo)) ne {})
} {
- Log WARNING - ReplayIfDead nonpipeline tokenArg $tokenArg $doing \
- has read queue socketRdQueue($stateArg(socketinfo)) \
- $socketRdQueue($stateArg(socketinfo)) ne {}
+ Log WARNING - ReplayIfDead nonpipeline token $token $doing \
+ has read queue socketRdQueue($state(socketinfo)) \
+ $socketRdQueue($state(socketinfo)) ne {}
}
- lappend InFlightW $socketRdState($stateArg(socketinfo))
- set socketRdQueue($stateArg(socketinfo)) {}
+ lappend InFlightW $socketRdState($state(socketinfo))
+ set socketRdQueue($state(socketinfo)) {}
}
set newQueue {}
lappend newQueue {*}$InFlightR
- lappend newQueue {*}$socketRdQueue($stateArg(socketinfo))
+ lappend newQueue {*}$socketRdQueue($state(socketinfo))
lappend newQueue {*}$InFlightW
- lappend newQueue {*}$socketWrQueue($stateArg(socketinfo))
+ lappend newQueue {*}$socketWrQueue($state(socketinfo))
- # 2. Tidy up tokenArg. This is a cut-down form of Finish/CloseSocket.
+ # 2. Tidy up token. This is a cut-down form of Finish/CloseSocket.
# Do not change state(status).
- # No need to after cancel stateArg(after) - either this is done in
+ # No need to after cancel state(after) - either this is done in
# ReplayCore/ReInit, or Finish is called.
- catch {close $stateArg(sock)}
+ 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.
@@ -2049,6 +2924,7 @@ proc http::ReplayIfDead {tokenArg doing} {
# to new values in ReplayCore.
ReplayCore $newQueue
+ return
}
# http::ReplayIfClose --
@@ -2079,7 +2955,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
if {$Wstate ni {Wready peNding}} {
lappend InFlightW $Wstate
}
-
+ ##Log $Rqueue -- $InFlightW -- $Wqueue
set newQueue {}
lappend newQueue {*}$Rqueue
lappend newQueue {*}$InFlightW
@@ -2088,6 +2964,7 @@ proc http::ReplayIfClose {Wstate Rqueue Wqueue} {
# 2. Cleanup - none needed, done by the caller.
ReplayCore $newQueue
+ return
}
# http::ReInit --
@@ -2131,6 +3008,11 @@ proc http::ReInit {token} {
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)
@@ -2170,13 +3052,18 @@ proc http::ReInit {token} {
# 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
+ variable socketProxyId
if {[llength $newQueue] == 0} {
# Nothing to do.
@@ -2196,6 +3083,7 @@ proc http::ReplayCore {newQueue} {
if {![ReInit $token]} {
Log FAILED in http::ReplayCore - NO tmp vars
+ Log ReplayCore reject $token
Finish $token {cannot send this request again}
return
}
@@ -2208,92 +3096,33 @@ proc http::ReplayCore {newQueue} {
unset state(tmpConnArgs)
set state(reusing) 0
+ set state(ReusingPlaceholder) 0
+ set state(alreadyQueued) 0
+ Log ReplayCore replay $token
- if {$state(-timeout) > 0} {
- set resetCmd [list http::reset $token timeout]
- set state(after) [after $state(-timeout) $resetCmd]
- }
-
- set pre [clock milliseconds]
- ##Log pre socket opened, - token $token
- ##Log $tmpOpenCmd - token $token
- # 4. Open a socket.
- if {[catch {eval $tmpOpenCmd} sock]} {
- # Something went wrong while trying to establish the connection.
- Log FAILED - $sock
- set state(sock) NONE
- Finish $token $sock
- return
- }
- ##Log post socket opened, - token $token
- set delay [expr {[clock milliseconds] - $pre}]
- if {$delay > 3000} {
- Log socket delay $delay - token $token
- }
- # Command [socket] is called with -async, but takes 5s to 5.1s to return,
- # with probability of order 1 in 10,000. This may be a bizarre scheduling
- # issue with my (KJN's) system (Fedora Linux).
- # This does not cause a problem (unless the request times out when this
- # command returns).
-
- # 5. Configure the persistent socket data.
- if {$state(-keepalive)} {
- set socketMapping($state(socketinfo)) $sock
-
- if {![info exists socketRdState($state(socketinfo))]} {
- set socketRdState($state(socketinfo)) {}
- set varName ::http::socketRdState($state(socketinfo))
- trace add variable $varName unset ::http::CancelReadPipeline
- }
-
- if {![info exists socketWrState($state(socketinfo))]} {
- set socketWrState($state(socketinfo)) {}
- set varName ::http::socketWrState($state(socketinfo))
- trace add variable $varName unset ::http::CancelWritePipeline
- }
-
- if {$state(-pipeline)} {
- #Log new, init for pipelined, GRANT write acc to $token ReplayCore
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
- } else {
- #Log new, init for nonpipeline, GRANT r/w acc to $token ReplayCore
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
- }
-
- set socketRdQueue($state(socketinfo)) {}
- set socketWrQueue($state(socketinfo)) $newQueue
- set socketClosing($state(socketinfo)) 0
- set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}}
- }
+ # Give the socket a placeholder name before it is created.
+ set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
+ set state(sock) $sock
- ##Log pre newQueue ReInit, - token $token
- # 6. Configure sockets in the queue.
+ # 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
+ Log ReplayCore replay $tok
} else {
+ Log ReplayCore reject $tok
set ${tok}(reusing) 1
set ${tok}(sock) NONE
- Finish $token {cannot send this request again}
+ Finish $tok {cannot send this request again}
}
}
- # 7. Configure the socket for newToken to send a request.
- set state(sock) $sock
- Log "Using $sock for $state(socketinfo) - token $token" \
- [expr {$state(-keepalive)?"keepalive":""}]
+ AsyncTransaction $token
- # Initialisation of a new socket.
- ##Log socket opened, now fconfigure - token $token
- fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
- ##Log socket opened, DONE fconfigure - token $token
-
- # Connect does its own fconfigure.
- fileevent $sock writable [list http::Connect $token {*}$tmpConnArgs]
- #Log ---- $sock << conn to $token for HTTP request (e)
+ return
}
# Data access functions:
@@ -2302,7 +3131,7 @@ proc http::ReplayCore {newQueue} {
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data
-proc http::data {token} {
+proc http::responseBody {token} {
variable $token
upvar 0 $token state
return $state(body)
@@ -2315,12 +3144,17 @@ proc http::status {token} {
upvar 0 $token state
return $state(status)
}
-proc http::code {token} {
+proc http::responseLine {token} {
variable $token
upvar 0 $token state
return $state(http)
}
-proc http::ncode {token} {
+proc http::requestLine {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(requestLine)
+}
+proc http::responseCode {token} {
variable $token
upvar 0 $token state
if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
@@ -2334,10 +3168,134 @@ proc http::size {token} {
upvar 0 $token state
return $state(currentsize)
}
-proc http::meta {token} {
+proc http::requestHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::requestHeaders token ?headerName?}
+ } else {
+ return [Meta $token request {*}$args]
+ }
+}
+proc http::responseHeaders {token args} {
+ set lenny [llength $args]
+ if {$lenny > 1} {
+ return -code error {usage: ::http::responseHeaders token ?headerName?}
+ } else {
+ return [Meta $token response {*}$args]
+ }
+}
+proc http::requestHeaderValue {token header} {
+ Meta $token request $header VALUE
+}
+proc http::responseHeaderValue {token header} {
+ Meta $token response $header VALUE
+}
+proc http::Meta {token who args} {
variable $token
upvar 0 $token state
- return $state(meta)
+
+ if {$who eq {request}} {
+ set whom requestHeaders
+ } elseif {$who eq {response}} {
+ set whom meta
+ } else {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ }
+
+ set header [string tolower [lindex $args 0]]
+ set how [string tolower [lindex $args 1]]
+ set lenny [llength $args]
+ if {$lenny == 0} {
+ return $state($whom)
+ } elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ } else {
+ set result {}
+ set combined {}
+ foreach {key value} $state($whom) {
+ if {$key eq $header} {
+ lappend result $key $value
+ append combined $value {, }
+ }
+ }
+ if {$lenny == 1} {
+ return $result
+ } else {
+ return [string range $combined 0 end-2]
+ }
+ }
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::responseInfo
+# ------------------------------------------------------------------------------
+# Command to return a dictionary of the most useful metadata of a HTTP
+# response.
+#
+# Arguments:
+# token - connection token (name of an array)
+#
+# Return Value: a dict. See man page http(n) for a description of each item.
+# ------------------------------------------------------------------------------
+
+proc http::responseInfo {token} {
+ variable $token
+ upvar 0 $token state
+ set result {}
+ foreach {key origin name} {
+ stage STATE state
+ status STATE status
+ responseCode STATE responseCode
+ reasonPhrase STATE reasonPhrase
+ contentType STATE type
+ binary STATE binary
+ redirection RESP location
+ upgrade STATE upgrade
+ error ERROR -
+ postError STATE posterror
+ method STATE method
+ charset STATE charset
+ compression STATE coding
+ httpRequest STATE -protocol
+ httpResponse STATE httpResponse
+ url STATE url
+ connectionRequest REQ connection
+ connectionResponse RESP connection
+ connectionActual STATE connection
+ transferEncoding STATE transfer
+ totalPost STATE querylength
+ currentPost STATE queryoffset
+ totalSize STATE totalsize
+ currentSize STATE currentsize
+ proxyUsed STATE proxyUsed
+ } {
+ if {$origin eq {STATE}} {
+ if {[info exists state($name)]} {
+ dict set result $key $state($name)
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ } elseif {$origin eq {REQ}} {
+ dict set result $key [requestHeaderValue $token $name]
+ } elseif {$origin eq {RESP}} {
+ dict set result $key [responseHeaderValue $token $name]
+ } elseif {$origin eq {ERROR}} {
+ # Don't flood the dict with data. The command ::http::error is
+ # available.
+ if {[info exists state(error)]} {
+ set msg [lindex $state(error) 0]
+ } else {
+ set msg {}
+ }
+ dict set result $key $msg
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ }
+ return $result
}
proc http::error {token} {
variable $token
@@ -2345,7 +3303,15 @@ proc http::error {token} {
if {[info exists state(error)]} {
return $state(error)
}
- return ""
+ return
+}
+proc http::postError {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(postErrorFull)]} {
+ return $state(postErrorFull)
+ }
+ return
}
# http::cleanup
@@ -2361,16 +3327,25 @@ proc http::error {token} {
proc http::cleanup {token} {
variable $token
upvar 0 $token state
- if {[info commands ${token}EventCoroutine] ne {}} {
- rename ${token}EventCoroutine {}
+ 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
@@ -2388,11 +3363,20 @@ proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set tk [namespace tail $token]
- set err "due to unexpected EOF"
- if {
- [eof $state(sock)] ||
- [set err [fconfigure $state(sock) -error]] ne ""
- } {
+
+ 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)} {
@@ -2408,12 +3392,8 @@ proc http::Connect {token proto phost srvurl} {
# If any other requests are in flight or pipelined/queued, they will
# be discarded.
}
- Finish $token "connect failed $err"
- } else {
- set state(state) connecting
- fileevent $state(sock) writable {}
- ::http::Connected $token $proto $phost $srvurl
- }
+ Finish $token "connect failed: $err"
+ return
}
# http::Write
@@ -2433,8 +3413,11 @@ proc http::Write {token} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -2495,11 +3478,13 @@ proc http::Write {token} {
set done 1
}
}
- } err]} {
+ } err opts]} {
# Do not call Finish here, but instead let the read half of the socket
# process whatever server reply there is to get.
-
set state(posterror) $err
+ set info [dict get $opts -errorinfo]
+ set code [dict get $opts -code]
+ set state(postErrorFull) [list $err $info $code]
set done 1
}
@@ -2515,15 +3500,16 @@ proc http::Write {token} {
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
- eval $state(-queryprogress) \
+ namespace 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
+# the coroutine commands ${token}--EventCoroutine that are
# bound to "fileevent $sock readable" and process input.
#
# Arguments
@@ -2540,8 +3526,11 @@ proc http::Event {sock token} {
variable socketWrState
variable socketRdQueue
variable socketWrQueue
+ variable socketPhQueue
variable socketClosing
variable socketPlayCmd
+ variable socketCoEvent
+ variable socketProxyId
variable $token
upvar 0 $token state
@@ -2552,15 +3541,18 @@ proc http::Event {sock token} {
if {![info exists state]} {
Log "Event $sock with invalid token '$token' - remote close?"
- if {![eof $sock]} {
+ if {!([catch {eof $sock} tmp] || $tmp)} {
if {[set d [read $sock]] ne ""} {
Log "WARNING: additional data left on closed socket\
- token $token"
+ } else {
}
+ } else {
}
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
return
+ } else {
}
if {$state(state) eq "connecting"} {
##Log - connecting - token $token
@@ -2571,6 +3563,7 @@ proc http::Event {sock token} {
} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
+ } else {
}
if {[catch {gets $sock state(http)} nsl]} {
@@ -2582,22 +3575,29 @@ proc http::Event {sock token} {
if {[TestForReplay $token read $nsl c]} {
return
+ } else {
}
-
# 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.
} else {
+ # https handshake errors come here, for
+ # Tcl 8.7 with http::SecureProxyConnect.
+ set msg [registerError $sock]
+ registerError $sock {}
+ if {$msg eq {}} {
+ set msg $nsl
+ }
Log ^X$tk end of response (error) - token $token
- Finish $token $nsl
+ Finish $token $msg
return
}
} elseif {$nsl >= 0} {
##Log - connecting 1 - token $token
set state(state) "header"
- } elseif { [eof $sock]
+ } elseif { ([catch {eof $sock} tmp] || $tmp)
&& [info exists state(reusing)]
&& $state(reusing)
} {
@@ -2607,6 +3607,7 @@ proc http::Event {sock token} {
if {[TestForReplay $token read {} d]} {
return
+ } else {
}
# else:
@@ -2614,6 +3615,7 @@ proc http::Event {sock token} {
# last use.
# If any other requests are in flight or pipelined/queued, they
# will be discarded.
+ } else {
}
} elseif {$state(state) eq "header"} {
if {[catch {gets $sock line} nhl]} {
@@ -2632,6 +3634,20 @@ proc http::Event {sock token} {
set state(state) "connecting"
continue
# This was a "return" in the pre-coroutine code.
+ } else {
+ }
+
+ # We have $state(http) so let's split it into its components.
+ if {[regexp {^HTTP/(\S+) ([0-9]{3}) (.*)$} $state(http) \
+ -> httpResponse responseCode reasonPhrase]
+ } {
+ set state(httpResponse) $httpResponse
+ set state(responseCode) $responseCode
+ set state(reasonPhrase) $reasonPhrase
+ } else {
+ set state(httpResponse) $state(http)
+ set state(responseCode) $state(http)
+ set state(reasonPhrase) $state(http)
}
if { ([info exists state(connection)])
@@ -2647,6 +3663,7 @@ proc http::Event {sock token} {
# Previous value is $token. It cannot be "pending".
set socketWrState($state(socketinfo)) Wready
http::NextPipelinedWrite $token
+ } else {
}
# Once a "close" has been signaled, the client MUST NOT send any
@@ -2665,6 +3682,21 @@ proc http::Event {sock token} {
# 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)) {}
+ } else {
+ }
+
if { ($socketRdQueue($state(socketinfo)) ne {})
|| ($socketWrQueue($state(socketinfo)) ne {})
|| ($socketWrState($state(socketinfo)) ni
@@ -2677,7 +3709,6 @@ proc http::Event {sock token} {
set msg "token ${InFlightW} is InFlightW"
##Log $msg - token $token
}
-
set socketPlayCmd($state(socketinfo)) \
[list ReplayIfClose $InFlightW \
$socketRdQueue($state(socketinfo)) \
@@ -2692,16 +3723,20 @@ proc http::Event {sock token} {
if {[info exists ${tokenVal}(after)]} {
after cancel [set ${tokenVal}(after)]
unset ${tokenVal}(after)
+ } else {
}
+ # 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.
+ # Do not allow further connections on this socket (but
+ # geturl can add new requests to the replay).
set socketClosing($state(socketinfo)) 1
+ } else {
}
set state(state) body
@@ -2717,6 +3752,7 @@ proc http::Event {sock token} {
&& ("keep-alive" ni $state(connection))
} {
lappend state(connection) "keep-alive"
+ } else {
}
# If doing a HEAD, then we won't get any body
@@ -2725,6 +3761,46 @@ proc http::Event {sock token} {
set state(state) complete
Eot $token
return
+ } elseif {
+ ($state(method) eq {CONNECT})
+ && [string is integer -strict $state(responseCode)]
+ && ($state(responseCode) >= 200)
+ && ($state(responseCode) < 300)
+ } {
+ # A successful CONNECT response has no body.
+ # (An unsuccessful CONNECT has headers and body.)
+ # The code below is abstracted from Eot/Finish, but
+ # keeps the socket open.
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ set state(state) complete
+ set state(status) ok
+ 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)
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+ if { [info exists state(-command)]
+ && (![info exists state(done-command-cb)])
+ } {
+ set state(done-command-cb) yes
+ if {[catch {namespace eval :: $state(-command) $token} err]} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ return
+ } else {
}
# - For non-chunked transfer we may have no body - in this case
@@ -2745,7 +3821,7 @@ proc http::Event {sock token} {
&& ("close" in $state(connection))
)
)
- && (![info exists state(transfer)])
+ && ($state(transfer) eq {})
&& ($state(totalsize) == 0)
} {
set msg {body size is 0 and no events likely - complete}
@@ -2755,6 +3831,7 @@ proc http::Event {sock token} {
set state(state) complete
Eot $token
return
+ } else {
}
# We have to use binary translation to count bytes properly.
@@ -2766,24 +3843,29 @@ proc http::Event {sock token} {
} {
# Turn off conversions for non-text data.
set state(binary) 1
+ } else {
}
if {[info exists state(-channel)]} {
if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
+ } else {
}
if {![info exists state(-handler)]} {
# Initiate a sequence of background fcopies.
fileevent $sock readable {}
- rename ${token}EventCoroutine {}
+ rename ${token}--EventCoroutine {}
CopyStart $sock $token
return
+ } else {
}
+ } else {
}
} elseif {$nhl > 0} {
# Process header lines.
##Log header - token $token - $line
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
- switch -- [string tolower $key] {
+ set key [string tolower $key]
+ switch -- $key {
content-type {
set state(type) [string trim [string tolower $value]]
# Grab the optional charset information.
@@ -2810,6 +3892,12 @@ proc http::Event {sock token} {
connection {
# RFC 7230 Section 6.1 states that a comma-separated
# list is an acceptable value.
+ if {![info exists state(connectionRespFlag)]} {
+ # This is the first "Connection" response header.
+ # Scrub the earlier value set by iniitialisation.
+ set state(connectionRespFlag) {}
+ set state(connection) {}
+ }
foreach el [SplitCommaSeparatedFieldValue $value] {
lappend state(connection) [string tolower $el]
}
@@ -2817,16 +3905,24 @@ proc http::Event {sock token} {
upgrade {
set state(upgrade) [string trim $value]
}
+ set-cookie {
+ if {$http(-cookiejar) ne ""} {
+ ParseCookie $token [string trim $value]
+ } else {
+ }
+ }
}
lappend state(meta) $key [string trim $value]
+ } else {
}
+ } else {
}
} else {
# Now reading body
##Log body - token $token
if {[catch {
if {[info exists state(-handler)]} {
- set n [eval $state(-handler) [list $sock $token]]
+ set n [namespace eval :: $state(-handler) [list $sock $token]]
##Log handler $n - token $token
# N.B. the protocol has been set to 1.0 because the -handler
# logic is not expected to handle chunked encoding.
@@ -2835,6 +3931,7 @@ proc http::Event {sock token} {
# We know the transfer is complete only when the server
# closes the connection - i.e. eof is not an error.
set state(state) complete
+ } else {
}
if {![string is integer -strict $n]} {
if 1 {
@@ -2864,10 +3961,11 @@ proc http::Event {sock token} {
set n 0
set state(state) complete
}
+ } else {
}
} elseif {[info exists state(transfer_final)]} {
# This code forgives EOF in place of the final CRLF.
- set line [getTextLine $sock]
+ set line [GetTextLine $sock]
set n [string length $line]
set state(state) complete
if {$n > 0} {
@@ -2890,7 +3988,7 @@ proc http::Event {sock token} {
} {
##Log chunked - token $token
set size 0
- set hexLenChunk [getTextLine $sock]
+ set hexLenChunk [GetTextLine $sock]
#set ntl [string length $hexLenChunk]
if {[string trim $hexLenChunk] ne ""} {
scan $hexLenChunk %x size
@@ -2903,6 +4001,7 @@ proc http::Event {sock token} {
incr state(log_size) [string length $chunk]
##Log chunk $n cumul $state(log_size) -\
token $token
+ } else {
}
if {$size != [string length $chunk]} {
Log "WARNING: mis-sized chunk:\
@@ -2915,10 +4014,11 @@ proc http::Event {sock token} {
set msg {error in chunked encoding - fetch\
terminated}
Eot $token $msg
+ } else {
}
# CRLF that follows chunk.
# If eof, this is handled at the end of this proc.
- getTextLine $sock
+ GetTextLine $sock
} else {
set n 0
set state(transfer_final) {}
@@ -2962,6 +4062,7 @@ proc http::Event {sock token} {
append state(body) $block
##Log non-chunk [string length $state(body)] -\
token $token
+ } else {
}
}
# This calculation uses n from the -handler, chunked, or
@@ -2973,6 +4074,7 @@ proc http::Event {sock token} {
set t $state(totalsize)
##Log another $n currentsize $c totalsize $t -\
token $token
+ } else {
}
# If Content-Length - check for end of data.
if {
@@ -2983,7 +4085,9 @@ proc http::Event {sock token} {
token $token
set state(state) complete
Eot $token
+ } else {
}
+ } else {
}
} err]} {
Log ^X$tk end of response (error ${err}) - token $token
@@ -2991,15 +4095,17 @@ proc http::Event {sock token} {
return
} else {
if {[info exists state(-progress)]} {
- eval $state(-progress) \
+ namespace eval :: $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
+ } else {
}
}
}
# catch as an Eot above may have closed the socket already
# $state(state) may be connecting, header, body, or complete
- if {![set cc [catch {eof $sock} eof]] && $eof} {
+ 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
@@ -3021,10 +4127,12 @@ proc http::Event {sock token} {
Log ^X$tk end of response (token error) - token $token
CloseSocket $sock
}
- } elseif {$cc} {
- return
+ } else {
+ # EITHER [eof sock] failed - presumed done by Eot
+ # OR [eof sock] succeeded and the result was 0
}
}
+ return
}
# http::TestForReplay
@@ -3114,10 +4222,88 @@ proc http::IsBinaryContentType {type} {
return true
}
-# http::getTextLine --
+proc http::ParseCookie {token value} {
+ variable http
+ variable CookieRE
+ variable $token
+ upvar 0 $token state
+
+ if {![regexp $CookieRE $value -> cookiename cookieval opts]} {
+ # Bad cookie! No biscuit!
+ return
+ }
+
+ # Convert the options into a list before feeding into the cookie store;
+ # ugly, but quite easy.
+ set realopts {hostonly 1 path / secure 0 httponly 0}
+ dict set realopts origin $state(host)
+ dict set realopts domain $state(host)
+ foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] {
+ regexp {^(.*?)(?:=(.*))?$} $option -> optname optval
+ switch -exact -- [string tolower $optname] {
+ expires {
+ if {[catch {
+ #Sun, 06 Nov 1994 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d %b %Y %T %Z"]
+ }] && [catch {
+ # Google does this one
+ #Mon, 01-Jan-1990 00:00:00 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d-%b-%Y %T %Z"]
+ }] && [catch {
+ # This is in the RFC, but it is also in the original
+ # Netscape cookie spec, now online at:
+ # <URL:http://curl.haxx.se/rfc/cookie_spec.html>
+ #Sunday, 06-Nov-94 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%A, %d-%b-%y %T %Z"]
+ }]} {catch {
+ #Sun Nov 6 08:49:37 1994
+ dict set realopts expires \
+ [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"]
+ }}
+ }
+ max-age {
+ # Normalize
+ if {[string is integer -strict $optval]} {
+ dict set realopts expires [expr {[clock seconds] + $optval}]
+ }
+ }
+ domain {
+ # From the domain-matches definition [RFC 2109, section 2]:
+ # Host A's name domain-matches host B's if [...]
+ # A is a FQDN string and has the form NB, where N is a
+ # non-empty name string, B has the form .B', and B' is a
+ # FQDN string. (So, x.y.com domain-matches .y.com but
+ # not y.com.)
+ if {$optval ne "" && ![string match *. $optval]} {
+ dict set realopts domain [string trimleft $optval "."]
+ dict set realopts hostonly [expr {
+ ! [string match .* $optval]
+ }]
+ }
+ }
+ path {
+ if {[string match /* $optval]} {
+ dict set realopts path $optval
+ }
+ }
+ secure - httponly {
+ dict set realopts [string tolower $optname] 1
+ }
+ }
+ }
+ dict set realopts key $cookiename
+ 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.
+# 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.
#
@@ -3127,7 +4313,7 @@ proc http::IsBinaryContentType {type} {
# Results:
# The line of text, without trailing newline
-proc http::getTextLine {sock} {
+proc http::GetTextLine {sock} {
set tr [fconfigure $sock -translation]
lassign $tr trRead trWrite
fconfigure $sock -translation [list crlf $trWrite]
@@ -3140,6 +4326,8 @@ proc http::getTextLine {sock} {
#
# 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} {
@@ -3149,7 +4337,7 @@ proc http::BlockingRead {sock size} {
while 1 {
set need [expr {$size - [string length $result]}]
set block [read $sock $need]
- set eof [eof $sock]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
append result $block
if {[string length $result] >= $size || $eof} {
return $result
@@ -3169,7 +4357,7 @@ proc http::BlockingRead {sock size} {
proc http::BlockingGets {sock} {
while 1 {
set count [gets $sock line]
- set eof [eof $sock]
+ set eof [expr {[catch {eof $sock} tmp] || $tmp}]
if {$count >= 0 || $eof} {
return $line
} else {
@@ -3190,16 +4378,28 @@ proc http::BlockingGets {sock} {
# This closes the connection upon error
proc http::CopyStart {sock token {initial 1}} {
- upvar #0 $token state
+ upvar 0 $token state
if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
foreach coding [ContentEncoding $token] {
- lappend state(zlib) [zlib stream $coding]
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ lappend state(zlib) [zlib stream $coding2]
}
- make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
+ MakeTransformationChunked $sock [namespace code [list CopyChunk $token]]
} else {
if {$initial} {
foreach coding [ContentEncoding $token] {
- zlib push $coding $sock
+ if {$coding eq {deflateX}} {
+ # Use the standards-compliant choice.
+ set coding2 decompress
+ } else {
+ set coding2 $coding
+ }
+ zlib push $coding2 $sock
}
}
if {[catch {
@@ -3213,6 +4413,7 @@ proc http::CopyStart {sock token {initial 1}} {
Finish $token $err
}
}
+ return
}
proc http::CopyChunk {token chunk} {
@@ -3226,7 +4427,7 @@ proc http::CopyChunk {token chunk} {
}
puts -nonewline $state(-channel) $chunk
if {[info exists state(-progress)]} {
- eval [linsert $state(-progress) end \
+ namespace eval :: [linsert $state(-progress) end \
$token $state(totalsize) $state(currentsize)]
}
} else {
@@ -3234,7 +4435,12 @@ proc http::CopyChunk {token chunk} {
if {[info exists state(zlib)]} {
set excess ""
foreach stream $state(zlib) {
- catch {set excess [$stream add -finalize $excess]}
+ catch {
+ $stream put -finalize $excess
+ set excess ""
+ set overflood ""
+ while {[set overflood [$stream get]] ne ""} { append excess $overflood }
+ }
}
puts -nonewline $state(-channel) $excess
foreach stream $state(zlib) { $stream close }
@@ -3242,6 +4448,7 @@ proc http::CopyChunk {token chunk} {
}
Eot $token ;# FIX ME: pipelining.
}
+ return
}
# http::CopyDone
@@ -3261,7 +4468,7 @@ proc http::CopyDone {token count {error {}}} {
set sock $state(sock)
incr state(currentsize) $count
if {[info exists state(-progress)]} {
- eval $state(-progress) \
+ namespace eval :: $state(-progress) \
[list $token $state(totalsize) $state(currentsize)]
}
# At this point the token may have been reset.
@@ -3272,6 +4479,7 @@ proc http::CopyDone {token count {error {}}} {
} else {
CopyStart $sock $token 0
}
+ return
}
# http::Eot
@@ -3317,7 +4525,20 @@ proc http::Eot {token {reason {}}} {
if {[string length $state(body)] > 0} {
if {[catch {
foreach coding [ContentEncoding $token] {
- set state(body) [zlib $coding $state(body)]
+ if {$coding eq {deflateX}} {
+ # First try the standards-compliant choice.
+ set coding2 decompress
+ if {[catch {zlib $coding2 $state(body)} result]} {
+ # If that fails, try the MS non-compliant choice.
+ set coding2 inflate
+ set state(body) [zlib $coding2 $state(body)]
+ } else {
+ # error {failed at standards-compliant deflate}
+ set state(body) $result
+ }
+ } else {
+ set state(body) [zlib $coding $state(body)]
+ }
}
} err]} {
Log "error doing decompression for token $token: $err"
@@ -3333,16 +4554,106 @@ proc http::Eot {token {reason {}}} {
set enc [CharsetToEncoding $state(charset)]
if {$enc ne "binary"} {
- set state(body) [encoding convertfrom $enc $state(body)]
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
+ } else {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
}
# Translate text line endings.
set state(body) [string map {\r\n \n \r \n} $state(body)]
}
+ if {[info exists state(-guesstype)] && $state(-guesstype)} {
+ GuessType $token
+ }
}
Finish $token $reason
+ return
}
+
+# ------------------------------------------------------------------------------
+# Proc http::GuessType
+# ------------------------------------------------------------------------------
+# Command to attempt limited analysis of a resource with undetermined
+# Content-Type, i.e. "application/octet-stream". This value can be set for two
+# reasons:
+# (a) by the server, in a Content-Type header
+# (b) by http::geturl, as the default value if the server does not supply a
+# Content-Type header.
+#
+# This command converts a resource if:
+# (1) it has type application/octet-stream
+# (2) it begins with an XML declaration "<?xml name="value" ... >?"
+# (3) one tag is named "encoding" and has a recognised value; or no "encoding"
+# tag exists (defaulting to utf-8)
+#
+# RFC 9110 Sec. 8.3 states:
+# "If a Content-Type header field is not present, the recipient MAY either
+# assume a media type of "application/octet-stream" ([RFC2046], Section 4.5.1)
+# or examine the data to determine its type."
+#
+# The RFC goes on to describe the pitfalls of "MIME sniffing", including
+# possible security risks.
+#
+# Arguments:
+# token - connection token
+#
+# Return Value: (boolean) true iff a change has been made
+# ------------------------------------------------------------------------------
+
+proc http::GuessType {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {$state(type) ne {application/octet-stream}} {
+ return 0
+ }
+
+ set body $state(body)
+ # e.g. {<?xml version="1.0" encoding="utf-8"?> ...}
+
+ if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
+ return 0
+ }
+ # e.g. {<?xml version="1.0" encoding="utf-8"?>}
+
+ set contents [regsub -- {[[:space:]]+} $match { }]
+ set contents [string range [string tolower $contents] 6 end-2]
+ # e.g. {version="1.0" encoding="utf-8"}
+ # without excess whitespace or upper-case letters
+
+ if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
+ return 0
+ }
+ # The application/xml default encoding:
+ set res utf-8
+
+ set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
+ foreach tag $tagList {
+ regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
+ if {$name eq {encoding}} {
+ set res $value
+ }
+ }
+ set enc [CharsetToEncoding $res]
+ if {$enc eq "binary"} {
+ return 0
+ }
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set state(body) [encoding convertfrom -profile tcl8 $enc $state(body)]
+ } else {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ set state(type) application/xml
+ set state(binary) 0
+ set state(charset) $res
+ return 1
+}
+
+
# http::wait --
#
# See documentation for details.
@@ -3387,7 +4698,7 @@ proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
- append result $sep [mapReply $i]
+ append result $sep [quoteString $i]
if {$sep eq "="} {
set sep &
} else {
@@ -3397,7 +4708,7 @@ proc http::formatQuery {args} {
return $result
}
-# http::mapReply --
+# http::quoteString --
#
# Do x-www-urlencoded character mapping
#
@@ -3407,7 +4718,7 @@ proc http::formatQuery {args} {
# Results:
# The encoded string
-proc http::mapReply {string} {
+proc http::quoteString {string} {
variable http
variable formMap
@@ -3415,20 +4726,13 @@ proc http::mapReply {string} {
# a pre-computed map and [string map] to do the conversion (much faster
# than [regsub]/[subst]). [Bug 1020491]
- if {$http(-urlencoding) ne ""} {
+ if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ set string [encoding convertto -profile tcl8 $http(-urlencoding) $string]
+ } else {
set string [encoding convertto $http(-urlencoding) $string]
- return [string map $formMap $string]
}
- set converted [string map $formMap $string]
- if {[string match "*\[\u0100-\uffff\]*" $converted]} {
- regexp "\[\u0100-\uffff\]" $converted badChar
- # Return this error message for maximum compatibility... :^/
- return -code error \
- "can't read \"formMap($badChar)\": no such element in array"
- }
- return $converted
+ return [string map $formMap $string]
}
-interp alias {} http::quoteString {} http::mapReply
# http::ProxyRequired --
# Default proxy filter.
@@ -3441,15 +4745,23 @@ interp alias {} http::quoteString {} http::mapReply
proc http::ProxyRequired {host} {
variable http
- if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
- if {
- ![info exists http(-proxyport)] ||
- ![string length $http(-proxyport)]
- } {
- set http(-proxyport) 8080
- }
- return [list $http(-proxyhost) $http(-proxyport)]
+ if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
+ return
+ }
+ if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
+ set port 8080
+ } else {
+ set port $http(-proxyport)
}
+
+ # Simple test (cf. autoproxy) for hosts that must be accessed directly,
+ # not through the proxy server.
+ foreach domain $http(-proxynot) {
+ if {[string match -nocase $domain $host]} {
+ return {}
+ }
+ }
+ return [list $http(-proxyhost) $port]
}
# http::CharsetToEncoding --
@@ -3494,16 +4806,41 @@ proc http::CharsetToEncoding {charset} {
}
}
+
+# ------------------------------------------------------------------------------
+# Proc http::ContentEncoding
+# ------------------------------------------------------------------------------
# Return the list of content-encoding transformations we need to do in order.
+#
+ # --------------------------------------------------------------------------
+ # Options for Accept-Encoding, Content-Encoding: the switch command
+ # --------------------------------------------------------------------------
+ # The symbol deflateX allows http to attempt both versions of "deflate",
+ # unless there is a -channel - for a -channel, only "decompress" is tried.
+ # Alternative/extra lines for switch:
+ # The standards-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r decompress }
+ # The Microsoft non-compliant version of "deflate" can be chosen with:
+ # deflate { lappend r inflate }
+ # The previously used implementation of "compress", which appears to be
+ # incorrect and is rarely used by web servers, can be chosen with:
+ # compress - x-compress { lappend r decompress }
+ # --------------------------------------------------------------------------
+#
+# Arguments:
+# token - Connection token.
+#
+# Return Value: list
+# ------------------------------------------------------------------------------
+
proc http::ContentEncoding {token} {
upvar 0 $token state
set r {}
if {[info exists state(coding)]} {
foreach coding [split $state(coding) ,] {
switch -exact -- $coding {
- deflate { lappend r inflate }
+ deflate { lappend r deflateX }
gzip - x-gzip { lappend r gunzip }
- compress - x-compress { lappend r decompress }
identity {}
br {
return -code error\
@@ -3594,9 +4931,525 @@ proc http::GetFieldValue {headers fieldName} {
return $r
}
-proc http::make-transformation-chunked {chan command} {
+proc http::MakeTransformationChunked {chan command} {
coroutine [namespace current]::dechunk$chan ::http::ReceiveChunked $chan $command
chan event $chan readable [namespace current]::dechunk$chan
+ return
+}
+
+interp alias {} http::data {} http::responseBody
+interp alias {} http::code {} http::responseLine
+interp alias {} http::mapReply {} http::quoteString
+interp alias {} http::meta {} http::responseHeaders
+interp alias {} http::metaValue {} http::responseHeaderValue
+interp alias {} http::ncode {} http::responseCode
+
+
+# ------------------------------------------------------------------------------
+# Proc http::socketForTls
+# ------------------------------------------------------------------------------
+# Command to use in place of ::socket as the value of ::tls::socketCmd.
+# This command does the same as http::socket, and also handles https connections
+# through a proxy server.
+#
+# Notes.
+# - The proxy server works differently for https and http. This implementation
+# is for https. The proxy for http is implemented in http::CreateToken (in
+# code that was previously part of http::geturl).
+# - This code implicitly uses the tls options set for https in a call to
+# http::register, and does not need to call commands tls::*. This simple
+# implementation is possible because tls uses a callback to ::socket that can
+# be redirected by changing the value of ::tls::socketCmd.
+#
+# Arguments:
+# args - as for ::socket
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+
+proc http::socketForTls {args} {
+ variable http
+ set host [lindex $args end-1]
+ set port [lindex $args end]
+ if { ($http(-proxyfilter) ne {})
+ && (![catch {$http(-proxyfilter) $host} proxy])
+ } {
+ set phost [lindex $proxy 0]
+ set pport [lindex $proxy 1]
+ } else {
+ set phost {}
+ set pport {}
+ }
+ if {$phost eq ""} {
+ set sock [::http::socket {*}$args]
+ } else {
+ set sock [::http::SecureProxyConnect {*}$args $phost $pport]
+ }
+ return $sock
+}
+
+
+# ------------------------------------------------------------------------------
+# Proc http::SecureProxyConnect
+# ------------------------------------------------------------------------------
+# Command to open a socket through a proxy server to a remote server for use by
+# tls. The caller must perform the tls handshake.
+#
+# Notes
+# - Based on patch supplied by Melissa Chawla in ticket 1173760, and
+# Proxy-Authorization header cf. autoproxy by Pat Thoyts.
+# - Rewritten as a call to http::geturl, because response headers and body are
+# needed if the CONNECT request fails. CONNECT is implemented for this case
+# only, by state(bypass).
+# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT.
+# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014),
+# RFC 9112 (June 2022).
+#
+# Arguments:
+# args - as for ::socket, ending in host, port; with proxy host, proxy
+# port appended.
+#
+# Return Value: a socket identifier
+# ------------------------------------------------------------------------------
+
+proc http::SecureProxyConnect {args} {
+ variable http
+ variable ConnectVar
+ variable ConnectCounter
+ variable failedProxyValues
+ set varName ::http::ConnectVar([incr ConnectCounter])
+
+ # Extract (non-proxy) target from args.
+ set host [lindex $args end-3]
+ set port [lindex $args end-2]
+ set args [lreplace $args end-3 end-2]
+
+ # Proxy server URL for connection.
+ # This determines where the socket is opened.
+ set phost [lindex $args end-1]
+ set pport [lindex $args end]
+ if {[string first : $phost] != -1} {
+ # IPv6 address, wrap it in [] so we can append :pport
+ set phost "\[${phost}\]"
+ }
+ set url http://${phost}:${pport}
+ # Elements of args other than host and port are not used when
+ # AsyncTransaction opens a socket. Those elements are -async and the
+ # -type $tokenName for the https transaction. Option -async is used by
+ # AsyncTransaction anyway, and -type $tokenName should not be propagated:
+ # the proxy request adds its own -type value.
+
+ set targ [lsearch -exact $args -type]
+ if {$targ != -1} {
+ # Record in the token that this is a proxy call.
+ set token [lindex $args $targ+1]
+ upvar 0 ${token} state
+ set tim $state(-timeout)
+ set state(proxyUsed) SecureProxyFailed
+ # This value is overwritten with "SecureProxy" below if the CONNECT is
+ # successful. If it is unsuccessful, the socket will be closed
+ # below, and so in this unsuccessful case there are no other transactions
+ # whose (proxyUsed) must be updated.
+ } else {
+ set tim 0
+ }
+ if {$tim == 0} {
+ # Do not use infinite timeout for the proxy.
+ set tim 30000
+ }
+
+ # Prepare and send a CONNECT request to the proxy, using
+ # code similar to http::geturl.
+ set requestHeaders [list Host $host]
+ lappend requestHeaders Connection keep-alive
+ if {$http(-proxyauth) != {}} {
+ lappend requestHeaders Proxy-Authorization $http(-proxyauth)
+ }
+
+ set token2 [CreateToken $url -keepalive 0 -timeout $tim \
+ -headers $requestHeaders -command [list http::AllDone $varName]]
+ variable $token2
+ upvar 0 $token2 state2
+
+ # Kludges:
+ # Setting this variable overrides the HTTP request line and also allows
+ # -headers to override the Connection: header set by -keepalive.
+ # The arguments "-keepalive 0" ensure that when Finish is called for an
+ # unsuccessful request, the socket is always closed.
+ set state2(bypass) "CONNECT $host:$port HTTP/1.1"
+
+ AsyncTransaction $token2
+
+ 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
+ }
+ unset $varName
+
+ if { ($state2(state) ne "complete")
+ || ($state2(status) ne "ok")
+ || (![string is integer -strict $state2(responseCode)])
+ } {
+ set msg {the HTTP request to the proxy server did not return a valid\
+ and complete response}
+ if {[info exists state2(error)]} {
+ append msg ": " [lindex $state2(error) 0]
+ }
+ cleanup $token2
+ return -code error $msg
+ }
+
+ set code $state2(responseCode)
+
+ if {($code >= 200) && ($code < 300)} {
+ # All OK. The caller in package tls will now call "tls::import $sock".
+ # The cleanup command does not close $sock.
+ # Other tidying was done in http::Event.
+
+ # If this is a persistent socket, any other transactions that are
+ # already marked to use the socket will have their (proxyUsed) updated
+ # when http::OpenSocket calls http::ConfigureNewSocket.
+ set state(proxyUsed) SecureProxy
+ set sock $state2(sock)
+ cleanup $token2
+ return $sock
+ }
+
+ if {$targ != -1} {
+ # Non-OK HTTP status code; token is known because option -type
+ # (cf. targ) was passed through tcltls, and so the useful
+ # parts of the proxy's response can be copied to state(*).
+ # Do not copy state2(sock).
+ # Return the proxy response to the caller of geturl.
+ foreach name $failedProxyValues {
+ if {[info exists state2($name)]} {
+ set state($name) $state2($name)
+ }
+ }
+ set state(connection) close
+ set msg "proxy connect failed: $code"
+ # - This error message will be detected by http::OpenSocket and will
+ # cause it to present the proxy's HTTP response as that of the
+ # original $token transaction, identified only by state(proxyUsed)
+ # as the response of the proxy.
+ # - The cases where this would mislead the caller of http::geturl are
+ # given a different value of msg (below) so that http::OpenSocket will
+ # treat them as errors, but will preserve the $token array for
+ # inspection by the caller.
+ # - Status code 305 (Proxy Required) was deprecated for security reasons
+ # in RFC 2616 (June 1999) and in any case should never be served by a
+ # proxy.
+ # - Other 3xx responses from the proxy are inappropriate, and should not
+ # occur.
+ # - A 401 response from the proxy is inappropriate, and should not
+ # occur. It would be confusing if returned to the caller.
+
+ if {($code >= 300) && ($code < 400)} {
+ set msg "the proxy server responded to the HTTP request with an\
+ inappropriate $code redirect"
+ set loc [responseHeaderValue $token2 location]
+ if {$loc ne {}} {
+ append msg "to " $loc
+ }
+ } elseif {($code == 401)} {
+ set msg "the proxy server responded to the HTTP request with an\
+ inappropriate 401 request for target-host credentials"
+ } else {
+ }
+ } else {
+ set msg "connection to proxy failed with status code $code"
+ }
+
+ # - ${token2}(sock) has already been closed because -keepalive 0.
+ # - Error return does not pass the socket ID to the
+ # $token transaction, which retains its socket placeholder.
+ cleanup $token2
+ return -code error $msg
+}
+
+proc http::AllDone {varName args} {
+ set $varName done
+ 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.
+# - Unexpected behaviour by thread::send -async (Thread 2.8.6).
+# An error in thread::send -async causes return of just the error message
+# (not the expected 3 elements), and raises a bgerror in the main thread.
+# Hence wrap the command with catch as a precaution.
+# ------------------------------------------------------------------------------
+
+proc http::socket {args} {
+ variable ThreadVar
+ variable ThreadCounter
+ variable http
+
+ LoadThreadIfNeeded
+
+ set targ [lsearch -exact $args -type]
+ 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 "
+ set code \[catch {
+ [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
+ [list ::SockInThread [thread::id] $defcmd $sockargs]
+ } result opts\]
+ list \$code \$opts \$result
+ "
+
+ 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) {}
+ set result [set $varName]
+ unset $varName
+ if {(![string is list $result]) || ([llength $result] != 3)} {
+ return -code error "result from peer thread is not a list of\
+ length 3: it is \n$result"
+ }
+ lassign $result threadCode threadDict threadResult
+ if {($threadCode != 0)} {
+ # This is an error in thread::send. Return the lot.
+ return -options $threadDict -code error $threadResult
+ }
+
+ # Now the results of the catch in the peer thread.
+ lassign $threadResult catchCode errdict sock
+
+ if {($catchCode == 0) && ($sock ni [chan names])} {
+ return -code error {Transfer of socket from peer thread failed.\
+ Check that this script is not running in a child interpreter.}
+ }
+ return -options $errdict -code $catchCode $sock
+}
+
+# The commands below are dependencies of http::socket and
+# http::SecureProxyConnect 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:
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index bb742fd..8977ef3 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-package ifneeded http 2.9.8 [list tclPkgSetup $dir http 2.9.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.10b1 [list tclPkgSetup $dir http 2.10b1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl
deleted file mode 100644
index 8329de4..0000000
--- a/library/http1.0/http.tcl
+++ /dev/null
@@ -1,377 +0,0 @@
-# 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 http.n man page for documentation
-
-package provide http 1.0
-
-array set http {
- -accept */*
- -proxyhost {}
- -proxyport {}
- -useragent {Tcl http client package 1.0}
- -proxyfilter httpProxyRequired
-}
-proc http_config {args} {
- global http
- set options [lsort [array names http -*]]
- set usage [join $options ", "]
- if {[llength $args] == 0} {
- set result {}
- foreach name $options {
- lappend result $name $http($name)
- }
- return $result
- }
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- if {[llength $args] == 1} {
- set flag [lindex $args 0]
- if {[regexp -- $pat $flag]} {
- return $http($flag)
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- } else {
- foreach {flag value} $args {
- if {[regexp -- $pat $flag]} {
- set http($flag) $value
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- }
- }
-}
-
- proc httpFinish { token {errormsg ""} } {
- upvar #0 $token state
- global errorInfo errorCode
- if {[string length $errormsg] != 0} {
- set state(error) [list $errormsg $errorInfo $errorCode]
- set state(status) error
- }
- catch {close $state(sock)}
- catch {after cancel $state(after)}
- if {[info exists state(-command)]} {
- if {[catch {eval $state(-command) {$token}} err]} {
- if {[string length $errormsg] == 0} {
- set state(error) [list $err $errorInfo $errorCode]
- set state(status) error
- }
- }
- unset state(-command)
- }
-}
-proc http_reset { token {why reset} } {
- upvar #0 $token state
- set state(status) $why
- catch {fileevent $state(sock) readable {}}
- httpFinish $token
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state(error)
- eval error $errorlist
- }
-}
-proc http_get { url args } {
- global http
- if {![info exists http(uid)]} {
- set http(uid) 0
- }
- set token http#[incr http(uid)]
- upvar #0 $token state
- http_reset $token
- array set state {
- -blocksize 8192
- -validate 0
- -headers {}
- -timeout 0
- state header
- meta {}
- currentsize 0
- totalsize 0
- type text/html
- body {}
- status ""
- }
- set options {-blocksize -channel -command -handler -headers \
- -progress -query -validate -timeout}
- set usage [join $options ", "]
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- foreach {flag value} $args {
- if {[regexp $pat $flag]} {
- # Validate numbers
- if {[info exists state($flag)] && \
- [regexp {^[0-9]+$} $state($flag)] && \
- ![regexp {^[0-9]+$} $value]} {
- return -code error "Bad value for $flag ($value), must be integer"
- }
- set state($flag) $value
- } else {
- return -code error "Unknown option $flag, can be: $usage"
- }
- }
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
- x proto host y port srvurl]} {
- error "Unsupported URL: $url"
- }
- if {[string length $port] == 0} {
- set port 80
- }
- if {[string length $srvurl] == 0} {
- set srvurl /
- }
- if {[string length $proto] == 0} {
- set url http://$url
- }
- set state(url) $url
- if {![catch {$http(-proxyfilter) $host} proxy]} {
- set phost [lindex $proxy 0]
- set pport [lindex $proxy 1]
- }
- if {$state(-timeout) > 0} {
- set state(after) [after $state(-timeout) [list http_reset $token timeout]]
- }
- if {[info exists phost] && [string length $phost]} {
- set srvurl $url
- set s [socket $phost $pport]
- } else {
- set s [socket $host $port]
- }
- set state(sock) $s
-
- # Send data in cr-lf format, but accept any line terminators
-
- fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
-
- # The following is disallowed in safe interpreters, but the socket
- # is already in non-blocking mode in that case.
-
- catch {fconfigure $s -blocking off}
- set len 0
- set how GET
- if {[info exists state(-query)]} {
- set len [string length $state(-query)]
- if {$len > 0} {
- set how POST
- }
- } elseif {$state(-validate)} {
- set how HEAD
- }
- puts $s "$how $srvurl HTTP/1.0"
- puts $s "Accept: $http(-accept)"
- puts $s "Host: $host"
- puts $s "User-Agent: $http(-useragent)"
- foreach {key value} $state(-headers) {
- regsub -all \[\n\r\] $value {} value
- set key [string trim $key]
- if {[string length $key]} {
- puts $s "$key: $value"
- }
- }
- if {$len > 0} {
- puts $s "Content-Length: $len"
- puts $s "Content-Type: application/x-www-form-urlencoded"
- puts $s ""
- fconfigure $s -translation {auto binary}
- puts -nonewline $s $state(-query)
- } else {
- puts $s ""
- }
- flush $s
- fileevent $s readable [list httpEvent $token]
- if {! [info exists state(-command)]} {
- http_wait $token
- }
- return $token
-}
-proc http_data {token} {
- upvar #0 $token state
- return $state(body)
-}
-proc http_status {token} {
- upvar #0 $token state
- return $state(status)
-}
-proc http_code {token} {
- upvar #0 $token state
- return $state(http)
-}
-proc http_size {token} {
- upvar #0 $token state
- return $state(currentsize)
-}
-
- proc httpEvent {token} {
- upvar #0 $token state
- set s $state(sock)
-
- if {[eof $s]} {
- httpEof $token
- return
- }
- if {$state(state) == "header"} {
- set n [gets $s line]
- if {$n == 0} {
- set state(state) body
- if {![regexp -nocase ^text $state(type)]} {
- # Turn off conversions for non-text data
- fconfigure $s -translation binary
- if {[info exists state(-channel)]} {
- fconfigure $state(-channel) -translation binary
- }
- }
- if {[info exists state(-channel)] &&
- ![info exists state(-handler)]} {
- # Initiate a sequence of background fcopies
- fileevent $s readable {}
- httpCopyStart $s $token
- }
- } elseif {$n > 0} {
- if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
- set state(type) [string trim $type]
- }
- if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
- set state(totalsize) [string trim $length]
- }
- if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
- lappend state(meta) $key $value
- } elseif {[regexp ^HTTP $line]} {
- set state(http) $line
- }
- }
- } else {
- if {[catch {
- if {[info exists state(-handler)]} {
- set n [eval $state(-handler) {$s $token}]
- } else {
- set block [read $s $state(-blocksize)]
- set n [string length $block]
- if {$n >= 0} {
- append state(body) $block
- }
- }
- if {$n >= 0} {
- incr state(currentsize) $n
- }
- } err]} {
- httpFinish $token $err
- } else {
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- }
- }
-}
- proc httpCopyStart {s token} {
- upvar #0 $token state
- if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
- [list httpCopyDone $token]
- } err]} {
- httpFinish $token $err
- }
-}
- proc httpCopyDone {token count {error {}}} {
- upvar #0 $token state
- set s $state(sock)
- incr state(currentsize) $count
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- if {([string length $error] != 0)} {
- httpFinish $token $error
- } elseif {[eof $s]} {
- httpEof $token
- } else {
- httpCopyStart $s $token
- }
-}
- proc httpEof {token} {
- upvar #0 $token state
- if {$state(state) == "header"} {
- # Premature eof
- set state(status) eof
- } else {
- set state(status) ok
- }
- set state(state) eof
- httpFinish $token
-}
-proc http_wait {token} {
- upvar #0 $token state
- if {![info exists state(status)] || [string length $state(status)] == 0} {
- vwait $token\(status)
- }
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state(error)
- eval error $errorlist
- }
- return $state(status)
-}
-
-# Call http_formatQuery with an even number of arguments, where the first is
-# a name, the second is a value, the third is another name, and so on.
-
-proc http_formatQuery {args} {
- set result ""
- set sep ""
- foreach i $args {
- append result $sep [httpMapReply $i]
- if {$sep != "="} {
- set sep =
- } else {
- set sep &
- }
- }
- return $result
-}
-
-# do x-www-urlencoded character mapping
-# The spec says: "non-alphanumeric characters are replaced by '%HH'"
-# 1 leave alphanumerics characters alone
-# 2 Convert every other character to an array lookup
-# 3 Escape constructs that are "special" to the tcl parser
-# 4 "subst" the result, doing all the array substitutions
-
- proc httpMapReply {string} {
- global httpFormMap
- set alphanumeric a-zA-Z0-9
- if {![info exists httpFormMap]} {
-
- for {set i 1} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$alphanumeric\] $c]} {
- set httpFormMap($c) %[format %.2x $i]
- }
- }
- # These are handled specially
- array set httpFormMap {
- " " + \n %0d%0a
- }
- }
- regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# Default proxy filter.
- proc httpProxyRequired {host} {
- global http
- if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
- if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
- set http(-proxyport) 8080
- }
- return [list $http(-proxyhost) $http(-proxyport)]
- } else {
- return {}
- }
-}
diff --git a/library/http1.0/pkgIndex.tcl b/library/http1.0/pkgIndex.tcl
deleted file mode 100644
index ab6170f..0000000
--- a/library/http1.0/pkgIndex.tcl
+++ /dev/null
@@ -1,11 +0,0 @@
-# Tcl package index file, version 1.0
-# This file is generated by the "pkg_mkIndex" 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.
-
-package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}]
diff --git a/library/init.tcl b/library/init.tcl
index 9412e00..33be0ac 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,10 +3,13 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2004 Kevin B. Kenny. All rights reserved.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2004 Kevin B. Kenny.
+# Copyright © 2018 Sean Woods
+#
+# All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,7 +19,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.6.13
+package require -exact tcl 8.7a6
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -78,81 +81,10 @@ namespace eval tcl {
}
unset Dir Path
}
-
- # TIP #255 min and max functions
- namespace eval mathfunc {
- proc min {args} {
- if {![llength $args]} {
- return -code error \
- "not enough arguments to math function \"min\""
- }
- set val Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg < $val} {set val $arg}
- }
- return $val
- }
- proc max {args} {
- if {![llength $args]} {
- return -code error \
- "not enough arguments to math function \"max\""
- }
- set val -Inf
- foreach arg $args {
- # This will handle forcing the numeric value without
- # ruining the internal type of a numeric object
- if {[catch {expr {double($arg)}} err]} {
- return -code error $err
- }
- if {$arg > $val} {set val $arg}
- }
- return $val
- }
- namespace export min max
- }
}
-# Windows specific end of initialization
-
-if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
- namespace eval tcl {
- proc EnvTraceProc {lo n1 n2 op} {
- global env
- set x $env($n2)
- set env($lo) $x
- set env([string toupper $lo]) $x
- }
- proc InitWinEnv {} {
- global env tcl_platform
- foreach p [array names env] {
- set u [string toupper $p]
- if {$u ne $p} {
- switch -- $u {
- COMSPEC -
- PATH {
- set temp $env($p)
- unset env($p)
- set env($u) $temp
- trace add variable env($p) write \
- [namespace code [list EnvTraceProc $p]]
- trace add variable env($u) write \
- [namespace code [list EnvTraceProc $p]]
- }
- }
- }
- }
- if {![info exists env(COMSPEC)]} {
- set env(COMSPEC) cmd.exe
- }
- }
- InitWinEnv
- }
-}
+namespace eval tcl::Pkg {}
+
# Setup the unknown package handler
@@ -180,7 +112,7 @@ if {[interp issafe]} {
foreach cmd {add format scan} {
proc ::tcl::clock::$cmd args {
variable TclLibDir
- source -encoding utf-8 [file join $TclLibDir clock.tcl]
+ source [file join $TclLibDir clock.tcl]
return [uplevel 1 [info level 0]]
}
}
@@ -282,9 +214,9 @@ proc unknown args {
set errInfo [dict get $opts -errorinfo]
set errCode [dict get $opts -errorcode]
set cinfo $args
- if {[string bytelength $cinfo] > 150} {
+ if {[string length [encoding convertto utf-8 $cinfo]] > 150} {
set cinfo [string range $cinfo 0 150]
- while {[string bytelength $cinfo] > 150} {
+ while {[string length [encoding convertto utf-8 $cinfo]] > 150} {
set cinfo [string range $cinfo 0 end-1]
}
append cinfo ...
@@ -463,6 +395,22 @@ proc auto_load {cmd {namespace {}}} {
return 0
}
+# ::tcl::Pkg::source --
+# This procedure provides an alternative "source" command, which doesn't
+# register the file for the "package files" command. Safe interpreters
+# don't have to do anything special.
+#
+# Arguments:
+# filename
+
+proc ::tcl::Pkg::source {filename} {
+ if {[interp issafe]} {
+ uplevel 1 [list ::source $filename]
+ } else {
+ uplevel 1 [list ::source -nopkg $filename]
+ }
+}
+
# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list. This is usually invoked within auto_load to load the index
@@ -494,7 +442,7 @@ proc auto_load_index {} {
continue
} else {
set error [catch {
- fconfigure $f -eofchar "\032 {}"
+ fconfigure $f -encoding utf-8 -eofchar "\x1A {}"
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
@@ -506,7 +454,7 @@ proc auto_load_index {} {
}
set name [lindex $line 0]
set auto_index($name) \
- "source [file join $dir [lindex $line 1]]"
+ "::tcl::Pkg::source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
@@ -680,10 +628,7 @@ proc auto_execok name {
set windir $env(WINDIR)
}
if {[info exists windir]} {
- if {$tcl_platform(os) eq "Windows NT"} {
- append path "$windir/system32;"
- }
- append path "$windir/system;$windir;"
+ append path "$windir/system32;$windir/system;$windir;"
}
foreach var {PATH Path path} {
@@ -781,7 +726,7 @@ proc tcl::CopyDirectory {action src dest} {
# the following code is now commented out.
#
# return -code error "error $action \"$src\" to\
- # \"$dest\": file already exists"
+ # \"$dest\": file exists"
} else {
# Depending on the platform, and on the current
# working directory, the directories '.', '..'
@@ -793,7 +738,7 @@ proc tcl::CopyDirectory {action src dest} {
foreach s $existing {
if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
- \"$dest\": file already exists"
+ \"$dest\": file exists"
}
}
}
diff --git a/library/install.tcl b/library/install.tcl
new file mode 100644
index 0000000..50e40df
--- /dev/null
+++ b/library/install.tcl
@@ -0,0 +1,247 @@
+###
+# Installer actions built into tclsh and invoked
+# if the first command line argument is "install"
+###
+if {[llength $argv] < 2} {
+ exit 0
+}
+namespace eval ::practcl {}
+###
+# Installer tools
+###
+proc ::practcl::_isdirectory name {
+ return [file isdirectory $name]
+}
+###
+# Return true if the pkgindex file contains
+# any statement other than "package ifneeded"
+# and/or if any package ifneeded loads a DLL
+###
+proc ::practcl::_pkgindex_directory {path} {
+ set buffer {}
+ set pkgidxfile [file join $path pkgIndex.tcl]
+ if {![file exists $pkgidxfile]} {
+ # No pkgIndex file, read the source
+ foreach file [glob -nocomplain $path/*.tm] {
+ set file [file normalize $file]
+ set fname [file rootname [file tail $file]]
+ ###
+ # We used to be able to ... Assume the package is correct in the filename
+ # No hunt for a "package provides"
+ ###
+ set package [lindex [split $fname -] 0]
+ set version [lindex [split $fname -] 1]
+ ###
+ # Read the file, and override assumptions as needed
+ ###
+ set fin [open $file r]
+ fconfigure $fin -encoding utf-8 -eofchar "\x1A {}"
+ set dat [read $fin]
+ close $fin
+ # Look for a teapot style Package statement
+ foreach line [split $dat \n] {
+ set line [string trim $line]
+ if { [string range $line 0 9] != "# Package " } continue
+ set package [lindex $line 2]
+ set version [lindex $line 3]
+ break
+ }
+ # Look for a package provide statement
+ foreach line [split $dat \n] {
+ set line [string trim $line]
+ if { [string range $line 0 14] != "package provide" } continue
+ set package [lindex $line 2]
+ set version [lindex $line 3]
+ break
+ }
+ append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
+ }
+ foreach file [glob -nocomplain $path/*.tcl] {
+ if { [file tail $file] == "version_info.tcl" } continue
+ set fin [open $file r]
+ fconfigure $fin -encoding utf-8 -eofchar "\x1A {}"
+ set dat [read $fin]
+ close $fin
+ if {![regexp "package provide" $dat]} continue
+ set fname [file rootname [file tail $file]]
+ # Look for a package provide statement
+ foreach line [split $dat \n] {
+ set line [string trim $line]
+ if { [string range $line 0 14] != "package provide" } continue
+ set package [lindex $line 2]
+ set version [lindex $line 3]
+ if {[string index $package 0] in "\$ \[ @"} continue
+ if {[string index $version 0] in "\$ \[ @"} continue
+ append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
+ break
+ }
+ }
+ return $buffer
+ }
+ set fin [open $pkgidxfile r]
+ fconfigure $fin -encoding utf-8 -eofchar "\x1A {}"
+ set dat [read $fin]
+ close $fin
+ set trace 0
+ #if {[file tail $path] eq "tool"} {
+ # set trace 1
+ #}
+ set thisline {}
+ foreach line [split $dat \n] {
+ append thisline $line \n
+ if {![info complete $thisline]} continue
+ set line [string trim $line]
+ if {[string length $line]==0} {
+ set thisline {} ; continue
+ }
+ if {[string index $line 0] eq "#"} {
+ set thisline {} ; continue
+ }
+ if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} {
+ if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"}
+ set thisline {} ; continue
+ }
+ if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
+ if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
+ set thisline {} ; continue
+ }
+ if {![regexp "package.*ifneeded" $thisline]} {
+ # This package index contains arbitrary code
+ # source instead of trying to add it to the main
+ # package index
+ if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" }
+ return {source [file join $dir pkgIndex.tcl]}
+ }
+ append buffer $thisline \n
+ set thisline {}
+ }
+ if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]}
+ return $buffer
+}
+
+
+proc ::practcl::_pkgindex_path_subdir {path} {
+ set result {}
+ foreach subpath [glob -nocomplain [file join $path *]] {
+ if {[file isdirectory $subpath]} {
+ lappend result $subpath {*}[_pkgindex_path_subdir $subpath]
+ }
+ }
+ return $result
+}
+###
+# Index all paths given as though they will end up in the same
+# virtual file system
+###
+proc ::practcl::pkgindex_path args {
+ set stack {}
+ set buffer {
+lappend ::PATHSTACK $dir
+ }
+ foreach base $args {
+ set base [file normalize $base]
+ set paths {}
+ foreach dir [glob -nocomplain [file join $base *]] {
+ if {[file tail $dir] eq "teapot"} continue
+ lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir]
+ }
+ set i [string length $base]
+ # Build a list of all of the paths
+ if {[llength $paths]} {
+ foreach path $paths {
+ if {$path eq $base} continue
+ set path_indexed($path) 0
+ }
+ } else {
+ puts [list WARNING: NO PATHS FOUND IN $base]
+ }
+ set path_indexed($base) 1
+ set path_indexed([file join $base boot tcl]) 1
+ foreach teapath [glob -nocomplain [file join $base teapot *]] {
+ set pkg [file tail $teapath]
+ append buffer [list set pkg $pkg]
+ append buffer {
+set pkginstall [file join $::g(HOME) teapot $pkg]
+if {![file exists $pkginstall]} {
+ installDir [file join $dir teapot $pkg] $pkginstall
+}
+}
+ }
+ foreach path $paths {
+ if {$path_indexed($path)} continue
+ set thisdir [file_relative $base $path]
+ set idxbuf [::practcl::_pkgindex_directory $path]
+ if {[string length $idxbuf]} {
+ incr path_indexed($path)
+ append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n
+ append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n
+ }
+ }
+ }
+ append buffer {
+set dir [lindex $::PATHSTACK end]
+set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
+}
+ return $buffer
+}
+
+###
+# topic: 64319f4600fb63c82b2258d908f9d066
+# description: Script to build the VFS file system
+###
+proc ::practcl::installDir {d1 d2} {
+
+ puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]]
+ file delete -force -- $d2
+ file mkdir $d2
+
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ installDir $f [file join $d2 $ftail]
+ } elseif {[file isfile $f]} {
+ file copy -force $f [file join $d2 $ftail]
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes [file join $d2 $ftail] -permissions 0o644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes $d2 -permissions 0o755
+ } else {
+ file attributes $d2 -readonly 1
+ }
+}
+
+proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
+ #if {$toplevel} {
+ # puts [list ::practcl::copyDir $d1 -> $d2]
+ #}
+ #file delete -force -- $d2
+ file mkdir $d2
+
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ copyDir $f [file join $d2 $ftail] 0
+ } elseif {[file isfile $f]} {
+ file copy -force $f [file join $d2 $ftail]
+ }
+ }
+}
+
+switch [lindex $argv 1] {
+ mkzip {
+ zipfs mkzip {*}[lrange $argv 2 end]
+ }
+ mkzip {
+ zipfs mkimg {*}[lrange $argv 2 end]
+ }
+ default {
+ ::practcl::[lindex $argv 1] {*}[lrange $argv 2 end]
+ }
+}
+exit 0
diff --git a/library/manifest.txt b/library/manifest.txt
new file mode 100644
index 0000000..5a999f4
--- /dev/null
+++ b/library/manifest.txt
@@ -0,0 +1,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.10b1 {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.19 {platform platform.tcl}
+ 0 platform::shell 1.1.4 {platform shell.tcl}
+ 1 tcltest 2.5.6 {tcltest tcltest.tcl}
+ } {
+ if {$isafe && !$safe} continue
+ package ifneeded $package $version [list source [file join $dir {*}$file]]
+ }
+}} $dir
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 851ad77..fa21685 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -4,22 +4,24 @@
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
-# Copyright (c) 2010-2015 Harald Oehlmann.
-# Copyright (c) 1998-2000 Ajuba Solutions.
-# Copyright (c) 1998 Mark Harrison.
+# Copyright © 2010-2018 Harald Oehlmann.
+# Copyright © 1998-2000 Ajuba Solutions.
+# Copyright © 1998 Mark Harrison.
#
# 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.5-
+# We use oo::define::self, which is new in Tcl 8.7
+package require Tcl 8.7-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
-package provide msgcat 1.6.1
+package provide msgcat 1.7.1
namespace eval msgcat {
- namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
+ namespace export mc mcn mcexists mcload mclocale mcmax\
+ mcmset mcpreferences mcset\
mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
- mcpackageconfig mcpackagelocale
+ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
# Records the list of locales to search
variable Loclist {}
@@ -41,6 +43,12 @@ namespace eval msgcat {
# namespace should be themselves dict values and the value is
# the translated string.
variable Msgs [dict create]
+}
+
+# create ensemble namespace for mcutil command
+namespace eval msgcat::mcutil {
+ namespace export getsystemlocale getpreferences
+ namespace ensemble create -prefix 0
# Map of language codes used in Windows registry to those of ISO-639
if {[info sharedlibextension] eq ".dll"} {
@@ -192,10 +200,31 @@ namespace eval msgcat {
# Returns the translated string. Propagates errors thrown by the
# format command.
-proc msgcat::mc {src args} {
- # this may be replaced by:
- # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
- # $src {*}$args]
+proc msgcat::mc {args} {
+ tailcall mcn [PackageNamespaceGet] {*}$args
+}
+
+# msgcat::mcn --
+#
+# Find the translation for the given string based on the current
+# locale setting. Check the passed namespace first, then look in each
+# parent namespace until the source is found. If additional args are
+# specified, use the format command to work them into the translated
+# string.
+#
+# If no catalog item is found, mcunknown is called in the caller frame
+# and its result is returned.
+#
+# Arguments:
+# ns Package namespace of the translation
+# src The string to translate.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated string. Propagates errors thrown by the
+# format command.
+
+proc msgcat::mcn {ns src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
@@ -203,7 +232,6 @@ proc msgcat::mc {src args} {
variable Msgs
variable Loclist
- set ns [uplevel 1 [list ::namespace current]]
set loclist [PackagePreferences $ns]
set nscur $ns
@@ -219,7 +247,7 @@ proc msgcat::mc {src args} {
# call package local or default unknown command
set args [linsert $args 0 [lindex $loclist 0] $src]
switch -exact -- [Invoke unknowncmd $args $ns result 1] {
- 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
+ 0 { tailcall mcunknown {*}$args }
1 { return [DefaultUnknown {*}$args] }
default { return $result }
}
@@ -245,31 +273,39 @@ proc msgcat::mcexists {args} {
variable Loclist
variable PackageConfig
- set ns [uplevel 1 [list ::namespace current]]
- set loclist [PackagePreferences $ns]
-
while {[llength $args] != 1} {
set args [lassign $args option]
switch -glob -- $option {
- -exactnamespace { set exactnamespace 1 }
- -exactlocale { set loclist [lrange $loclist 0 0] }
+ -exactnamespace - -exactlocale { set $option 1 }
+ -namespace {
+ if {[llength $args] < 2} {
+ return -code error\
+ "Argument missing for switch \"-namespace\""
+ }
+ set args [lassign $args ns]
+ }
-* { return -code error "unknown option \"$option\"" }
default {
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] ?-exactnamespace?\
- ?-exactlocale? src\""
+ ?-exactlocale? ?-namespace ns? src\""
}
}
}
set src [lindex $args 0]
+ if {![info exists ns]} { set ns [PackageNamespaceGet] }
+
+ set loclist [PackagePreferences $ns]
+ if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
+
while {$ns ne ""} {
foreach loc $loclist {
if {[dict exists $Msgs $ns $loc $src]} {
return 1
}
}
- if {[info exists exactnamespace]} {return 0}
+ if {[info exists -exactnamespace]} {return 0}
set ns [namespace parent $ns]
}
return 0
@@ -303,44 +339,41 @@ proc msgcat::mclocale {args} {
return -code error "invalid newLocale value \"$newLocale\":\
could be path to unsafe code."
}
- if {[lindex $Loclist 0] ne $newLocale} {
- set Loclist [GetPreferences $newLocale]
-
- # locale not loaded jet
- LoadAll $Loclist
- # Invoke callback
- Invoke changecmd $Loclist
- }
+ mcpreferences {*}[mcutil getpreferences $newLocale]
}
return [lindex $Loclist 0]
}
-# msgcat::GetPreferences --
+# msgcat::mcutil::getpreferences --
#
# Get list of locales from a locale.
# The first element is always the lowercase locale.
# Other elements have one component separated by "_" less.
# Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
#
+# This method is part of the ensemble mcutil
+#
# Arguments:
# Locale.
#
# Results:
# Locale list
-proc msgcat::GetPreferences {locale} {
+proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
- set loclist [list $locale]
- while {-1 !=[set pos [string last "_" $locale]]} {
- set locale [string range $locale 0 $pos-1]
- if { "_" ne [string index $locale end] } {
- lappend loclist $locale
+ set result [list {}]
+ set el {}
+ foreach e [split $locale _] {
+ if {$el eq {}} {
+ set el ${e}
+ } else {
+ set el ${el}_${e}
+ }
+ if {[string index $el end] != {_}} {
+ set result [linsert $result 0 $el]
}
}
- if {"" ne [lindex $loclist end]} {
- lappend loclist {}
- }
- return $loclist
+ return $result
}
# msgcat::mcpreferences --
@@ -349,16 +382,51 @@ proc msgcat::GetPreferences {locale} {
# most preferred to least preferred.
#
# Arguments:
-# None.
+# New location list
#
# Results:
# Returns an ordered list of the locales preferred by the user.
-proc msgcat::mcpreferences {} {
+proc msgcat::mcpreferences {args} {
variable Loclist
+
+ if {[llength $args] > 0} {
+ # args is the new loclist
+ if {![ListEqualString $args $Loclist]} {
+ set Loclist $args
+
+ # locale not loaded jet
+ LoadAll $Loclist
+ # Invoke callback
+ Invoke changecmd $Loclist
+ }
+ }
return $Loclist
}
+# msgcat::ListStringEqual --
+#
+# Compare two strings for equal string contents
+#
+# Arguments:
+# list1 first list
+# list2 second list
+#
+# Results:
+# 1 if lists of strings are identical, 0 otherwise
+
+proc msgcat::ListEqualString {list1 list2} {
+ if {[llength $list1] != [llength $list2]} {
+ return 0
+ }
+ foreach item1 $list1 item2 $list2 {
+ if {$item1 ne $item2} {
+ return 0
+ }
+ }
+ return 1
+}
+
# msgcat::mcloadedlocales --
#
# Get or change the list of currently loaded default locales
@@ -442,7 +510,7 @@ proc msgcat::mcloadedlocales {subcommand} {
# Results:
# Empty string, if not stated differently for the subcommand
-proc msgcat::mcpackagelocale {subcommand {locale ""}} {
+proc msgcat::mcpackagelocale {subcommand args} {
# todo: implement using an ensemble
variable Loclist
variable LoadedLocales
@@ -450,27 +518,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
variable PackageConfig
# Check option
# check if required item is exactly provided
- if {[llength [info level 0]] == 2} {
- # locale not given
- unset locale
- } else {
- # locale given
- if {$subcommand in
- {"get" "isset" "unset" "preferences" "loaded" "clear"} } {
- return -code error "wrong # args: should be\
- \"[lrange [info level 0] 0 1]\""
- }
- set locale [string tolower $locale]
+ if { [llength $args] > 0
+ && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1]\""
}
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
switch -exact -- $subcommand {
get { return [lindex [PackagePreferences $ns] 0] }
- preferences { return [PackagePreferences $ns] }
loaded { return [PackageLocales $ns] }
- present { return [expr {$locale in [PackageLocales $ns]} ]}
+ present {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] locale\""
+ }
+ return [expr {[string tolower [lindex $args 0]]
+ in [PackageLocales $ns]} ]
+ }
isset { return [dict exists $PackageConfig loclist $ns] }
- set { # set a package locale or add a package locale
+ set - preferences {
+ # set a package locale or add a package locale
+ set fSet [expr {$subcommand eq "set"}]
+
+ # Check parameter
+ if {$fSet && 1 < [llength $args] } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] ?locale?\""
+ }
+
+ # > Return preferences if no parameter
+ if {!$fSet && 0 == [llength $args] } {
+ return [PackagePreferences $ns]
+ }
# Copy the default locale if no package locale set so far
if {![dict exists $PackageConfig loclist $ns]} {
@@ -478,25 +558,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
dict set PackageConfig loadedlocales $ns $LoadedLocales
}
- # Check if changed
- set loclist [dict get $PackageConfig loclist $ns]
- if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
- return [lindex $loclist 0]
+ # No argument for set: return current package locale
+ # The difference to no argument and subcommand "preferences" is,
+ # that "preferences" does not set the package locale property.
+ # This case is processed above, so no check for fSet here
+ if { 0 == [llength $args] } {
+ return [lindex [dict get $PackageConfig loclist $ns] 0]
+ }
+
+ # Get new loclist
+ if {$fSet} {
+ set loclist [mcutil getpreferences [lindex $args 0]]
+ } else {
+ set loclist $args
+ }
+
+ # Check if not changed to return imediately
+ if { [ListEqualString $loclist\
+ [dict get $PackageConfig loclist $ns]] } {
+ if {$fSet} {
+ return [lindex $loclist 0]
+ }
+ return $loclist
}
# Change loclist
- set loclist [GetPreferences $locale]
- set locale [lindex $loclist 0]
dict set PackageConfig loclist $ns $loclist
# load eventual missing locales
set loadedLocales [dict get $PackageConfig loadedlocales $ns]
- if {$locale in $loadedLocales} { return $locale }
set loadLocales [ListComplement $loadedLocales $loclist]
dict set PackageConfig loadedlocales $ns\
[concat $loadedLocales $loadLocales]
Load $ns $loadLocales
- return $locale
+ if {$fSet} {
+ return [lindex $loclist 0]
+ }
+ return $loclist
}
clear { # Remove all locales not contained in Loclist
if {![dict exists $PackageConfig loclist $ns]} {
@@ -551,7 +649,7 @@ proc msgcat::mcforgetpackage {} {
# todo: this may be implemented using an ensemble
variable PackageConfig
variable Msgs
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
# Remove MC items
dict unset Msgs $ns
# Remove config items
@@ -561,6 +659,15 @@ proc msgcat::mcforgetpackage {} {
return
}
+# msgcat::mcgetmynamespace --
+#
+# Return the package namespace of the caller
+# This consideres to be called from a class or object.
+
+proc msgcat::mcpackagenamespaceget {} {
+ return [PackageNamespaceGet]
+}
+
# msgcat::mcpackageconfig --
#
# Get or modify the per caller namespace (e.g. packages) config options.
@@ -616,7 +723,7 @@ proc msgcat::mcforgetpackage {} {
proc msgcat::mcpackageconfig {subcommand option {value ""}} {
variable PackageConfig
# get namespace
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
@@ -756,8 +863,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
- return [uplevel 1 [list\
- [namespace origin mcpackageconfig] set mcfolder $langdir]]
+ tailcall mcpackageconfig set mcfolder $langdir
}
# msgcat::LoadAll --
@@ -923,7 +1029,7 @@ proc msgcat::mcset {locale src {dest ""}} {
set dest $src
}
- set ns [uplevel 1 [list ::namespace current]]
+ set ns [PackageNamespaceGet]
set locale [string tolower $locale]
@@ -951,7 +1057,7 @@ proc msgcat::mcflset {src {dest ""}} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
- return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
+ tailcall mcset $FileLocale $src $dest
}
# msgcat::mcmset --
@@ -975,7 +1081,7 @@ proc msgcat::mcmset {locale pairs} {
}
set locale [string tolower $locale]
- set ns [uplevel 1 [list ::namespace current]]
+ set ns [PackageNamespaceGet]
foreach {src dest} $pairs {
dict set Msgs $ns $locale $src $dest
@@ -1002,7 +1108,7 @@ proc msgcat::mcflmset {pairs} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
- return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
+ tailcall mcmset $FileLocale $pairs
}
# msgcat::mcunknown --
@@ -1024,7 +1130,7 @@ proc msgcat::mcflmset {pairs} {
# Returns the translated value.
proc msgcat::mcunknown {args} {
- return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
+ tailcall DefaultUnknown {*}$args
}
# msgcat::DefaultUnknown --
@@ -1067,8 +1173,9 @@ proc msgcat::DefaultUnknown {locale src args} {
proc msgcat::mcmax {args} {
set max 0
+ set ns [PackageNamespaceGet]
foreach string $args {
- set translated [uplevel 1 [list [namespace origin mc] $string]]
+ set translated [uplevel 1 [list [namespace origin mcn] $ns $string]]
set len [string length $translated]
if {$len>$max} {
set max $len
@@ -1079,7 +1186,7 @@ proc msgcat::mcmax {args} {
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
-proc msgcat::ConvertLocale {value} {
+proc msgcat::mcutil::ConvertLocale {value} {
# Assume $value is of form: $language[_$territory][.$codeset][@modifier]
# Convert to form: $language[_$territory][_$modifier]
#
@@ -1106,8 +1213,40 @@ proc msgcat::ConvertLocale {value} {
return $ret
}
+# helper function to find package namespace of stack-frame -2
+# There are 4 possibilities:
+# - called from a proc
+# - called within a class definition script
+# - called from an class defined oo object
+# - called from a classless oo object
+proc ::msgcat::PackageNamespaceGet {} {
+ uplevel 2 {
+ # Check self namespace to determine environment
+ switch -exact -- [namespace which self] {
+ {::oo::define::self} {
+ # We are within a class definition
+ return [namespace qualifiers [self]]
+ }
+ {::oo::Helpers::self} {
+ # We are within an object
+ set Class [info object class [self]]
+ # Check for classless defined object
+ if {$Class eq {::oo::object}} {
+ return [namespace qualifiers [self]]
+ }
+ # Class defined object
+ return [namespace qualifiers $Class]
+ }
+ default {
+ # Not in object environment
+ return [namespace current]
+ }
+ }
+ }
+}
+
# Initialize the default locale
-proc msgcat::Init {} {
+proc msgcat::mcutil::getsystemlocale {} {
global env
#
@@ -1115,10 +1254,8 @@ proc msgcat::Init {} {
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists env($varName)] && ("" ne $env($varName))} {
- if {![catch {
- mclocale [ConvertLocale $env($varName)]
- }]} {
- return
+ if {![catch { ConvertLocale $env($varName) } locale]} {
+ return $locale
}
}
}
@@ -1126,10 +1263,8 @@ proc msgcat::Init {} {
# On Darwin, fallback to current CFLocale identifier if available.
#
if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
- if {![catch {
- mclocale [ConvertLocale $::tcl::mac::locale]
- }]} {
- return
+ if {![catch { ConvertLocale $::tcl::mac::locale } locale]} {
+ return $locale
}
}
#
@@ -1138,8 +1273,7 @@ proc msgcat::Init {} {
#
if {([info sharedlibextension] ne ".dll")
|| [catch {package require registry}]} {
- mclocale C
- return
+ return C
}
#
# On Windows or Cygwin, try to set locale depending on registry
@@ -1148,7 +1282,7 @@ proc msgcat::Init {} {
# On Vista and later:
# HCU/Control Panel/Desktop : PreferredUILanguages is for language packs,
- # HCU/Control Pannel/International : localName is the default locale.
+ # HCU/Control Panel/International : localName is the default locale.
#
# They contain the local string as RFC5646, composed of:
# [a-z]{2,3} : language
@@ -1170,8 +1304,8 @@ proc msgcat::Init {} {
if {[dict exists $modifierDict $script]} {
append locale @ [dict get $modifierDict $script]
}
- if {![catch {mclocale [ConvertLocale $locale]}]} {
- return
+ if {![catch {ConvertLocale $locale} locale]} {
+ return $locale
}
}
}
@@ -1180,13 +1314,12 @@ proc msgcat::Init {} {
if {[catch {
set locale [registry get $key "locale"]
}]} {
- mclocale C
- return
+ return C
}
#
# Keep trying to match against smaller and smaller suffixes
- # of the registry value, since the latter hexadigits appear
- # to determine general language and earlier hexadigits determine
+ # of the registry value, since the latter hexdigits appear
+ # to determine general language and earlier hexdigits determine
# more precise information, such as territory. For example,
# 0409 - English - United States
# 0809 - English - United Kingdom
@@ -1196,15 +1329,15 @@ proc msgcat::Init {} {
set locale [string tolower $locale]
while {[string length $locale]} {
if {![catch {
- mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
- }]} {
- return
+ ConvertLocale [dict get $WinRegToISO639 $locale]
+ } localeOut]} {
+ return $localeOut
}
set locale [string range $locale 1 end]
}
#
# No translation known. Fall back on "C" locale
#
- mclocale C
+ return C
}
-msgcat::Init
+msgcat::mclocale [msgcat::mcutil getsystemlocale]
diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl
index 72c5dc0..18bd71b 100644
--- a/library/msgcat/pkgIndex.tcl
+++ b/library/msgcat/pkgIndex.tcl
@@ -1,2 +1,2 @@
-if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
+package ifneeded msgcat 1.7.1 [list source [file join $dir msgcat.tcl]]
diff --git a/library/msgs/ar.msg b/library/msgs/ar.msg
index 257157f..2d403ec 100644
--- a/library/msgs/ar.msg
+++ b/library/msgs/ar.msg
@@ -1,53 +1,53 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ar DAYS_OF_WEEK_ABBREV [list \
- "\u062d"\
- "\u0646"\
- "\u062b"\
- "\u0631"\
- "\u062e"\
- "\u062c"\
- "\u0633"]
+ "ح"\
+ "ن"\
+ "ث"\
+ "ر"\
+ "خ"\
+ "ج"\
+ "س"]
::msgcat::mcset ar DAYS_OF_WEEK_FULL [list \
- "\u0627\u0644\u0623\u062d\u062f"\
- "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
- "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
- "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
- "\u0627\u0644\u062e\u0645\u064a\u0633"\
- "\u0627\u0644\u062c\u0645\u0639\u0629"\
- "\u0627\u0644\u0633\u0628\u062a"]
+ "الأحد"\
+ "الاثنين"\
+ "الثلاثاء"\
+ "الأربعاء"\
+ "الخميس"\
+ "الجمعة"\
+ "السبت"]
::msgcat::mcset ar MONTHS_ABBREV [list \
- "\u064a\u0646\u0627"\
- "\u0641\u0628\u0631"\
- "\u0645\u0627\u0631"\
- "\u0623\u0628\u0631"\
- "\u0645\u0627\u064a"\
- "\u064a\u0648\u0646"\
- "\u064a\u0648\u0644"\
- "\u0623\u063a\u0633"\
- "\u0633\u0628\u062a"\
- "\u0623\u0643\u062a"\
- "\u0646\u0648\u0641"\
- "\u062f\u064a\u0633"\
+ "ينا"\
+ "فبر"\
+ "مار"\
+ "أبر"\
+ "ماي"\
+ "يون"\
+ "يول"\
+ "أغس"\
+ "سبت"\
+ "أكت"\
+ "نوف"\
+ "ديس"\
""]
::msgcat::mcset ar MONTHS_FULL [list \
- "\u064a\u0646\u0627\u064a\u0631"\
- "\u0641\u0628\u0631\u0627\u064a\u0631"\
- "\u0645\u0627\u0631\u0633"\
- "\u0623\u0628\u0631\u064a\u0644"\
- "\u0645\u0627\u064a\u0648"\
- "\u064a\u0648\u0646\u064a\u0648"\
- "\u064a\u0648\u0644\u064a\u0648"\
- "\u0623\u063a\u0633\u0637\u0633"\
- "\u0633\u0628\u062a\u0645\u0628\u0631"\
- "\u0623\u0643\u062a\u0648\u0628\u0631"\
- "\u0646\u0648\u0641\u0645\u0628\u0631"\
- "\u062f\u064a\u0633\u0645\u0628\u0631"\
+ "يناير"\
+ "فبراير"\
+ "مارس"\
+ "أبريل"\
+ "مايو"\
+ "يونيو"\
+ "يوليو"\
+ "أغسطس"\
+ "سبتمبر"\
+ "أكتوبر"\
+ "نوفمبر"\
+ "ديسمبر"\
""]
- ::msgcat::mcset ar BCE "\u0642.\u0645"
- ::msgcat::mcset ar CE "\u0645"
- ::msgcat::mcset ar AM "\u0635"
- ::msgcat::mcset ar PM "\u0645"
+ ::msgcat::mcset ar BCE "ق.م"
+ ::msgcat::mcset ar CE "م"
+ ::msgcat::mcset ar AM "ص"
+ ::msgcat::mcset ar PM "م"
::msgcat::mcset ar DATE_FORMAT "%d/%m/%Y"
::msgcat::mcset ar TIME_FORMAT_12 "%I:%M:%S %P"
::msgcat::mcset ar DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
diff --git a/library/msgs/ar_jo.msg b/library/msgs/ar_jo.msg
index 0f5e269..9a9dda0 100644
--- a/library/msgs/ar_jo.msg
+++ b/library/msgs/ar_jo.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \
- "\u0627\u0644\u0623\u062d\u062f"\
- "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
- "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
- "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
- "\u0627\u0644\u062e\u0645\u064a\u0633"\
- "\u0627\u0644\u062c\u0645\u0639\u0629"\
- "\u0627\u0644\u0633\u0628\u062a"]
+ "الأحد"\
+ "الاثنين"\
+ "الثلاثاء"\
+ "الأربعاء"\
+ "الخميس"\
+ "الجمعة"\
+ "السبت"]
::msgcat::mcset ar_JO MONTHS_ABBREV [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631"\
- "\u062d\u0632\u064a\u0631\u0627\u0646"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نوار"\
+ "حزيران"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
::msgcat::mcset ar_JO MONTHS_FULL [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631"\
- "\u062d\u0632\u064a\u0631\u0627\u0646"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نوار"\
+ "حزيران"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
}
diff --git a/library/msgs/ar_lb.msg b/library/msgs/ar_lb.msg
index e62acd3..c23aa2c 100644
--- a/library/msgs/ar_lb.msg
+++ b/library/msgs/ar_lb.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \
- "\u0627\u0644\u0623\u062d\u062f"\
- "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
- "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
- "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
- "\u0627\u0644\u062e\u0645\u064a\u0633"\
- "\u0627\u0644\u062c\u0645\u0639\u0629"\
- "\u0627\u0644\u0633\u0628\u062a"]
+ "الأحد"\
+ "الاثنين"\
+ "الثلاثاء"\
+ "الأربعاء"\
+ "الخميس"\
+ "الجمعة"\
+ "السبت"]
::msgcat::mcset ar_LB MONTHS_ABBREV [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631"\
- "\u062d\u0632\u064a\u0631\u0627\u0646"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نوار"\
+ "حزيران"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
::msgcat::mcset ar_LB MONTHS_FULL [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631"\
- "\u062d\u0632\u064a\u0631\u0627\u0646"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نوار"\
+ "حزيران"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
}
diff --git a/library/msgs/ar_sy.msg b/library/msgs/ar_sy.msg
index d5e1c87..f0daec0 100644
--- a/library/msgs/ar_sy.msg
+++ b/library/msgs/ar_sy.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \
- "\u0627\u0644\u0623\u062d\u062f"\
- "\u0627\u0644\u0627\u062b\u0646\u064a\u0646"\
- "\u0627\u0644\u062b\u0644\u0627\u062b\u0627\u0621"\
- "\u0627\u0644\u0623\u0631\u0628\u0639\u0627\u0621"\
- "\u0627\u0644\u062e\u0645\u064a\u0633"\
- "\u0627\u0644\u062c\u0645\u0639\u0629"\
- "\u0627\u0644\u0633\u0628\u062a"]
+ "الأحد"\
+ "الاثنين"\
+ "الثلاثاء"\
+ "الأربعاء"\
+ "الخميس"\
+ "الجمعة"\
+ "السبت"]
::msgcat::mcset ar_SY MONTHS_ABBREV [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631"\
- "\u062d\u0632\u064a\u0631\u0627\u0646"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نوار"\
+ "حزيران"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
::msgcat::mcset ar_SY MONTHS_FULL [list \
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0634\u0628\u0627\u0637"\
- "\u0622\u0630\u0627\u0631"\
- "\u0646\u064a\u0633\u0627\u0646"\
- "\u0646\u0648\u0627\u0631\u0627\u0646"\
- "\u062d\u0632\u064a\u0631"\
- "\u062a\u0645\u0648\u0632"\
- "\u0622\u0628"\
- "\u0623\u064a\u0644\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u0623\u0648\u0644"\
- "\u062a\u0634\u0631\u064a\u0646 \u0627\u0644\u062b\u0627\u0646\u064a"\
- "\u0643\u0627\u0646\u0648\u0646 \u0627\u0644\u0623\u0648\u0644"\
+ "كانون الثاني"\
+ "شباط"\
+ "آذار"\
+ "نيسان"\
+ "نواران"\
+ "حزير"\
+ "تموز"\
+ "آب"\
+ "أيلول"\
+ "تشرين الأول"\
+ "تشرين الثاني"\
+ "كانون الأول"\
""]
}
diff --git a/library/msgs/be.msg b/library/msgs/be.msg
index 379a1d7..a0aceed 100644
--- a/library/msgs/be.msg
+++ b/library/msgs/be.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset be DAYS_OF_WEEK_ABBREV [list \
- "\u043d\u0434"\
- "\u043f\u043d"\
- "\u0430\u0442"\
- "\u0441\u0440"\
- "\u0447\u0446"\
- "\u043f\u0442"\
- "\u0441\u0431"]
+ "нд"\
+ "пн"\
+ "ат"\
+ "ср"\
+ "чц"\
+ "пт"\
+ "сб"]
::msgcat::mcset be DAYS_OF_WEEK_FULL [list \
- "\u043d\u044f\u0434\u0437\u0435\u043b\u044f"\
- "\u043f\u0430\u043d\u044f\u0434\u0437\u0435\u043b\u0430\u043a"\
- "\u0430\u045e\u0442\u043e\u0440\u0430\u043a"\
- "\u0441\u0435\u0440\u0430\u0434\u0430"\
- "\u0447\u0430\u0446\u0432\u0435\u0440"\
- "\u043f\u044f\u0442\u043d\u0456\u0446\u0430"\
- "\u0441\u0443\u0431\u043e\u0442\u0430"]
+ "нядзеля"\
+ "панядзелак"\
+ "аўторак"\
+ "серада"\
+ "чацвер"\
+ "пятніца"\
+ "субота"]
::msgcat::mcset be MONTHS_ABBREV [list \
- "\u0441\u0442\u0434"\
- "\u043b\u044e\u0442"\
- "\u0441\u043a\u0432"\
- "\u043a\u0440\u0441"\
- "\u043c\u0430\u0439"\
- "\u0447\u0440\u0432"\
- "\u043b\u043f\u043d"\
- "\u0436\u043d\u0432"\
- "\u0432\u0440\u0441"\
- "\u043a\u0441\u0442"\
- "\u043b\u0441\u0442"\
- "\u0441\u043d\u0436"\
+ "стд"\
+ "лют"\
+ "скв"\
+ "крс"\
+ "май"\
+ "чрв"\
+ "лпн"\
+ "жнв"\
+ "врс"\
+ "кст"\
+ "лст"\
+ "снж"\
""]
::msgcat::mcset be MONTHS_FULL [list \
- "\u0441\u0442\u0443\u0434\u0437\u0435\u043d\u044f"\
- "\u043b\u044e\u0442\u0430\u0433\u0430"\
- "\u0441\u0430\u043a\u0430\u0432\u0456\u043a\u0430"\
- "\u043a\u0440\u0430\u0441\u0430\u0432\u0456\u043a\u0430"\
- "\u043c\u0430\u044f"\
- "\u0447\u0440\u0432\u0435\u043d\u044f"\
- "\u043b\u0456\u043f\u0435\u043d\u044f"\
- "\u0436\u043d\u0456\u045e\u043d\u044f"\
- "\u0432\u0435\u0440\u0430\u0441\u043d\u044f"\
- "\u043a\u0430\u0441\u0442\u0440\u044b\u0447\u043d\u0456\u043a\u0430"\
- "\u043b\u0438\u0441\u0442\u0430\u043f\u0430\u0434\u0430"\
- "\u0441\u043d\u0435\u0436\u043d\u044f"\
+ "студзеня"\
+ "лютага"\
+ "сакавіка"\
+ "красавіка"\
+ "мая"\
+ "чрвеня"\
+ "ліпеня"\
+ "жніўня"\
+ "верасня"\
+ "кастрычніка"\
+ "листапада"\
+ "снежня"\
""]
- ::msgcat::mcset be BCE "\u0434\u0430 \u043d.\u0435."
- ::msgcat::mcset be CE "\u043d.\u0435."
+ ::msgcat::mcset be BCE "да н.е."
+ ::msgcat::mcset be CE "н.е."
::msgcat::mcset be DATE_FORMAT "%e.%m.%Y"
::msgcat::mcset be TIME_FORMAT "%k.%M.%S"
::msgcat::mcset be DATE_TIME_FORMAT "%e.%m.%Y %k.%M.%S %z"
diff --git a/library/msgs/bg.msg b/library/msgs/bg.msg
index ff17759..2e7730d 100644
--- a/library/msgs/bg.msg
+++ b/library/msgs/bg.msg
@@ -1,21 +1,21 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset bg DAYS_OF_WEEK_ABBREV [list \
- "\u041d\u0434"\
- "\u041f\u043d"\
- "\u0412\u0442"\
- "\u0421\u0440"\
- "\u0427\u0442"\
- "\u041f\u0442"\
- "\u0421\u0431"]
+ "Нд"\
+ "Пн"\
+ "Вт"\
+ "Ср"\
+ "Чт"\
+ "Пт"\
+ "Сб"]
::msgcat::mcset bg DAYS_OF_WEEK_FULL [list \
- "\u041d\u0435\u0434\u0435\u043b\u044f"\
- "\u041f\u043e\u043d\u0435\u0434\u0435\u043b\u043d\u0438\u043a"\
- "\u0412\u0442\u043e\u0440\u043d\u0438\u043a"\
- "\u0421\u0440\u044f\u0434\u0430"\
- "\u0427\u0435\u0442\u0432\u044a\u0440\u0442\u044a\u043a"\
- "\u041f\u0435\u0442\u044a\u043a"\
- "\u0421\u044a\u0431\u043e\u0442\u0430"]
+ "Неделя"\
+ "Понеделник"\
+ "Вторник"\
+ "Сряда"\
+ "Четвъртък"\
+ "Петък"\
+ "Събота"]
::msgcat::mcset bg MONTHS_ABBREV [list \
"I"\
"II"\
@@ -31,21 +31,21 @@ namespace eval ::tcl::clock {
"XII"\
""]
::msgcat::mcset bg MONTHS_FULL [list \
- "\u042f\u043d\u0443\u0430\u0440\u0438"\
- "\u0424\u0435\u0432\u0440\u0443\u0430\u0440\u0438"\
- "\u041c\u0430\u0440\u0442"\
- "\u0410\u043f\u0440\u0438\u043b"\
- "\u041c\u0430\u0439"\
- "\u042e\u043d\u0438"\
- "\u042e\u043b\u0438"\
- "\u0410\u0432\u0433\u0443\u0441\u0442"\
- "\u0421\u0435\u043f\u0442\u0435\u043c\u0432\u0440\u0438"\
- "\u041e\u043a\u0442\u043e\u043c\u0432\u0440\u0438"\
- "\u041d\u043e\u0435\u043c\u0432\u0440\u0438"\
- "\u0414\u0435\u043a\u0435\u043c\u0432\u0440\u0438"\
+ "Януари"\
+ "Февруари"\
+ "Март"\
+ "Април"\
+ "Май"\
+ "Юни"\
+ "Юли"\
+ "Август"\
+ "Септември"\
+ "Октомври"\
+ "Ноември"\
+ "Декември"\
""]
- ::msgcat::mcset bg BCE "\u043f\u0440.\u043d.\u0435."
- ::msgcat::mcset bg CE "\u043d.\u0435."
+ ::msgcat::mcset bg BCE "пр.н.е."
+ ::msgcat::mcset bg CE "н.е."
::msgcat::mcset bg DATE_FORMAT "%Y-%m-%e"
::msgcat::mcset bg TIME_FORMAT "%k:%M:%S"
::msgcat::mcset bg DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z"
diff --git a/library/msgs/bn.msg b/library/msgs/bn.msg
index 664b9d8..a0aef13 100644
--- a/library/msgs/bn.msg
+++ b/library/msgs/bn.msg
@@ -1,49 +1,49 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset bn DAYS_OF_WEEK_ABBREV [list \
- "\u09b0\u09ac\u09bf"\
- "\u09b8\u09cb\u09ae"\
- "\u09ae\u0999\u0997\u09b2"\
- "\u09ac\u09c1\u09a7"\
- "\u09ac\u09c3\u09b9\u09b8\u09cd\u09aa\u09a4\u09bf"\
- "\u09b6\u09c1\u0995\u09cd\u09b0"\
- "\u09b6\u09a8\u09bf"]
+ "রবি"\
+ "সোম"\
+ "মঙগল"\
+ "বুধ"\
+ "বৃহস্পতি"\
+ "শুক্র"\
+ "শনি"]
::msgcat::mcset bn DAYS_OF_WEEK_FULL [list \
- "\u09b0\u09ac\u09bf\u09ac\u09be\u09b0"\
- "\u09b8\u09cb\u09ae\u09ac\u09be\u09b0"\
- "\u09ae\u0999\u0997\u09b2\u09ac\u09be\u09b0"\
- "\u09ac\u09c1\u09a7\u09ac\u09be\u09b0"\
- "\u09ac\u09c3\u09b9\u09b8\u09cd\u09aa\u09a4\u09bf\u09ac\u09be\u09b0"\
- "\u09b6\u09c1\u0995\u09cd\u09b0\u09ac\u09be\u09b0"\
- "\u09b6\u09a8\u09bf\u09ac\u09be\u09b0"]
+ "রবিবার"\
+ "সোমবার"\
+ "মঙগলবার"\
+ "বুধবার"\
+ "বৃহস্পতিবার"\
+ "শুক্রবার"\
+ "শনিবার"]
::msgcat::mcset bn MONTHS_ABBREV [list \
- "\u099c\u09be\u09a8\u09c1\u09df\u09be\u09b0\u09c0"\
- "\u09ab\u09c7\u09ac\u09cd\u09b0\u09c1\u09df\u09be\u09b0\u09c0"\
- "\u09ae\u09be\u09b0\u09cd\u099a"\
- "\u098f\u09aa\u09cd\u09b0\u09bf\u09b2"\
- "\u09ae\u09c7"\
- "\u099c\u09c1\u09a8"\
- "\u099c\u09c1\u09b2\u09be\u0987"\
- "\u0986\u0997\u09b8\u09cd\u099f"\
- "\u09b8\u09c7\u09aa\u09cd\u099f\u09c7\u09ae\u09cd\u09ac\u09b0"\
- "\u0985\u0995\u09cd\u099f\u09cb\u09ac\u09b0"\
- "\u09a8\u09ad\u09c7\u09ae\u09cd\u09ac\u09b0"\
- "\u09a1\u09bf\u09b8\u09c7\u09ae\u09cd\u09ac\u09b0"\
+ "জানুয়ারী"\
+ "ফেব্রুয়ারী"\
+ "মার্চ"\
+ "এপ্রিল"\
+ "মে"\
+ "জুন"\
+ "জুলাই"\
+ "আগস্ট"\
+ "সেপ্টেম্বর"\
+ "অক্টোবর"\
+ "নভেম্বর"\
+ "ডিসেম্বর"\
""]
::msgcat::mcset bn MONTHS_FULL [list \
- "\u099c\u09be\u09a8\u09c1\u09df\u09be\u09b0\u09c0"\
- "\u09ab\u09c7\u09ac\u09cd\u09b0\u09c1\u09df\u09be\u09b0\u09c0"\
- "\u09ae\u09be\u09b0\u09cd\u099a"\
- "\u098f\u09aa\u09cd\u09b0\u09bf\u09b2"\
- "\u09ae\u09c7"\
- "\u099c\u09c1\u09a8"\
- "\u099c\u09c1\u09b2\u09be\u0987"\
- "\u0986\u0997\u09b8\u09cd\u099f"\
- "\u09b8\u09c7\u09aa\u09cd\u099f\u09c7\u09ae\u09cd\u09ac\u09b0"\
- "\u0985\u0995\u09cd\u099f\u09cb\u09ac\u09b0"\
- "\u09a8\u09ad\u09c7\u09ae\u09cd\u09ac\u09b0"\
- "\u09a1\u09bf\u09b8\u09c7\u09ae\u09cd\u09ac\u09b0"\
+ "জানুয়ারী"\
+ "ফেব্রুয়ারী"\
+ "মার্চ"\
+ "এপ্রিল"\
+ "মে"\
+ "জুন"\
+ "জুলাই"\
+ "আগস্ট"\
+ "সেপ্টেম্বর"\
+ "অক্টোবর"\
+ "নভেম্বর"\
+ "ডিসেম্বর"\
""]
- ::msgcat::mcset bn AM "\u09aa\u09c2\u09b0\u09cd\u09ac\u09be\u09b9\u09cd\u09a3"
- ::msgcat::mcset bn PM "\u0985\u09aa\u09b0\u09be\u09b9\u09cd\u09a3"
+ ::msgcat::mcset bn AM "পূর্বাহ্ণ"
+ ::msgcat::mcset bn PM "অপরাহ্ণ"
}
diff --git a/library/msgs/ca.msg b/library/msgs/ca.msg
index 36c9772..272f682 100644
--- a/library/msgs/ca.msg
+++ b/library/msgs/ca.msg
@@ -19,7 +19,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset ca MONTHS_ABBREV [list \
"gen."\
"feb."\
- "mar\u00e7"\
+ "març"\
"abr."\
"maig"\
"juny"\
@@ -33,7 +33,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset ca MONTHS_FULL [list \
"gener"\
"febrer"\
- "mar\u00e7"\
+ "març"\
"abril"\
"maig"\
"juny"\
diff --git a/library/msgs/cs.msg b/library/msgs/cs.msg
index 8db8bdd..4673cd4 100644
--- a/library/msgs/cs.msg
+++ b/library/msgs/cs.msg
@@ -3,18 +3,18 @@ namespace eval ::tcl::clock {
::msgcat::mcset cs DAYS_OF_WEEK_ABBREV [list \
"Ne"\
"Po"\
- "\u00dat"\
+ "Út"\
"St"\
- "\u010ct"\
- "P\u00e1"\
+ "Čt"\
+ "Pá"\
"So"]
::msgcat::mcset cs DAYS_OF_WEEK_FULL [list \
- "Ned\u011ble"\
- "Pond\u011bl\u00ed"\
- "\u00dater\u00fd"\
- "St\u0159eda"\
- "\u010ctvrtek"\
- "P\u00e1tek"\
+ "Neděle"\
+ "Pondělí"\
+ "Úterý"\
+ "Středa"\
+ "Čtvrtek"\
+ "Pátek"\
"Sobota"]
::msgcat::mcset cs MONTHS_ABBREV [list \
"I"\
@@ -32,19 +32,19 @@ namespace eval ::tcl::clock {
""]
::msgcat::mcset cs MONTHS_FULL [list \
"leden"\
- "\u00fanor"\
- "b\u0159ezen"\
+ "únor"\
+ "březen"\
"duben"\
- "kv\u011bten"\
- "\u010derven"\
- "\u010dervenec"\
+ "květen"\
+ "červen"\
+ "červenec"\
"srpen"\
- "z\u00e1\u0159\u00ed"\
- "\u0159\u00edjen"\
+ "září"\
+ "říjen"\
"listopad"\
"prosinec"\
""]
- ::msgcat::mcset cs BCE "p\u0159.Kr."
+ ::msgcat::mcset cs BCE "př.Kr."
::msgcat::mcset cs CE "po Kr."
::msgcat::mcset cs AM "dop."
::msgcat::mcset cs PM "odp."
diff --git a/library/msgs/da.msg b/library/msgs/da.msg
index e4fec7f..abed3c5 100644
--- a/library/msgs/da.msg
+++ b/library/msgs/da.msg
@@ -1,21 +1,21 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset da DAYS_OF_WEEK_ABBREV [list \
- "s\u00f8"\
+ "sø"\
"ma"\
"ti"\
"on"\
"to"\
"fr"\
- "l\u00f8"]
+ "lø"]
::msgcat::mcset da DAYS_OF_WEEK_FULL [list \
- "s\u00f8ndag"\
+ "søndag"\
"mandag"\
"tirsdag"\
"onsdag"\
"torsdag"\
"fredag"\
- "l\u00f8rdag"]
+ "lørdag"]
::msgcat::mcset da MONTHS_ABBREV [list \
"jan"\
"feb"\
diff --git a/library/msgs/de.msg b/library/msgs/de.msg
index 9eb3145..0bb7399 100644
--- a/library/msgs/de.msg
+++ b/library/msgs/de.msg
@@ -33,7 +33,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset de MONTHS_FULL [list \
"Januar"\
"Februar"\
- "M\u00e4rz"\
+ "März"\
"April"\
"Mai"\
"Juni"\
diff --git a/library/msgs/de_at.msg b/library/msgs/de_at.msg
index 61bc266..1a0a0f5 100644
--- a/library/msgs/de_at.msg
+++ b/library/msgs/de_at.msg
@@ -1,9 +1,9 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset de_AT MONTHS_ABBREV [list \
- "J\u00e4n"\
+ "Jän"\
"Feb"\
- "M\u00e4r"\
+ "Mär"\
"Apr"\
"Mai"\
"Jun"\
@@ -15,9 +15,9 @@ namespace eval ::tcl::clock {
"Dez"\
""]
::msgcat::mcset de_AT MONTHS_FULL [list \
- "J\u00e4nner"\
+ "Jänner"\
"Februar"\
- "M\u00e4rz"\
+ "März"\
"April"\
"Mai"\
"Juni"\
diff --git a/library/msgs/de_be.msg b/library/msgs/de_be.msg
index 3614763..04cf88c 100644
--- a/library/msgs/de_be.msg
+++ b/library/msgs/de_be.msg
@@ -19,7 +19,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset de_BE MONTHS_ABBREV [list \
"Jan"\
"Feb"\
- "M\u00e4r"\
+ "Mär"\
"Apr"\
"Mai"\
"Jun"\
@@ -33,7 +33,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset de_BE MONTHS_FULL [list \
"Januar"\
"Februar"\
- "M\u00e4rz"\
+ "März"\
"April"\
"Mai"\
"Juni"\
diff --git a/library/msgs/el.msg b/library/msgs/el.msg
index ac19f62..26bdfe9 100644
--- a/library/msgs/el.msg
+++ b/library/msgs/el.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset el DAYS_OF_WEEK_ABBREV [list \
- "\u039a\u03c5\u03c1"\
- "\u0394\u03b5\u03c5"\
- "\u03a4\u03c1\u03b9"\
- "\u03a4\u03b5\u03c4"\
- "\u03a0\u03b5\u03bc"\
- "\u03a0\u03b1\u03c1"\
- "\u03a3\u03b1\u03b2"]
+ "Κυρ"\
+ "Δευ"\
+ "Τρι"\
+ "Τετ"\
+ "Πεμ"\
+ "Παρ"\
+ "Σαβ"]
::msgcat::mcset el DAYS_OF_WEEK_FULL [list \
- "\u039a\u03c5\u03c1\u03b9\u03b1\u03ba\u03ae"\
- "\u0394\u03b5\u03c5\u03c4\u03ad\u03c1\u03b1"\
- "\u03a4\u03c1\u03af\u03c4\u03b7"\
- "\u03a4\u03b5\u03c4\u03ac\u03c1\u03c4\u03b7"\
- "\u03a0\u03ad\u03bc\u03c0\u03c4\u03b7"\
- "\u03a0\u03b1\u03c1\u03b1\u03c3\u03ba\u03b5\u03c5\u03ae"\
- "\u03a3\u03ac\u03b2\u03b2\u03b1\u03c4\u03bf"]
+ "Κυριακή"\
+ "Δευτέρα"\
+ "Τρίτη"\
+ "Τετάρτη"\
+ "Πέμπτη"\
+ "Παρασκευή"\
+ "Σάββατο"]
::msgcat::mcset el MONTHS_ABBREV [list \
- "\u0399\u03b1\u03bd"\
- "\u03a6\u03b5\u03b2"\
- "\u039c\u03b1\u03c1"\
- "\u0391\u03c0\u03c1"\
- "\u039c\u03b1\u03ca"\
- "\u0399\u03bf\u03c5\u03bd"\
- "\u0399\u03bf\u03c5\u03bb"\
- "\u0391\u03c5\u03b3"\
- "\u03a3\u03b5\u03c0"\
- "\u039f\u03ba\u03c4"\
- "\u039d\u03bf\u03b5"\
- "\u0394\u03b5\u03ba"\
+ "Ιαν"\
+ "Φεβ"\
+ "Μαρ"\
+ "Απρ"\
+ "Μαϊ"\
+ "Ιουν"\
+ "Ιουλ"\
+ "Αυγ"\
+ "Σεπ"\
+ "Οκτ"\
+ "Νοε"\
+ "Δεκ"\
""]
::msgcat::mcset el MONTHS_FULL [list \
- "\u0399\u03b1\u03bd\u03bf\u03c5\u03ac\u03c1\u03b9\u03bf\u03c2"\
- "\u03a6\u03b5\u03b2\u03c1\u03bf\u03c5\u03ac\u03c1\u03b9\u03bf\u03c2"\
- "\u039c\u03ac\u03c1\u03c4\u03b9\u03bf\u03c2"\
- "\u0391\u03c0\u03c1\u03af\u03bb\u03b9\u03bf\u03c2"\
- "\u039c\u03ac\u03ca\u03bf\u03c2"\
- "\u0399\u03bf\u03cd\u03bd\u03b9\u03bf\u03c2"\
- "\u0399\u03bf\u03cd\u03bb\u03b9\u03bf\u03c2"\
- "\u0391\u03cd\u03b3\u03bf\u03c5\u03c3\u03c4\u03bf\u03c2"\
- "\u03a3\u03b5\u03c0\u03c4\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\
- "\u039f\u03ba\u03c4\u03ce\u03b2\u03c1\u03b9\u03bf\u03c2"\
- "\u039d\u03bf\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\
- "\u0394\u03b5\u03ba\u03ad\u03bc\u03b2\u03c1\u03b9\u03bf\u03c2"\
+ "Ιανουάριος"\
+ "Φεβρουάριος"\
+ "Μάρτιος"\
+ "Απρίλιος"\
+ "Μάϊος"\
+ "Ιούνιος"\
+ "Ιούλιος"\
+ "Αύγουστος"\
+ "Σεπτέμβριος"\
+ "Οκτώβριος"\
+ "Νοέμβριος"\
+ "Δεκέμβριος"\
""]
- ::msgcat::mcset el AM "\u03c0\u03bc"
- ::msgcat::mcset el PM "\u03bc\u03bc"
+ ::msgcat::mcset el AM "πμ"
+ ::msgcat::mcset el PM "μμ"
::msgcat::mcset el DATE_FORMAT "%e/%m/%Y"
::msgcat::mcset el TIME_FORMAT_12 "%l:%M:%S %P"
::msgcat::mcset el DATE_TIME_FORMAT "%e/%m/%Y %l:%M:%S %P %z"
diff --git a/library/msgs/eo.msg b/library/msgs/eo.msg
index 1d2a24f..b9b1500 100644
--- a/library/msgs/eo.msg
+++ b/library/msgs/eo.msg
@@ -5,15 +5,15 @@ namespace eval ::tcl::clock {
"lu"\
"ma"\
"me"\
- "\u0135a"\
+ "ĵa"\
"ve"\
"sa"]
::msgcat::mcset eo DAYS_OF_WEEK_FULL [list \
- "diman\u0109o"\
+ "dimanĉo"\
"lundo"\
"mardo"\
"merkredo"\
- "\u0135a\u016ddo"\
+ "ĵaŭdo"\
"vendredo"\
"sabato"]
::msgcat::mcset eo MONTHS_ABBREV [list \
@@ -24,7 +24,7 @@ namespace eval ::tcl::clock {
"maj"\
"jun"\
"jul"\
- "a\u016dg"\
+ "aŭg"\
"sep"\
"okt"\
"nov"\
@@ -38,7 +38,7 @@ namespace eval ::tcl::clock {
"majo"\
"junio"\
"julio"\
- "a\u016dgusto"\
+ "aŭgusto"\
"septembro"\
"oktobro"\
"novembro"\
diff --git a/library/msgs/es.msg b/library/msgs/es.msg
index a24f0a1..6090eab 100644
--- a/library/msgs/es.msg
+++ b/library/msgs/es.msg
@@ -4,18 +4,18 @@ namespace eval ::tcl::clock {
"dom"\
"lun"\
"mar"\
- "mi\u00e9"\
+ "mié"\
"jue"\
"vie"\
- "s\u00e1b"]
+ "sáb"]
::msgcat::mcset es DAYS_OF_WEEK_FULL [list \
"domingo"\
"lunes"\
"martes"\
- "mi\u00e9rcoles"\
+ "miércoles"\
"jueves"\
"viernes"\
- "s\u00e1bado"]
+ "sábado"]
::msgcat::mcset es MONTHS_ABBREV [list \
"ene"\
"feb"\
diff --git a/library/msgs/et.msg b/library/msgs/et.msg
index 8d32e9e..a782f9b 100644
--- a/library/msgs/et.msg
+++ b/library/msgs/et.msg
@@ -9,17 +9,17 @@ namespace eval ::tcl::clock {
"R"\
"L"]
::msgcat::mcset et DAYS_OF_WEEK_FULL [list \
- "p\u00fchap\u00e4ev"\
- "esmasp\u00e4ev"\
- "teisip\u00e4ev"\
- "kolmap\u00e4ev"\
- "neljap\u00e4ev"\
+ "pühapäev"\
+ "esmaspäev"\
+ "teisipäev"\
+ "kolmapäev"\
+ "neljapäev"\
"reede"\
- "laup\u00e4ev"]
+ "laupäev"]
::msgcat::mcset et MONTHS_ABBREV [list \
"Jaan"\
"Veebr"\
- "M\u00e4rts"\
+ "Märts"\
"Apr"\
"Mai"\
"Juuni"\
@@ -33,7 +33,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset et MONTHS_FULL [list \
"Jaanuar"\
"Veebruar"\
- "M\u00e4rts"\
+ "Märts"\
"Aprill"\
"Mai"\
"Juuni"\
diff --git a/library/msgs/fa.msg b/library/msgs/fa.msg
index 89b2f90..6166e28 100644
--- a/library/msgs/fa.msg
+++ b/library/msgs/fa.msg
@@ -1,47 +1,47 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset fa DAYS_OF_WEEK_ABBREV [list \
- "\u06cc\u2214"\
- "\u062f\u2214"\
- "\u0633\u2214"\
- "\u0686\u2214"\
- "\u067e\u2214"\
- "\u062c\u2214"\
- "\u0634\u2214"]
+ "ی∔"\
+ "د∔"\
+ "س∔"\
+ "چ∔"\
+ "پ∔"\
+ "ج∔"\
+ "ش∔"]
::msgcat::mcset fa DAYS_OF_WEEK_FULL [list \
- "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\
- "\u062f\u0648\u0634\u0646\u0628\u0647"\
- "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\
- "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\
- "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\
- "\u062c\u0645\u0639\u0647"\
- "\u0634\u0646\u0628\u0647"]
+ "یی‌شنبه"\
+ "دوشنبه"\
+ "سه‌شنبه"\
+ "چهارشنبه"\
+ "پنج‌شنبه"\
+ "جمعه"\
+ "شنبه"]
::msgcat::mcset fa MONTHS_ABBREV [list \
- "\u0698\u0627\u0646"\
- "\u0641\u0648\u0631"\
- "\u0645\u0627\u0631"\
- "\u0622\u0648\u0631"\
- "\u0645\u0640\u0647"\
- "\u0698\u0648\u0646"\
- "\u0698\u0648\u06cc"\
- "\u0627\u0648\u062a"\
- "\u0633\u067e\u062a"\
- "\u0627\u0643\u062a"\
- "\u0646\u0648\u0627"\
- "\u062f\u0633\u0627"\
+ "ژان"\
+ "فور"\
+ "مار"\
+ "آور"\
+ "مـه"\
+ "ژون"\
+ "ژوی"\
+ "اوت"\
+ "سپت"\
+ "اكت"\
+ "نوا"\
+ "دسا"\
""]
::msgcat::mcset fa MONTHS_FULL [list \
- "\u0698\u0627\u0646\u0648\u06cc\u0647"\
- "\u0641\u0648\u0631\u0648\u06cc\u0647"\
- "\u0645\u0627\u0631\u0633"\
- "\u0622\u0648\u0631\u06cc\u0644"\
- "\u0645\u0647"\
- "\u0698\u0648\u0626\u0646"\
- "\u0698\u0648\u0626\u06cc\u0647"\
- "\u0627\u0648\u062a"\
- "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\
- "\u0627\u0643\u062a\u0628\u0631"\
- "\u0646\u0648\u0627\u0645\u0628\u0631"\
- "\u062f\u0633\u0627\u0645\u0628\u0631"\
+ "ژانویه"\
+ "فورویه"\
+ "مارس"\
+ "آوریل"\
+ "مه"\
+ "ژوئن"\
+ "ژوئیه"\
+ "اوت"\
+ "سپتامبر"\
+ "اكتبر"\
+ "نوامبر"\
+ "دسامبر"\
""]
}
diff --git a/library/msgs/fa_in.msg b/library/msgs/fa_in.msg
index adc9e91..ce32f99 100644
--- a/library/msgs/fa_in.msg
+++ b/library/msgs/fa_in.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \
- "\u06cc\u2214"\
- "\u062f\u2214"\
- "\u0633\u2214"\
- "\u0686\u2214"\
- "\u067e\u2214"\
- "\u062c\u2214"\
- "\u0634\u2214"]
+ "ی∔"\
+ "د∔"\
+ "س∔"\
+ "چ∔"\
+ "پ∔"\
+ "ج∔"\
+ "ش∔"]
::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \
- "\u06cc\u06cc\u200c\u0634\u0646\u0628\u0647"\
- "\u062f\u0648\u0634\u0646\u0628\u0647"\
- "\u0633\u0647\u200c\u0634\u0646\u0628\u0647"\
- "\u0686\u0647\u0627\u0631\u0634\u0646\u0628\u0647"\
- "\u067e\u0646\u062c\u200c\u0634\u0646\u0628\u0647"\
- "\u062c\u0645\u0639\u0647"\
- "\u0634\u0646\u0628\u0647"]
+ "یی‌شنبه"\
+ "دوشنبه"\
+ "سه‌شنبه"\
+ "چهارشنبه"\
+ "پنج‌شنبه"\
+ "جمعه"\
+ "شنبه"]
::msgcat::mcset fa_IN MONTHS_ABBREV [list \
- "\u0698\u0627\u0646"\
- "\u0641\u0648\u0631"\
- "\u0645\u0627\u0631"\
- "\u0622\u0648\u0631"\
- "\u0645\u0640\u0647"\
- "\u0698\u0648\u0646"\
- "\u0698\u0648\u06cc"\
- "\u0627\u0648\u062a"\
- "\u0633\u067e\u062a"\
- "\u0627\u0643\u062a"\
- "\u0646\u0648\u0627"\
- "\u062f\u0633\u0627"\
+ "ژان"\
+ "فور"\
+ "مار"\
+ "آور"\
+ "مـه"\
+ "ژون"\
+ "ژوی"\
+ "اوت"\
+ "سپت"\
+ "اكت"\
+ "نوا"\
+ "دسا"\
""]
::msgcat::mcset fa_IN MONTHS_FULL [list \
- "\u0698\u0627\u0646\u0648\u06cc\u0647"\
- "\u0641\u0648\u0631\u0648\u06cc\u0647"\
- "\u0645\u0627\u0631\u0633"\
- "\u0622\u0648\u0631\u06cc\u0644"\
- "\u0645\u0647"\
- "\u0698\u0648\u0626\u0646"\
- "\u0698\u0648\u0626\u06cc\u0647"\
- "\u0627\u0648\u062a"\
- "\u0633\u067e\u062a\u0627\u0645\u0628\u0631"\
- "\u0627\u0643\u062a\u0628\u0631"\
- "\u0646\u0648\u0627\u0645\u0628\u0631"\
- "\u062f\u0633\u0627\u0645\u0628\u0631"\
+ "ژانویه"\
+ "فورویه"\
+ "مارس"\
+ "آوریل"\
+ "مه"\
+ "ژوئن"\
+ "ژوئیه"\
+ "اوت"\
+ "سپتامبر"\
+ "اكتبر"\
+ "نوامبر"\
+ "دسامبر"\
""]
- ::msgcat::mcset fa_IN AM "\u0635\u0628\u062d"
- ::msgcat::mcset fa_IN PM "\u0639\u0635\u0631"
+ ::msgcat::mcset fa_IN AM "صبح"
+ ::msgcat::mcset fa_IN PM "عصر"
::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y"
::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z"
::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z"
diff --git a/library/msgs/fa_ir.msg b/library/msgs/fa_ir.msg
index 597ce9d..9ce9284 100644
--- a/library/msgs/fa_ir.msg
+++ b/library/msgs/fa_ir.msg
@@ -1,9 +1,9 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
- ::msgcat::mcset fa_IR AM "\u0635\u0628\u062d"
- ::msgcat::mcset fa_IR PM "\u0639\u0635\u0631"
- ::msgcat::mcset fa_IR DATE_FORMAT "%d\u2044%m\u2044%Y"
+ ::msgcat::mcset fa_IR AM "صبح"
+ ::msgcat::mcset fa_IR PM "عصر"
+ ::msgcat::mcset fa_IR DATE_FORMAT "%d⁄%m⁄%Y"
::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H"
::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P"
- ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d\u2044%m\u2044%Y %S:%M:%H %z"
+ ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d⁄%m⁄%Y %S:%M:%H %z"
}
diff --git a/library/msgs/fi.msg b/library/msgs/fi.msg
index acabba0..69be367 100644
--- a/library/msgs/fi.msg
+++ b/library/msgs/fi.msg
@@ -22,8 +22,8 @@ namespace eval ::tcl::clock {
"maalis"\
"huhti"\
"touko"\
- "kes\u00e4"\
- "hein\u00e4"\
+ "kesä"\
+ "heinä"\
"elo"\
"syys"\
"loka"\
@@ -36,8 +36,8 @@ namespace eval ::tcl::clock {
"maaliskuu"\
"huhtikuu"\
"toukokuu"\
- "kes\u00e4kuu"\
- "hein\u00e4kuu"\
+ "kesäkuu"\
+ "heinäkuu"\
"elokuu"\
"syyskuu"\
"lokakuu"\
diff --git a/library/msgs/fo.msg b/library/msgs/fo.msg
index 4696e62..1f1794d 100644
--- a/library/msgs/fo.msg
+++ b/library/msgs/fo.msg
@@ -2,19 +2,19 @@
namespace eval ::tcl::clock {
::msgcat::mcset fo DAYS_OF_WEEK_ABBREV [list \
"sun"\
- "m\u00e1n"\
- "t\u00fds"\
+ "mán"\
+ "týs"\
"mik"\
- "h\u00f3s"\
- "fr\u00ed"\
+ "hós"\
+ "frí"\
"ley"]
::msgcat::mcset fo DAYS_OF_WEEK_FULL [list \
"sunnudagur"\
- "m\u00e1nadagur"\
- "t\u00fdsdagur"\
+ "mánadagur"\
+ "týsdagur"\
"mikudagur"\
- "h\u00f3sdagur"\
- "fr\u00edggjadagur"\
+ "hósdagur"\
+ "fríggjadagur"\
"leygardagur"]
::msgcat::mcset fo MONTHS_ABBREV [list \
"jan"\
@@ -34,7 +34,7 @@ namespace eval ::tcl::clock {
"januar"\
"februar"\
"mars"\
- "apr\u00edl"\
+ "apríl"\
"mai"\
"juni"\
"juli"\
diff --git a/library/msgs/fr.msg b/library/msgs/fr.msg
index 55b19bf..a274468 100644
--- a/library/msgs/fr.msg
+++ b/library/msgs/fr.msg
@@ -18,31 +18,31 @@ namespace eval ::tcl::clock {
"samedi"]
::msgcat::mcset fr MONTHS_ABBREV [list \
"janv."\
- "f\u00e9vr."\
+ "févr."\
"mars"\
"avr."\
"mai"\
"juin"\
"juil."\
- "ao\u00fbt"\
+ "août"\
"sept."\
"oct."\
"nov."\
- "d\u00e9c."\
+ "déc."\
""]
::msgcat::mcset fr MONTHS_FULL [list \
"janvier"\
- "f\u00e9vrier"\
+ "février"\
"mars"\
"avril"\
"mai"\
"juin"\
"juillet"\
- "ao\u00fbt"\
+ "août"\
"septembre"\
"octobre"\
"novembre"\
- "d\u00e9cembre"\
+ "décembre"\
""]
::msgcat::mcset fr BCE "av. J.-C."
::msgcat::mcset fr CE "ap. J.-C."
diff --git a/library/msgs/ga.msg b/library/msgs/ga.msg
index 6edf13a..056c9a0 100644
--- a/library/msgs/ga.msg
+++ b/library/msgs/ga.msg
@@ -3,45 +3,45 @@ namespace eval ::tcl::clock {
::msgcat::mcset ga DAYS_OF_WEEK_ABBREV [list \
"Domh"\
"Luan"\
- "M\u00e1irt"\
- "C\u00e9ad"\
- "D\u00e9ar"\
+ "Máirt"\
+ "Céad"\
+ "Déar"\
"Aoine"\
"Sath"]
::msgcat::mcset ga DAYS_OF_WEEK_FULL [list \
- "D\u00e9 Domhnaigh"\
- "D\u00e9 Luain"\
- "D\u00e9 M\u00e1irt"\
- "D\u00e9 C\u00e9adaoin"\
- "D\u00e9ardaoin"\
- "D\u00e9 hAoine"\
- "D\u00e9 Sathairn"]
+ "Dé Domhnaigh"\
+ "Dé Luain"\
+ "Dé Máirt"\
+ "Dé Céadaoin"\
+ "Déardaoin"\
+ "Dé hAoine"\
+ "Dé Sathairn"]
::msgcat::mcset ga MONTHS_ABBREV [list \
"Ean"\
"Feabh"\
- "M\u00e1rta"\
+ "Márta"\
"Aib"\
"Beal"\
"Meith"\
- "I\u00fail"\
- "L\u00fan"\
- "MF\u00f3mh"\
- "DF\u00f3mh"\
+ "Iúil"\
+ "Lún"\
+ "MFómh"\
+ "DFómh"\
"Samh"\
"Noll"\
""]
::msgcat::mcset ga MONTHS_FULL [list \
- "Ean\u00e1ir"\
+ "Eanáir"\
"Feabhra"\
- "M\u00e1rta"\
- "Aibre\u00e1n"\
- "M\u00ed na Bealtaine"\
+ "Márta"\
+ "Aibreán"\
+ "Mí na Bealtaine"\
"Meith"\
- "I\u00fail"\
- "L\u00fanasa"\
- "Me\u00e1n F\u00f3mhair"\
- "Deireadh F\u00f3mhair"\
- "M\u00ed na Samhna"\
- "M\u00ed na Nollag"\
+ "Iúil"\
+ "Lúnasa"\
+ "Meán Fómhair"\
+ "Deireadh Fómhair"\
+ "Mí na Samhna"\
+ "Mí na Nollag"\
""]
}
diff --git a/library/msgs/gl.msg b/library/msgs/gl.msg
index 4b869e8..c2fefc9 100644
--- a/library/msgs/gl.msg
+++ b/library/msgs/gl.msg
@@ -4,25 +4,25 @@ namespace eval ::tcl::clock {
"Dom"\
"Lun"\
"Mar"\
- "M\u00e9r"\
+ "Mér"\
"Xov"\
"Ven"\
- "S\u00e1b"]
+ "Sáb"]
::msgcat::mcset gl DAYS_OF_WEEK_FULL [list \
"Domingo"\
"Luns"\
"Martes"\
- "M\u00e9rcores"\
+ "Mércores"\
"Xoves"\
"Venres"\
- "S\u00e1bado"]
+ "Sábado"]
::msgcat::mcset gl MONTHS_ABBREV [list \
"Xan"\
"Feb"\
"Mar"\
"Abr"\
"Mai"\
- "Xu\u00f1"\
+ "Xuñ"\
"Xul"\
"Ago"\
"Set"\
@@ -36,7 +36,7 @@ namespace eval ::tcl::clock {
"Marzo"\
"Abril"\
"Maio"\
- "Xu\u00f1o"\
+ "Xuño"\
"Xullo"\
"Agosto"\
"Setembro"\
diff --git a/library/msgs/he.msg b/library/msgs/he.msg
index 4fd921d..13a81b7 100644
--- a/library/msgs/he.msg
+++ b/library/msgs/he.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset he DAYS_OF_WEEK_ABBREV [list \
- "\u05d0"\
- "\u05d1"\
- "\u05d2"\
- "\u05d3"\
- "\u05d4"\
- "\u05d5"\
- "\u05e9"]
+ "א"\
+ "ב"\
+ "ג"\
+ "ד"\
+ "ה"\
+ "ו"\
+ "ש"]
::msgcat::mcset he DAYS_OF_WEEK_FULL [list \
- "\u05d9\u05d5\u05dd \u05e8\u05d0\u05e9\u05d5\u05df"\
- "\u05d9\u05d5\u05dd \u05e9\u05e0\u05d9"\
- "\u05d9\u05d5\u05dd \u05e9\u05dc\u05d9\u05e9\u05d9"\
- "\u05d9\u05d5\u05dd \u05e8\u05d1\u05d9\u05e2\u05d9"\
- "\u05d9\u05d5\u05dd \u05d7\u05de\u05d9\u05e9\u05d9"\
- "\u05d9\u05d5\u05dd \u05e9\u05d9\u05e9\u05d9"\
- "\u05e9\u05d1\u05ea"]
+ "יום ראשון"\
+ "יום שני"\
+ "יום שלישי"\
+ "יום רביעי"\
+ "יום חמישי"\
+ "יום שישי"\
+ "שבת"]
::msgcat::mcset he MONTHS_ABBREV [list \
- "\u05d9\u05e0\u05d5"\
- "\u05e4\u05d1\u05e8"\
- "\u05de\u05e8\u05e5"\
- "\u05d0\u05e4\u05e8"\
- "\u05de\u05d0\u05d9"\
- "\u05d9\u05d5\u05e0"\
- "\u05d9\u05d5\u05dc"\
- "\u05d0\u05d5\u05d2"\
- "\u05e1\u05e4\u05d8"\
- "\u05d0\u05d5\u05e7"\
- "\u05e0\u05d5\u05d1"\
- "\u05d3\u05e6\u05de"\
+ "ינו"\
+ "פבר"\
+ "מרץ"\
+ "אפר"\
+ "מאי"\
+ "יונ"\
+ "יול"\
+ "אוג"\
+ "ספט"\
+ "אוק"\
+ "נוב"\
+ "דצמ"\
""]
::msgcat::mcset he MONTHS_FULL [list \
- "\u05d9\u05e0\u05d5\u05d0\u05e8"\
- "\u05e4\u05d1\u05e8\u05d5\u05d0\u05e8"\
- "\u05de\u05e8\u05e5"\
- "\u05d0\u05e4\u05e8\u05d9\u05dc"\
- "\u05de\u05d0\u05d9"\
- "\u05d9\u05d5\u05e0\u05d9"\
- "\u05d9\u05d5\u05dc\u05d9"\
- "\u05d0\u05d5\u05d2\u05d5\u05e1\u05d8"\
- "\u05e1\u05e4\u05d8\u05de\u05d1\u05e8"\
- "\u05d0\u05d5\u05e7\u05d8\u05d5\u05d1\u05e8"\
- "\u05e0\u05d5\u05d1\u05de\u05d1\u05e8"\
- "\u05d3\u05e6\u05de\u05d1\u05e8"\
+ "ינואר"\
+ "פברואר"\
+ "מרץ"\
+ "אפריל"\
+ "מאי"\
+ "יוני"\
+ "יולי"\
+ "אוגוסט"\
+ "ספטמבר"\
+ "אוקטובר"\
+ "נובמבר"\
+ "דצמבר"\
""]
- ::msgcat::mcset he BCE "\u05dc\u05e1\u05d4\u0022\u05e0"
- ::msgcat::mcset he CE "\u05dc\u05e4\u05e1\u05d4\u0022\u05e0"
+ ::msgcat::mcset he BCE "לסה"נ"
+ ::msgcat::mcset he CE "לפסה"נ"
::msgcat::mcset he DATE_FORMAT "%d/%m/%Y"
::msgcat::mcset he TIME_FORMAT "%H:%M:%S"
::msgcat::mcset he DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z"
diff --git a/library/msgs/hi.msg b/library/msgs/hi.msg
index 50c9fb8..18c8bf0 100644
--- a/library/msgs/hi.msg
+++ b/library/msgs/hi.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset hi DAYS_OF_WEEK_FULL [list \
- "\u0930\u0935\u093f\u0935\u093e\u0930"\
- "\u0938\u094b\u092e\u0935\u093e\u0930"\
- "\u092e\u0902\u0917\u0932\u0935\u093e\u0930"\
- "\u092c\u0941\u0927\u0935\u093e\u0930"\
- "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\
- "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\
- "\u0936\u0928\u093f\u0935\u093e\u0930"]
+ "रविवार"\
+ "सोमवार"\
+ "मंगलवार"\
+ "बुधवार"\
+ "गुरुवार"\
+ "शुक्रवार"\
+ "शनिवार"]
::msgcat::mcset hi MONTHS_ABBREV [list \
- "\u091c\u0928\u0935\u0930\u0940"\
- "\u092b\u093c\u0930\u0935\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u0905\u092a\u094d\u0930\u0947\u0932"\
- "\u092e\u0908"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u093e\u0908"\
- "\u0905\u0917\u0938\u094d\u0924"\
- "\u0938\u093f\u0924\u092e\u094d\u092c\u0930"\
- "\u0905\u0915\u094d\u091f\u0942\u092c\u0930"\
- "\u0928\u0935\u092e\u094d\u092c\u0930"\
- "\u0926\u093f\u0938\u092e\u094d\u092c\u0930"]
+ "जनवरी"\
+ "फ़रवरी"\
+ "मार्च"\
+ "अप्रेल"\
+ "मई"\
+ "जून"\
+ "जुलाई"\
+ "अगस्त"\
+ "सितम्बर"\
+ "अक्टूबर"\
+ "नवम्बर"\
+ "दिसम्बर"]
::msgcat::mcset hi MONTHS_FULL [list \
- "\u091c\u0928\u0935\u0930\u0940"\
- "\u092b\u093c\u0930\u0935\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u0905\u092a\u094d\u0930\u0947\u0932"\
- "\u092e\u0908"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u093e\u0908"\
- "\u0905\u0917\u0938\u094d\u0924"\
- "\u0938\u093f\u0924\u092e\u094d\u092c\u0930"\
- "\u0905\u0915\u094d\u091f\u0942\u092c\u0930"\
- "\u0928\u0935\u092e\u094d\u092c\u0930"\
- "\u0926\u093f\u0938\u092e\u094d\u092c\u0930"]
- ::msgcat::mcset hi AM "\u0908\u0938\u093e\u092a\u0942\u0930\u094d\u0935"
+ "जनवरी"\
+ "फ़रवरी"\
+ "मार्च"\
+ "अप्रेल"\
+ "मई"\
+ "जून"\
+ "जुलाई"\
+ "अगस्त"\
+ "सितम्बर"\
+ "अक्टूबर"\
+ "नवम्बर"\
+ "दिसम्बर"]
+ ::msgcat::mcset hi AM "ईसापूर्व"
::msgcat::mcset hi PM "."
}
diff --git a/library/msgs/hr.msg b/library/msgs/hr.msg
index cec145b..30491e1 100644
--- a/library/msgs/hr.msg
+++ b/library/msgs/hr.msg
@@ -5,7 +5,7 @@ namespace eval ::tcl::clock {
"pon"\
"uto"\
"sri"\
- "\u010det"\
+ "čet"\
"pet"\
"sub"]
::msgcat::mcset hr DAYS_OF_WEEK_FULL [list \
@@ -13,13 +13,13 @@ namespace eval ::tcl::clock {
"ponedjeljak"\
"utorak"\
"srijeda"\
- "\u010detvrtak"\
+ "četvrtak"\
"petak"\
"subota"]
::msgcat::mcset hr MONTHS_ABBREV [list \
"sij"\
"vel"\
- "o\u017eu"\
+ "ožu"\
"tra"\
"svi"\
"lip"\
@@ -31,9 +31,9 @@ namespace eval ::tcl::clock {
"pro"\
""]
::msgcat::mcset hr MONTHS_FULL [list \
- "sije\u010danj"\
- "velja\u010da"\
- "o\u017eujak"\
+ "siječanj"\
+ "veljača"\
+ "ožujak"\
"travanj"\
"svibanj"\
"lipanj"\
diff --git a/library/msgs/hu.msg b/library/msgs/hu.msg
index e5e68d9..46776dd 100644
--- a/library/msgs/hu.msg
+++ b/library/msgs/hu.msg
@@ -9,21 +9,21 @@ namespace eval ::tcl::clock {
"P"\
"Szo"]
::msgcat::mcset hu DAYS_OF_WEEK_FULL [list \
- "vas\u00e1rnap"\
- "h\u00e9tf\u0151"\
+ "vasárnap"\
+ "hétfő"\
"kedd"\
"szerda"\
- "cs\u00fct\u00f6rt\u00f6k"\
- "p\u00e9ntek"\
+ "csütörtök"\
+ "péntek"\
"szombat"]
::msgcat::mcset hu MONTHS_ABBREV [list \
"jan."\
"febr."\
- "m\u00e1rc."\
- "\u00e1pr."\
- "m\u00e1j."\
- "j\u00fan."\
- "j\u00fal."\
+ "márc."\
+ "ápr."\
+ "máj."\
+ "jún."\
+ "júl."\
"aug."\
"szept."\
"okt."\
@@ -31,16 +31,16 @@ namespace eval ::tcl::clock {
"dec."\
""]
::msgcat::mcset hu MONTHS_FULL [list \
- "janu\u00e1r"\
- "febru\u00e1r"\
- "m\u00e1rcius"\
- "\u00e1prilis"\
- "m\u00e1jus"\
- "j\u00fanius"\
- "j\u00falius"\
+ "január"\
+ "február"\
+ "március"\
+ "április"\
+ "május"\
+ "június"\
+ "július"\
"augusztus"\
"szeptember"\
- "okt\u00f3ber"\
+ "október"\
"november"\
"december"\
""]
diff --git a/library/msgs/is.msg b/library/msgs/is.msg
index adc2d2a..a369b89 100644
--- a/library/msgs/is.msg
+++ b/library/msgs/is.msg
@@ -2,46 +2,46 @@
namespace eval ::tcl::clock {
::msgcat::mcset is DAYS_OF_WEEK_ABBREV [list \
"sun."\
- "m\u00e1n."\
- "\u00feri."\
- "mi\u00f0."\
+ "mán."\
+ "þri."\
+ "mið."\
"fim."\
- "f\u00f6s."\
+ "fös."\
"lau."]
::msgcat::mcset is DAYS_OF_WEEK_FULL [list \
"sunnudagur"\
- "m\u00e1nudagur"\
- "\u00feri\u00f0judagur"\
- "mi\u00f0vikudagur"\
+ "mánudagur"\
+ "þriðjudagur"\
+ "miðvikudagur"\
"fimmtudagur"\
- "f\u00f6studagur"\
+ "föstudagur"\
"laugardagur"]
::msgcat::mcset is MONTHS_ABBREV [list \
"jan."\
"feb."\
"mar."\
"apr."\
- "ma\u00ed"\
- "j\u00fan."\
- "j\u00fal."\
- "\u00e1g\u00fa."\
+ "maí"\
+ "jún."\
+ "júl."\
+ "ágú."\
"sep."\
"okt."\
- "n\u00f3v."\
+ "nóv."\
"des."\
""]
::msgcat::mcset is MONTHS_FULL [list \
- "jan\u00faar"\
- "febr\u00faar"\
+ "janúar"\
+ "febrúar"\
"mars"\
- "apr\u00edl"\
- "ma\u00ed"\
- "j\u00fan\u00ed"\
- "j\u00fal\u00ed"\
- "\u00e1g\u00fast"\
+ "apríl"\
+ "maí"\
+ "júní"\
+ "júlí"\
+ "ágúst"\
"september"\
- "okt\u00f3ber"\
- "n\u00f3vember"\
+ "október"\
+ "nóvember"\
"desember"\
""]
::msgcat::mcset is DATE_FORMAT "%e.%m.%Y"
diff --git a/library/msgs/it.msg b/library/msgs/it.msg
index b641cde..e51aee2 100644
--- a/library/msgs/it.msg
+++ b/library/msgs/it.msg
@@ -10,11 +10,11 @@ namespace eval ::tcl::clock {
"sab"]
::msgcat::mcset it DAYS_OF_WEEK_FULL [list \
"domenica"\
- "luned\u00ec"\
- "marted\u00ec"\
- "mercoled\u00ec"\
- "gioved\u00ec"\
- "venerd\u00ec"\
+ "lunedì"\
+ "martedì"\
+ "mercoledì"\
+ "giovedì"\
+ "venerdì"\
"sabato"]
::msgcat::mcset it MONTHS_ABBREV [list \
"gen"\
diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg
index cf70c2f..dac690b 100644
--- a/library/msgs/ja.msg
+++ b/library/msgs/ja.msg
@@ -1,44 +1,44 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ja DAYS_OF_WEEK_ABBREV [list \
- "\u65e5"\
- "\u6708"\
- "\u706b"\
- "\u6c34"\
- "\u6728"\
- "\u91d1"\
- "\u571f"]
+ "日"\
+ "月"\
+ "火"\
+ "水"\
+ "木"\
+ "金"\
+ "土"]
::msgcat::mcset ja DAYS_OF_WEEK_FULL [list \
- "\u65e5\u66dc\u65e5"\
- "\u6708\u66dc\u65e5"\
- "\u706b\u66dc\u65e5"\
- "\u6c34\u66dc\u65e5"\
- "\u6728\u66dc\u65e5"\
- "\u91d1\u66dc\u65e5"\
- "\u571f\u66dc\u65e5"]
+ "日曜日"\
+ "月曜日"\
+ "火曜日"\
+ "水曜日"\
+ "木曜日"\
+ "金曜日"\
+ "土曜日"]
::msgcat::mcset ja MONTHS_FULL [list \
- "1\u6708"\
- "2\u6708"\
- "3\u6708"\
- "4\u6708"\
- "5\u6708"\
- "6\u6708"\
- "7\u6708"\
- "8\u6708"\
- "9\u6708"\
- "10\u6708"\
- "11\u6708"\
- "12\u6708"]
- ::msgcat::mcset ja BCE "\u7d00\u5143\u524d"
- ::msgcat::mcset ja CE "\u897f\u66a6"
- ::msgcat::mcset ja AM "\u5348\u524d"
- ::msgcat::mcset ja PM "\u5348\u5f8c"
+ "1月"\
+ "2月"\
+ "3月"\
+ "4月"\
+ "5月"\
+ "6月"\
+ "7月"\
+ "8月"\
+ "9月"\
+ "10月"\
+ "11月"\
+ "12月"]
+ ::msgcat::mcset ja BCE "紀元前"
+ ::msgcat::mcset ja CE "西暦"
+ ::msgcat::mcset ja AM "午前"
+ ::msgcat::mcset ja PM "午後"
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
- ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY\u5e74%m\u6708%d\u65e5"
- ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H\u6642%M\u5206%S\u79d2"
- ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY\u5e74%m\u6708%d\u65e5 (%a) %H\u6642%M\u5206%S\u79d2 %z"
- ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 \u897f\u66a6 0} {-3061011600 \u660e\u6cbb 1867} {-1812186000 \u5927\u6b63 1911} {-1357635600 \u662d\u548c 1925} {600220800 \u5e73\u6210 1988} {1556668800 \u4ee4\u548c 2018}"
+ ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
+ ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
+ ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
+ ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
}
diff --git a/library/msgs/ko.msg b/library/msgs/ko.msg
index 0cd17a1..817c2e7 100644
--- a/library/msgs/ko.msg
+++ b/library/msgs/ko.msg
@@ -1,55 +1,55 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ko DAYS_OF_WEEK_ABBREV [list \
- "\uc77c"\
- "\uc6d4"\
- "\ud654"\
- "\uc218"\
- "\ubaa9"\
- "\uae08"\
- "\ud1a0"]
+ "일"\
+ "월"\
+ "화"\
+ "수"\
+ "목"\
+ "금"\
+ "토"]
::msgcat::mcset ko DAYS_OF_WEEK_FULL [list \
- "\uc77c\uc694\uc77c"\
- "\uc6d4\uc694\uc77c"\
- "\ud654\uc694\uc77c"\
- "\uc218\uc694\uc77c"\
- "\ubaa9\uc694\uc77c"\
- "\uae08\uc694\uc77c"\
- "\ud1a0\uc694\uc77c"]
+ "일요일"\
+ "월요일"\
+ "화요일"\
+ "수요일"\
+ "목요일"\
+ "금요일"\
+ "토요일"]
::msgcat::mcset ko MONTHS_ABBREV [list \
- "1\uc6d4"\
- "2\uc6d4"\
- "3\uc6d4"\
- "4\uc6d4"\
- "5\uc6d4"\
- "6\uc6d4"\
- "7\uc6d4"\
- "8\uc6d4"\
- "9\uc6d4"\
- "10\uc6d4"\
- "11\uc6d4"\
- "12\uc6d4"\
+ "1월"\
+ "2월"\
+ "3월"\
+ "4월"\
+ "5월"\
+ "6월"\
+ "7월"\
+ "8월"\
+ "9월"\
+ "10월"\
+ "11월"\
+ "12월"\
""]
::msgcat::mcset ko MONTHS_FULL [list \
- "1\uc6d4"\
- "2\uc6d4"\
- "3\uc6d4"\
- "4\uc6d4"\
- "5\uc6d4"\
- "6\uc6d4"\
- "7\uc6d4"\
- "8\uc6d4"\
- "9\uc6d4"\
- "10\uc6d4"\
- "11\uc6d4"\
- "12\uc6d4"\
+ "1월"\
+ "2월"\
+ "3월"\
+ "4월"\
+ "5월"\
+ "6월"\
+ "7월"\
+ "8월"\
+ "9월"\
+ "10월"\
+ "11월"\
+ "12월"\
""]
- ::msgcat::mcset ko AM "\uc624\uc804"
- ::msgcat::mcset ko PM "\uc624\ud6c4"
+ ::msgcat::mcset ko AM "오전"
+ ::msgcat::mcset ko PM "오후"
::msgcat::mcset ko DATE_FORMAT "%Y-%m-%d"
::msgcat::mcset ko TIME_FORMAT_12 "%P %l:%M:%S"
::msgcat::mcset ko DATE_TIME_FORMAT "%Y-%m-%d %P %l:%M:%S %z"
- ::msgcat::mcset ko LOCALE_DATE_FORMAT "%Y\ub144%B%Od\uc77c"
- ::msgcat::mcset ko LOCALE_TIME_FORMAT "%H\uc2dc%M\ubd84%S\ucd08"
- ::msgcat::mcset ko LOCALE_DATE_TIME_FORMAT "%A %Y\ub144%B%Od\uc77c%H\uc2dc%M\ubd84%S\ucd08 %z"
+ ::msgcat::mcset ko LOCALE_DATE_FORMAT "%Y년%B%Od일"
+ ::msgcat::mcset ko LOCALE_TIME_FORMAT "%H시%M분%S초"
+ ::msgcat::mcset ko LOCALE_DATE_TIME_FORMAT "%A %Y년%B%Od일%H시%M분%S초 %z"
}
diff --git a/library/msgs/ko_kr.msg b/library/msgs/ko_kr.msg
index ea5bbd7..f23bd6b 100644
--- a/library/msgs/ko_kr.msg
+++ b/library/msgs/ko_kr.msg
@@ -1,7 +1,7 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
- ::msgcat::mcset ko_KR BCE "\uae30\uc6d0\uc804"
- ::msgcat::mcset ko_KR CE "\uc11c\uae30"
+ ::msgcat::mcset ko_KR BCE "기원전"
+ ::msgcat::mcset ko_KR CE "서기"
::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d"
::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S"
::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z"
diff --git a/library/msgs/kok.msg b/library/msgs/kok.msg
index 0869f20..231853b 100644
--- a/library/msgs/kok.msg
+++ b/library/msgs/kok.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset kok DAYS_OF_WEEK_FULL [list \
- "\u0906\u0926\u093f\u0924\u094d\u092f\u0935\u093e\u0930"\
- "\u0938\u094b\u092e\u0935\u093e\u0930"\
- "\u092e\u0902\u0917\u0933\u093e\u0930"\
- "\u092c\u0941\u0927\u0935\u093e\u0930"\
- "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\
- "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\
- "\u0936\u0928\u093f\u0935\u093e\u0930"]
+ "आदित्यवार"\
+ "सोमवार"\
+ "मंगळार"\
+ "बुधवार"\
+ "गुरुवार"\
+ "शुक्रवार"\
+ "शनिवार"]
::msgcat::mcset kok MONTHS_ABBREV [list \
- "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\
- "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u090f\u092a\u094d\u0930\u093f\u0932"\
- "\u092e\u0947"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u0948"\
- "\u0913\u0917\u0938\u094d\u091f"\
- "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\
- "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\
- "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\
- "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"]
+ "जानेवारी"\
+ "फेबृवारी"\
+ "मार्च"\
+ "एप्रिल"\
+ "मे"\
+ "जून"\
+ "जुलै"\
+ "ओगस्ट"\
+ "सेप्टेंबर"\
+ "ओक्टोबर"\
+ "नोव्हेंबर"\
+ "डिसेंबर"]
::msgcat::mcset kok MONTHS_FULL [list \
- "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\
- "\u092b\u0947\u092c\u094d\u0930\u0941\u0935\u093e\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u090f\u092a\u094d\u0930\u093f\u0932"\
- "\u092e\u0947"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u0948"\
- "\u0913\u0917\u0938\u094d\u091f"\
- "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\
- "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\
- "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\
- "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"]
- ::msgcat::mcset kok AM "\u0915\u094d\u0930\u093f\u0938\u094d\u0924\u092a\u0942\u0930\u094d\u0935"
- ::msgcat::mcset kok PM "\u0915\u094d\u0930\u093f\u0938\u094d\u0924\u0936\u0916\u093e"
+ "जानेवारी"\
+ "फेब्रुवारी"\
+ "मार्च"\
+ "एप्रिल"\
+ "मे"\
+ "जून"\
+ "जुलै"\
+ "ओगस्ट"\
+ "सेप्टेंबर"\
+ "ओक्टोबर"\
+ "नोव्हेंबर"\
+ "डिसेंबर"]
+ ::msgcat::mcset kok AM "क्रिस्तपूर्व"
+ ::msgcat::mcset kok PM "क्रिस्तशखा"
}
diff --git a/library/msgs/lt.msg b/library/msgs/lt.msg
index 27b0985..15829a9 100644
--- a/library/msgs/lt.msg
+++ b/library/msgs/lt.msg
@@ -7,15 +7,15 @@ namespace eval ::tcl::clock {
"Tr"\
"Kt"\
"Pn"\
- "\u0160t"]
+ "Št"]
::msgcat::mcset lt DAYS_OF_WEEK_FULL [list \
"Sekmadienis"\
"Pirmadienis"\
"Antradienis"\
- "Tre\u010diadienis"\
+ "Trečiadienis"\
"Ketvirtadienis"\
"Penktadienis"\
- "\u0160e\u0161tadienis"]
+ "Šeštadienis"]
::msgcat::mcset lt MONTHS_ABBREV [list \
"Sau"\
"Vas"\
@@ -34,15 +34,15 @@ namespace eval ::tcl::clock {
"Sausio"\
"Vasario"\
"Kovo"\
- "Baland\u017eio"\
- "Gegu\u017e\u0117s"\
- "Bir\u017eelio"\
+ "Balandžio"\
+ "Gegužės"\
+ "Birželio"\
"Liepos"\
- "Rugpj\u016b\u010dio"\
- "Rugs\u0117jo"\
+ "Rugpjūčio"\
+ "Rugsėjo"\
"Spalio"\
- "Lapkri\u010dio"\
- "Gruod\u017eio"\
+ "Lapkričio"\
+ "Gruodžio"\
""]
::msgcat::mcset lt BCE "pr.Kr."
::msgcat::mcset lt CE "po.Kr."
diff --git a/library/msgs/lv.msg b/library/msgs/lv.msg
index a037b15..730fd33 100644
--- a/library/msgs/lv.msg
+++ b/library/msgs/lv.msg
@@ -9,10 +9,10 @@ namespace eval ::tcl::clock {
"Pk"\
"S"]
::msgcat::mcset lv DAYS_OF_WEEK_FULL [list \
- "sv\u0113tdiena"\
+ "svētdiena"\
"pirmdiena"\
"otrdiena"\
- "tre\u0161diena"\
+ "trešdiena"\
"ceturdien"\
"piektdiena"\
"sestdiena"]
@@ -22,8 +22,8 @@ namespace eval ::tcl::clock {
"Mar"\
"Apr"\
"Maijs"\
- "J\u016bn"\
- "J\u016bl"\
+ "Jūn"\
+ "Jūl"\
"Aug"\
"Sep"\
"Okt"\
@@ -31,21 +31,21 @@ namespace eval ::tcl::clock {
"Dec"\
""]
::msgcat::mcset lv MONTHS_FULL [list \
- "janv\u0101ris"\
- "febru\u0101ris"\
+ "janvāris"\
+ "februāris"\
"marts"\
- "apr\u012blis"\
+ "aprīlis"\
"maijs"\
- "j\u016bnijs"\
- "j\u016blijs"\
+ "jūnijs"\
+ "jūlijs"\
"augusts"\
"septembris"\
"oktobris"\
"novembris"\
"decembris"\
""]
- ::msgcat::mcset lv BCE "pm\u0113"
- ::msgcat::mcset lv CE "m\u0113"
+ ::msgcat::mcset lv BCE "pmē"
+ ::msgcat::mcset lv CE "mē"
::msgcat::mcset lv DATE_FORMAT "%Y.%e.%m"
::msgcat::mcset lv TIME_FORMAT "%H:%M:%S"
::msgcat::mcset lv DATE_TIME_FORMAT "%Y.%e.%m %H:%M:%S %z"
diff --git a/library/msgs/mk.msg b/library/msgs/mk.msg
index 41cf60d..9b7bd9d 100644
--- a/library/msgs/mk.msg
+++ b/library/msgs/mk.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset mk DAYS_OF_WEEK_ABBREV [list \
- "\u043d\u0435\u0434."\
- "\u043f\u043e\u043d."\
- "\u0432\u0442."\
- "\u0441\u0440\u0435."\
- "\u0447\u0435\u0442."\
- "\u043f\u0435\u0442."\
- "\u0441\u0430\u0431."]
+ "нед."\
+ "пон."\
+ "вт."\
+ "сре."\
+ "чет."\
+ "пет."\
+ "саб."]
::msgcat::mcset mk DAYS_OF_WEEK_FULL [list \
- "\u043d\u0435\u0434\u0435\u043b\u0430"\
- "\u043f\u043e\u043d\u0435\u0434\u0435\u043b\u043d\u0438\u043a"\
- "\u0432\u0442\u043e\u0440\u043d\u0438\u043a"\
- "\u0441\u0440\u0435\u0434\u0430"\
- "\u0447\u0435\u0442\u0432\u0440\u0442\u043e\u043a"\
- "\u043f\u0435\u0442\u043e\u043a"\
- "\u0441\u0430\u0431\u043e\u0442\u0430"]
+ "недела"\
+ "понеделник"\
+ "вторник"\
+ "среда"\
+ "четврток"\
+ "петок"\
+ "сабота"]
::msgcat::mcset mk MONTHS_ABBREV [list \
- "\u0458\u0430\u043d."\
- "\u0444\u0435\u0432."\
- "\u043c\u0430\u0440."\
- "\u0430\u043f\u0440."\
- "\u043c\u0430\u0458."\
- "\u0458\u0443\u043d."\
- "\u0458\u0443\u043b."\
- "\u0430\u0432\u0433."\
- "\u0441\u0435\u043f\u0442."\
- "\u043e\u043a\u0442."\
- "\u043d\u043e\u0435\u043c."\
- "\u0434\u0435\u043a\u0435\u043c."\
+ "јан."\
+ "фев."\
+ "мар."\
+ "апр."\
+ "мај."\
+ "јун."\
+ "јул."\
+ "авг."\
+ "септ."\
+ "окт."\
+ "ноем."\
+ "декем."\
""]
::msgcat::mcset mk MONTHS_FULL [list \
- "\u0458\u0430\u043d\u0443\u0430\u0440\u0438"\
- "\u0444\u0435\u0432\u0440\u0443\u0430\u0440\u0438"\
- "\u043c\u0430\u0440\u0442"\
- "\u0430\u043f\u0440\u0438\u043b"\
- "\u043c\u0430\u0458"\
- "\u0458\u0443\u043d\u0438"\
- "\u0458\u0443\u043b\u0438"\
- "\u0430\u0432\u0433\u0443\u0441\u0442"\
- "\u0441\u0435\u043f\u0442\u0435\u043c\u0432\u0440\u0438"\
- "\u043e\u043a\u0442\u043e\u043c\u0432\u0440\u0438"\
- "\u043d\u043e\u0435\u043c\u0432\u0440\u0438"\
- "\u0434\u0435\u043a\u0435\u043c\u0432\u0440\u0438"\
+ "јануари"\
+ "февруари"\
+ "март"\
+ "април"\
+ "мај"\
+ "јуни"\
+ "јули"\
+ "август"\
+ "септември"\
+ "октомври"\
+ "ноември"\
+ "декември"\
""]
- ::msgcat::mcset mk BCE "\u043f\u0440.\u043d.\u0435."
- ::msgcat::mcset mk CE "\u0430\u0435."
+ ::msgcat::mcset mk BCE "пр.н.е."
+ ::msgcat::mcset mk CE "ае."
::msgcat::mcset mk DATE_FORMAT "%e.%m.%Y"
::msgcat::mcset mk TIME_FORMAT "%H:%M:%S %z"
::msgcat::mcset mk DATE_TIME_FORMAT "%e.%m.%Y %H:%M:%S %z %z"
diff --git a/library/msgs/mr.msg b/library/msgs/mr.msg
index cea427a..e475615 100644
--- a/library/msgs/mr.msg
+++ b/library/msgs/mr.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset mr DAYS_OF_WEEK_FULL [list \
- "\u0930\u0935\u093f\u0935\u093e\u0930"\
- "\u0938\u094b\u092e\u0935\u093e\u0930"\
- "\u092e\u0902\u0917\u0933\u0935\u093e\u0930"\
- "\u092e\u0902\u0917\u0933\u0935\u093e\u0930"\
- "\u0917\u0941\u0930\u0941\u0935\u093e\u0930"\
- "\u0936\u0941\u0915\u094d\u0930\u0935\u093e\u0930"\
- "\u0936\u0928\u093f\u0935\u093e\u0930"]
+ "रविवार"\
+ "सोमवार"\
+ "मंगळवार"\
+ "मंगळवार"\
+ "गुरुवार"\
+ "शुक्रवार"\
+ "शनिवार"]
::msgcat::mcset mr MONTHS_ABBREV [list \
- "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\
- "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u090f\u092a\u094d\u0930\u093f\u0932"\
- "\u092e\u0947"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u0948"\
- "\u0913\u0917\u0938\u094d\u091f"\
- "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\
- "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\
- "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\
- "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"]
+ "जानेवारी"\
+ "फेबृवारी"\
+ "मार्च"\
+ "एप्रिल"\
+ "मे"\
+ "जून"\
+ "जुलै"\
+ "ओगस्ट"\
+ "सेप्टेंबर"\
+ "ओक्टोबर"\
+ "नोव्हेंबर"\
+ "डिसेंबर"]
::msgcat::mcset mr MONTHS_FULL [list \
- "\u091c\u093e\u0928\u0947\u0935\u093e\u0930\u0940"\
- "\u092b\u0947\u092c\u0943\u0935\u093e\u0930\u0940"\
- "\u092e\u093e\u0930\u094d\u091a"\
- "\u090f\u092a\u094d\u0930\u093f\u0932"\
- "\u092e\u0947"\
- "\u091c\u0942\u0928"\
- "\u091c\u0941\u0932\u0948"\
- "\u0913\u0917\u0938\u094d\u091f"\
- "\u0938\u0947\u092a\u094d\u091f\u0947\u0902\u092c\u0930"\
- "\u0913\u0915\u094d\u091f\u094b\u092c\u0930"\
- "\u0928\u094b\u0935\u094d\u0939\u0947\u0902\u092c\u0930"\
- "\u0921\u093f\u0938\u0947\u0902\u092c\u0930"]
+ "जानेवारी"\
+ "फेबृवारी"\
+ "मार्च"\
+ "एप्रिल"\
+ "मे"\
+ "जून"\
+ "जुलै"\
+ "ओगस्ट"\
+ "सेप्टेंबर"\
+ "ओक्टोबर"\
+ "नोव्हेंबर"\
+ "डिसेंबर"]
::msgcat::mcset mr AM "BC"
::msgcat::mcset mr PM "AD"
}
diff --git a/library/msgs/mt.msg b/library/msgs/mt.msg
index ddd5446..c479e47 100644
--- a/library/msgs/mt.msg
+++ b/library/msgs/mt.msg
@@ -1,19 +1,19 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset mt DAYS_OF_WEEK_ABBREV [list \
- "\u0126ad"\
+ "Ħad"\
"Tne"\
"Tli"\
"Erb"\
- "\u0126am"\
- "\u0120im"]
+ "Ħam"\
+ "Ġim"]
::msgcat::mcset mt MONTHS_ABBREV [list \
"Jan"\
"Fra"\
"Mar"\
"Apr"\
"Mej"\
- "\u0120un"\
+ "Ġun"\
"Lul"\
"Awi"\
"Set"\
diff --git a/library/msgs/nb.msg b/library/msgs/nb.msg
index 90d49a3..4dd76c7 100644
--- a/library/msgs/nb.msg
+++ b/library/msgs/nb.msg
@@ -1,21 +1,21 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset nb DAYS_OF_WEEK_ABBREV [list \
- "s\u00f8"\
+ "sø"\
"ma"\
"ti"\
"on"\
"to"\
"fr"\
- "l\u00f8"]
+ "lø"]
::msgcat::mcset nb DAYS_OF_WEEK_FULL [list \
- "s\u00f8ndag"\
+ "søndag"\
"mandag"\
"tirsdag"\
"onsdag"\
"torsdag"\
"fredag"\
- "l\u00f8rdag"]
+ "lørdag"]
::msgcat::mcset nb MONTHS_ABBREV [list \
"jan"\
"feb"\
diff --git a/library/msgs/nn.msg b/library/msgs/nn.msg
index bd61ac9..b61a2dd 100644
--- a/library/msgs/nn.msg
+++ b/library/msgs/nn.msg
@@ -2,7 +2,7 @@
namespace eval ::tcl::clock {
::msgcat::mcset nn DAYS_OF_WEEK_ABBREV [list \
"su"\
- "m\u00e5"\
+ "må"\
"ty"\
"on"\
"to"\
@@ -10,7 +10,7 @@ namespace eval ::tcl::clock {
"lau"]
::msgcat::mcset nn DAYS_OF_WEEK_FULL [list \
"sundag"\
- "m\u00e5ndag"\
+ "måndag"\
"tysdag"\
"onsdag"\
"torsdag"\
diff --git a/library/msgs/pl.msg b/library/msgs/pl.msg
index d206f4b..821eea7 100644
--- a/library/msgs/pl.msg
+++ b/library/msgs/pl.msg
@@ -4,17 +4,17 @@ namespace eval ::tcl::clock {
"N"\
"Pn"\
"Wt"\
- "\u015ar"\
+ "Śr"\
"Cz"\
"Pt"\
"So"]
::msgcat::mcset pl DAYS_OF_WEEK_FULL [list \
"niedziela"\
- "poniedzia\u0142ek"\
+ "poniedziałek"\
"wtorek"\
- "\u015broda"\
+ "środa"\
"czwartek"\
- "pi\u0105tek"\
+ "piątek"\
"sobota"]
::msgcat::mcset pl MONTHS_ABBREV [list \
"sty"\
@@ -26,23 +26,23 @@ namespace eval ::tcl::clock {
"lip"\
"sie"\
"wrz"\
- "pa\u017a"\
+ "paź"\
"lis"\
"gru"\
""]
::msgcat::mcset pl MONTHS_FULL [list \
- "stycze\u0144"\
+ "styczeń"\
"luty"\
"marzec"\
- "kwiecie\u0144"\
+ "kwiecień"\
"maj"\
"czerwiec"\
"lipiec"\
- "sierpie\u0144"\
- "wrzesie\u0144"\
- "pa\u017adziernik"\
+ "sierpień"\
+ "wrzesień"\
+ "październik"\
"listopad"\
- "grudzie\u0144"\
+ "grudzień"\
""]
::msgcat::mcset pl BCE "p.n.e."
::msgcat::mcset pl CE "n.e."
diff --git a/library/msgs/pt.msg b/library/msgs/pt.msg
index 96fdb35..425c1f6 100644
--- a/library/msgs/pt.msg
+++ b/library/msgs/pt.msg
@@ -7,15 +7,15 @@ namespace eval ::tcl::clock {
"Qua"\
"Qui"\
"Sex"\
- "S\u00e1b"]
+ "Sáb"]
::msgcat::mcset pt DAYS_OF_WEEK_FULL [list \
"Domingo"\
"Segunda-feira"\
- "Ter\u00e7a-feira"\
+ "Terça-feira"\
"Quarta-feira"\
"Quinta-feira"\
"Sexta-feira"\
- "S\u00e1bado"]
+ "Sábado"]
::msgcat::mcset pt MONTHS_ABBREV [list \
"Jan"\
"Fev"\
@@ -33,7 +33,7 @@ namespace eval ::tcl::clock {
::msgcat::mcset pt MONTHS_FULL [list \
"Janeiro"\
"Fevereiro"\
- "Mar\u00e7o"\
+ "Março"\
"Abril"\
"Maio"\
"Junho"\
diff --git a/library/msgs/ro.msg b/library/msgs/ro.msg
index bdd7c61..f4452ba 100644
--- a/library/msgs/ro.msg
+++ b/library/msgs/ro.msg
@@ -9,13 +9,13 @@ namespace eval ::tcl::clock {
"V"\
"S"]
::msgcat::mcset ro DAYS_OF_WEEK_FULL [list \
- "duminic\u0103"\
+ "duminică"\
"luni"\
- "mar\u0163i"\
+ "marţi"\
"miercuri"\
"joi"\
"vineri"\
- "s\u00eemb\u0103t\u0103"]
+ "sîmbătă"]
::msgcat::mcset ro MONTHS_ABBREV [list \
"Ian"\
"Feb"\
@@ -45,7 +45,7 @@ namespace eval ::tcl::clock {
"decembrie"\
""]
::msgcat::mcset ro BCE "d.C."
- ::msgcat::mcset ro CE "\u00ee.d.C."
+ ::msgcat::mcset ro CE "î.d.C."
::msgcat::mcset ro DATE_FORMAT "%d.%m.%Y"
::msgcat::mcset ro TIME_FORMAT "%H:%M:%S"
::msgcat::mcset ro DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z"
diff --git a/library/msgs/ru.msg b/library/msgs/ru.msg
index 65b075d..983a253 100644
--- a/library/msgs/ru.msg
+++ b/library/msgs/ru.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ru DAYS_OF_WEEK_ABBREV [list \
- "\u0412\u0441"\
- "\u041f\u043d"\
- "\u0412\u0442"\
- "\u0421\u0440"\
- "\u0427\u0442"\
- "\u041f\u0442"\
- "\u0421\u0431"]
+ "Вс"\
+ "Пн"\
+ "Вт"\
+ "Ср"\
+ "Чт"\
+ "Пт"\
+ "Сб"]
::msgcat::mcset ru DAYS_OF_WEEK_FULL [list \
- "\u0432\u043e\u0441\u043a\u0440\u0435\u0441\u0435\u043d\u044c\u0435"\
- "\u043f\u043e\u043d\u0435\u0434\u0435\u043b\u044c\u043d\u0438\u043a"\
- "\u0432\u0442\u043e\u0440\u043d\u0438\u043a"\
- "\u0441\u0440\u0435\u0434\u0430"\
- "\u0447\u0435\u0442\u0432\u0435\u0440\u0433"\
- "\u043f\u044f\u0442\u043d\u0438\u0446\u0430"\
- "\u0441\u0443\u0431\u0431\u043e\u0442\u0430"]
+ "воскресенье"\
+ "понедельник"\
+ "вторник"\
+ "среда"\
+ "четверг"\
+ "пятница"\
+ "суббота"]
::msgcat::mcset ru MONTHS_ABBREV [list \
- "\u044f\u043d\u0432"\
- "\u0444\u0435\u0432"\
- "\u043c\u0430\u0440"\
- "\u0430\u043f\u0440"\
- "\u043c\u0430\u0439"\
- "\u0438\u044e\u043d"\
- "\u0438\u044e\u043b"\
- "\u0430\u0432\u0433"\
- "\u0441\u0435\u043d"\
- "\u043e\u043a\u0442"\
- "\u043d\u043e\u044f"\
- "\u0434\u0435\u043a"\
+ "янв"\
+ "фев"\
+ "мар"\
+ "апр"\
+ "май"\
+ "июн"\
+ "июл"\
+ "авг"\
+ "сен"\
+ "окт"\
+ "ноя"\
+ "дек"\
""]
::msgcat::mcset ru MONTHS_FULL [list \
- "\u042f\u043d\u0432\u0430\u0440\u044c"\
- "\u0424\u0435\u0432\u0440\u0430\u043b\u044c"\
- "\u041c\u0430\u0440\u0442"\
- "\u0410\u043f\u0440\u0435\u043b\u044c"\
- "\u041c\u0430\u0439"\
- "\u0418\u044e\u043d\u044c"\
- "\u0418\u044e\u043b\u044c"\
- "\u0410\u0432\u0433\u0443\u0441\u0442"\
- "\u0421\u0435\u043d\u0442\u044f\u0431\u0440\u044c"\
- "\u041e\u043a\u0442\u044f\u0431\u0440\u044c"\
- "\u041d\u043e\u044f\u0431\u0440\u044c"\
- "\u0414\u0435\u043a\u0430\u0431\u0440\u044c"\
+ "Январь"\
+ "Февраль"\
+ "Март"\
+ "Апрель"\
+ "Май"\
+ "Июнь"\
+ "Июль"\
+ "Август"\
+ "Сентябрь"\
+ "Октябрь"\
+ "Ноябрь"\
+ "Декабрь"\
""]
- ::msgcat::mcset ru BCE "\u0434\u043e \u043d.\u044d."
- ::msgcat::mcset ru CE "\u043d.\u044d."
+ ::msgcat::mcset ru BCE "до н.э."
+ ::msgcat::mcset ru CE "н.э."
::msgcat::mcset ru DATE_FORMAT "%d.%m.%Y"
::msgcat::mcset ru TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ru DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z"
diff --git a/library/msgs/sh.msg b/library/msgs/sh.msg
index 6ee0fc7..2e4143d 100644
--- a/library/msgs/sh.msg
+++ b/library/msgs/sh.msg
@@ -5,7 +5,7 @@ namespace eval ::tcl::clock {
"Pon"\
"Uto"\
"Sre"\
- "\u010cet"\
+ "Čet"\
"Pet"\
"Sub"]
::msgcat::mcset sh DAYS_OF_WEEK_FULL [list \
@@ -13,7 +13,7 @@ namespace eval ::tcl::clock {
"Ponedeljak"\
"Utorak"\
"Sreda"\
- "\u010cetvrtak"\
+ "Četvrtak"\
"Petak"\
"Subota"]
::msgcat::mcset sh MONTHS_ABBREV [list \
diff --git a/library/msgs/sk.msg b/library/msgs/sk.msg
index 9b2f0aa..dc6f6b6 100644
--- a/library/msgs/sk.msg
+++ b/library/msgs/sk.msg
@@ -5,15 +5,15 @@ namespace eval ::tcl::clock {
"Po"\
"Ut"\
"St"\
- "\u0160t"\
+ "Št"\
"Pa"\
"So"]
::msgcat::mcset sk DAYS_OF_WEEK_FULL [list \
- "Nede\u013ee"\
+ "Nedeľe"\
"Pondelok"\
"Utorok"\
"Streda"\
- "\u0160tvrtok"\
+ "Štvrtok"\
"Piatok"\
"Sobota"]
::msgcat::mcset sk MONTHS_ABBREV [list \
@@ -21,9 +21,9 @@ namespace eval ::tcl::clock {
"feb"\
"mar"\
"apr"\
- "m\u00e1j"\
- "j\u00fan"\
- "j\u00fal"\
+ "máj"\
+ "jún"\
+ "júl"\
"aug"\
"sep"\
"okt"\
@@ -31,16 +31,16 @@ namespace eval ::tcl::clock {
"dec"\
""]
::msgcat::mcset sk MONTHS_FULL [list \
- "janu\u00e1r"\
- "febru\u00e1r"\
+ "január"\
+ "február"\
"marec"\
- "apr\u00edl"\
- "m\u00e1j"\
- "j\u00fan"\
- "j\u00fal"\
+ "apríl"\
+ "máj"\
+ "jún"\
+ "júl"\
"august"\
"september"\
- "okt\u00f3ber"\
+ "október"\
"november"\
"december"\
""]
diff --git a/library/msgs/sl.msg b/library/msgs/sl.msg
index 42bc509..2ee0a03 100644
--- a/library/msgs/sl.msg
+++ b/library/msgs/sl.msg
@@ -5,7 +5,7 @@ namespace eval ::tcl::clock {
"Pon"\
"Tor"\
"Sre"\
- "\u010cet"\
+ "Čet"\
"Pet"\
"Sob"]
::msgcat::mcset sl DAYS_OF_WEEK_FULL [list \
@@ -13,7 +13,7 @@ namespace eval ::tcl::clock {
"Ponedeljek"\
"Torek"\
"Sreda"\
- "\u010cetrtek"\
+ "Četrtek"\
"Petek"\
"Sobota"]
::msgcat::mcset sl MONTHS_ABBREV [list \
@@ -44,7 +44,7 @@ namespace eval ::tcl::clock {
"november"\
"december"\
""]
- ::msgcat::mcset sl BCE "pr.n.\u0161."
+ ::msgcat::mcset sl BCE "pr.n.š."
::msgcat::mcset sl CE "po Kr."
::msgcat::mcset sl DATE_FORMAT "%Y.%m.%e"
::msgcat::mcset sl TIME_FORMAT "%k:%M:%S"
diff --git a/library/msgs/sq.msg b/library/msgs/sq.msg
index 8fb1fce..65da407 100644
--- a/library/msgs/sq.msg
+++ b/library/msgs/sq.msg
@@ -2,20 +2,20 @@
namespace eval ::tcl::clock {
::msgcat::mcset sq DAYS_OF_WEEK_ABBREV [list \
"Die"\
- "H\u00ebn"\
+ "Hën"\
"Mar"\
- "M\u00ebr"\
+ "Mër"\
"Enj"\
"Pre"\
"Sht"]
::msgcat::mcset sq DAYS_OF_WEEK_FULL [list \
"e diel"\
- "e h\u00ebn\u00eb"\
- "e mart\u00eb"\
- "e m\u00ebrkur\u00eb"\
+ "e hënë"\
+ "e martë"\
+ "e mërkurë"\
"e enjte"\
"e premte"\
- "e shtun\u00eb"]
+ "e shtunë"]
::msgcat::mcset sq MONTHS_ABBREV [list \
"Jan"\
"Shk"\
@@ -27,7 +27,7 @@ namespace eval ::tcl::clock {
"Gsh"\
"Sht"\
"Tet"\
- "N\u00ebn"\
+ "Nën"\
"Dhj"\
""]
::msgcat::mcset sq MONTHS_FULL [list \
@@ -41,7 +41,7 @@ namespace eval ::tcl::clock {
"gusht"\
"shtator"\
"tetor"\
- "n\u00ebntor"\
+ "nëntor"\
"dhjetor"\
""]
::msgcat::mcset sq BCE "p.e.r."
diff --git a/library/msgs/sr.msg b/library/msgs/sr.msg
index 7576668..3d84d6c 100644
--- a/library/msgs/sr.msg
+++ b/library/msgs/sr.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset sr DAYS_OF_WEEK_ABBREV [list \
- "\u041d\u0435\u0434"\
- "\u041f\u043e\u043d"\
- "\u0423\u0442\u043e"\
- "\u0421\u0440\u0435"\
- "\u0427\u0435\u0442"\
- "\u041f\u0435\u0442"\
- "\u0421\u0443\u0431"]
+ "Нед"\
+ "Пон"\
+ "Уто"\
+ "Сре"\
+ "Чет"\
+ "Пет"\
+ "Суб"]
::msgcat::mcset sr DAYS_OF_WEEK_FULL [list \
- "\u041d\u0435\u0434\u0435\u0459\u0430"\
- "\u041f\u043e\u043d\u0435\u0434\u0435\u0459\u0430\u043a"\
- "\u0423\u0442\u043e\u0440\u0430\u043a"\
- "\u0421\u0440\u0435\u0434\u0430"\
- "\u0427\u0435\u0442\u0432\u0440\u0442\u0430\u043a"\
- "\u041f\u0435\u0442\u0430\u043a"\
- "\u0421\u0443\u0431\u043e\u0442\u0430"]
+ "Недеља"\
+ "Понедељак"\
+ "Уторак"\
+ "Среда"\
+ "Четвртак"\
+ "Петак"\
+ "Субота"]
::msgcat::mcset sr MONTHS_ABBREV [list \
- "\u0408\u0430\u043d"\
- "\u0424\u0435\u0431"\
- "\u041c\u0430\u0440"\
- "\u0410\u043f\u0440"\
- "\u041c\u0430\u0458"\
- "\u0408\u0443\u043d"\
- "\u0408\u0443\u043b"\
- "\u0410\u0432\u0433"\
- "\u0421\u0435\u043f"\
- "\u041e\u043a\u0442"\
- "\u041d\u043e\u0432"\
- "\u0414\u0435\u0446"\
+ "Јан"\
+ "Феб"\
+ "Мар"\
+ "Апр"\
+ "Мај"\
+ "Јун"\
+ "Јул"\
+ "Авг"\
+ "Сеп"\
+ "Окт"\
+ "Нов"\
+ "Дец"\
""]
::msgcat::mcset sr MONTHS_FULL [list \
- "\u0408\u0430\u043d\u0443\u0430\u0440"\
- "\u0424\u0435\u0431\u0440\u0443\u0430\u0440"\
- "\u041c\u0430\u0440\u0442"\
- "\u0410\u043f\u0440\u0438\u043b"\
- "\u041c\u0430\u0458"\
- "\u0408\u0443\u043d\u0438"\
- "\u0408\u0443\u043b\u0438"\
- "\u0410\u0432\u0433\u0443\u0441\u0442"\
- "\u0421\u0435\u043f\u0442\u0435\u043c\u0431\u0430\u0440"\
- "\u041e\u043a\u0442\u043e\u0431\u0430\u0440"\
- "\u041d\u043e\u0432\u0435\u043c\u0431\u0430\u0440"\
- "\u0414\u0435\u0446\u0435\u043c\u0431\u0430\u0440"\
+ "Јануар"\
+ "Фебруар"\
+ "Март"\
+ "Април"\
+ "Мај"\
+ "Јуни"\
+ "Јули"\
+ "Август"\
+ "Септембар"\
+ "Октобар"\
+ "Новембар"\
+ "Децембар"\
""]
- ::msgcat::mcset sr BCE "\u043f. \u043d. \u0435."
- ::msgcat::mcset sr CE "\u043d. \u0435"
+ ::msgcat::mcset sr BCE "п. н. е."
+ ::msgcat::mcset sr CE "н. е"
::msgcat::mcset sr DATE_FORMAT "%Y.%m.%e"
::msgcat::mcset sr TIME_FORMAT "%k.%M.%S"
::msgcat::mcset sr DATE_TIME_FORMAT "%Y.%m.%e %k.%M.%S %z"
diff --git a/library/msgs/sv.msg b/library/msgs/sv.msg
index f7a67c6..5716092 100644
--- a/library/msgs/sv.msg
+++ b/library/msgs/sv.msg
@@ -1,21 +1,21 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset sv DAYS_OF_WEEK_ABBREV [list \
- "s\u00f6"\
- "m\u00e5"\
+ "sö"\
+ "må"\
"ti"\
"on"\
"to"\
"fr"\
- "l\u00f6"]
+ "lö"]
::msgcat::mcset sv DAYS_OF_WEEK_FULL [list \
- "s\u00f6ndag"\
- "m\u00e5ndag"\
+ "söndag"\
+ "måndag"\
"tisdag"\
"onsdag"\
"torsdag"\
"fredag"\
- "l\u00f6rdag"]
+ "lördag"]
::msgcat::mcset sv MONTHS_ABBREV [list \
"jan"\
"feb"\
diff --git a/library/msgs/ta.msg b/library/msgs/ta.msg
index 4abb90c..ea62552 100644
--- a/library/msgs/ta.msg
+++ b/library/msgs/ta.msg
@@ -1,39 +1,39 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset ta DAYS_OF_WEEK_FULL [list \
- "\u0b9e\u0bbe\u0baf\u0bbf\u0bb1\u0bc1"\
- "\u0ba4\u0bbf\u0b99\u0bcd\u0b95\u0bb3\u0bcd"\
- "\u0b9a\u0bc6\u0bb5\u0bcd\u0bb5\u0bbe\u0baf\u0bcd"\
- "\u0baa\u0bc1\u0ba4\u0ba9\u0bcd"\
- "\u0bb5\u0bbf\u0baf\u0bbe\u0bb4\u0ba9\u0bcd"\
- "\u0bb5\u0bc6\u0bb3\u0bcd\u0bb3\u0bbf"\
- "\u0b9a\u0ba9\u0bbf"]
+ "ஞாயிறு"\
+ "திங்கள்"\
+ "செவ்வாய்"\
+ "புதன்"\
+ "வியாழன்"\
+ "வெள்ளி"\
+ "சனி"]
::msgcat::mcset ta MONTHS_ABBREV [list \
- "\u0b9c\u0ba9\u0bb5\u0bb0\u0bbf"\
- "\u0baa\u0bc6\u0baa\u0bcd\u0bb0\u0bb5\u0bb0\u0bbf"\
- "\u0bae\u0bbe\u0bb0\u0bcd\u0b9a\u0bcd"\
- "\u0b8f\u0baa\u0bcd\u0bb0\u0bb2\u0bcd"\
- "\u0bae\u0bc7"\
- "\u0b9c\u0bc2\u0ba9\u0bcd"\
- "\u0b9c\u0bc2\u0bb2\u0bc8"\
- "\u0b86\u0b95\u0bb8\u0bcd\u0b9f\u0bcd"\
- "\u0b9a\u0bc6\u0baa\u0bcd\u0b9f\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\
- "\u0b85\u0b95\u0bcd\u0b9f\u0bcb\u0baa\u0bb0\u0bcd"\
- "\u0ba8\u0bb5\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\
- "\u0b9f\u0bbf\u0b9a\u0bae\u0bcd\u0baa\u0bb0\u0bcdr"]
+ "ஜனவரி"\
+ "பெப்ரவரி"\
+ "மார்ச்"\
+ "ஏப்ரல்"\
+ "மே"\
+ "ஜூன்"\
+ "ஜூலை"\
+ "ஆகஸ்ட்"\
+ "செப்டம்பர்"\
+ "அக்டோபர்"\
+ "நவம்பர்"\
+ "டிசம்பர்r"]
::msgcat::mcset ta MONTHS_FULL [list \
- "\u0b9c\u0ba9\u0bb5\u0bb0\u0bbf"\
- "\u0baa\u0bc6\u0baa\u0bcd\u0bb0\u0bb5\u0bb0\u0bbf"\
- "\u0bae\u0bbe\u0bb0\u0bcd\u0b9a\u0bcd"\
- "\u0b8f\u0baa\u0bcd\u0bb0\u0bb2\u0bcd"\
- "\u0bae\u0bc7"\
- "\u0b9c\u0bc2\u0ba9\u0bcd"\
- "\u0b9c\u0bc2\u0bb2\u0bc8"\
- "\u0b86\u0b95\u0bb8\u0bcd\u0b9f\u0bcd"\
- "\u0b9a\u0bc6\u0baa\u0bcd\u0b9f\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\
- "\u0b85\u0b95\u0bcd\u0b9f\u0bcb\u0baa\u0bb0\u0bcd"\
- "\u0ba8\u0bb5\u0bae\u0bcd\u0baa\u0bb0\u0bcd"\
- "\u0b9f\u0bbf\u0b9a\u0bae\u0bcd\u0baa\u0bb0\u0bcdr"]
- ::msgcat::mcset ta AM "\u0b95\u0bbf\u0bae\u0bc1"
- ::msgcat::mcset ta PM "\u0b95\u0bbf\u0baa\u0bbf"
+ "ஜனவரி"\
+ "பெப்ரவரி"\
+ "மார்ச்"\
+ "ஏப்ரல்"\
+ "மே"\
+ "ஜூன்"\
+ "ஜூலை"\
+ "ஆகஸ்ட்"\
+ "செப்டம்பர்"\
+ "அக்டோபர்"\
+ "நவம்பர்"\
+ "டிசம்பர்r"]
+ ::msgcat::mcset ta AM "கிமு"
+ ::msgcat::mcset ta PM "கிபி"
}
diff --git a/library/msgs/te.msg b/library/msgs/te.msg
index 6111473..f35ece4 100644
--- a/library/msgs/te.msg
+++ b/library/msgs/te.msg
@@ -1,47 +1,47 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset te DAYS_OF_WEEK_ABBREV [list \
- "\u0c06\u0c26\u0c3f"\
- "\u0c38\u0c4b\u0c2e"\
- "\u0c2e\u0c02\u0c17\u0c33"\
- "\u0c2c\u0c41\u0c27"\
- "\u0c17\u0c41\u0c30\u0c41"\
- "\u0c36\u0c41\u0c15\u0c4d\u0c30"\
- "\u0c36\u0c28\u0c3f"]
+ "ఆది"\
+ "సోమ"\
+ "మంగళ"\
+ "బుధ"\
+ "గురు"\
+ "శుక్ర"\
+ "శని"]
::msgcat::mcset te DAYS_OF_WEEK_FULL [list \
- "\u0c06\u0c26\u0c3f\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c38\u0c4b\u0c2e\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c2e\u0c02\u0c17\u0c33\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c2c\u0c41\u0c27\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c17\u0c41\u0c30\u0c41\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c36\u0c41\u0c15\u0c4d\u0c30\u0c35\u0c3e\u0c30\u0c02"\
- "\u0c36\u0c28\u0c3f\u0c35\u0c3e\u0c30\u0c02"]
+ "ఆదివారం"\
+ "సోమవారం"\
+ "మంగళవారం"\
+ "బుధవారం"\
+ "గురువారం"\
+ "శుక్రవారం"\
+ "శనివారం"]
::msgcat::mcset te MONTHS_ABBREV [list \
- "\u0c1c\u0c28\u0c35\u0c30\u0c3f"\
- "\u0c2b\u0c3f\u0c2c\u0c4d\u0c30\u0c35\u0c30\u0c3f"\
- "\u0c2e\u0c3e\u0c30\u0c4d\u0c1a\u0c3f"\
- "\u0c0f\u0c2a\u0c4d\u0c30\u0c3f\u0c32\u0c4d"\
- "\u0c2e\u0c47"\
- "\u0c1c\u0c42\u0c28\u0c4d"\
- "\u0c1c\u0c42\u0c32\u0c48"\
- "\u0c06\u0c17\u0c38\u0c4d\u0c1f\u0c41"\
- "\u0c38\u0c46\u0c2a\u0c4d\u0c1f\u0c46\u0c02\u0c2c\u0c30\u0c4d"\
- "\u0c05\u0c15\u0c4d\u0c1f\u0c4b\u0c2c\u0c30\u0c4d"\
- "\u0c28\u0c35\u0c02\u0c2c\u0c30\u0c4d"\
- "\u0c21\u0c3f\u0c38\u0c46\u0c02\u0c2c\u0c30\u0c4d"\
+ "జనవరి"\
+ "ఫిబ్రవరి"\
+ "మార్చి"\
+ "ఏప్రిల్"\
+ "మే"\
+ "జూన్"\
+ "జూలై"\
+ "ఆగస్టు"\
+ "సెప్టెంబర్"\
+ "అక్టోబర్"\
+ "నవంబర్"\
+ "డిసెంబర్"\
""]
::msgcat::mcset te MONTHS_FULL [list \
- "\u0c1c\u0c28\u0c35\u0c30\u0c3f"\
- "\u0c2b\u0c3f\u0c2c\u0c4d\u0c30\u0c35\u0c30\u0c3f"\
- "\u0c2e\u0c3e\u0c30\u0c4d\u0c1a\u0c3f"\
- "\u0c0f\u0c2a\u0c4d\u0c30\u0c3f\u0c32\u0c4d"\
- "\u0c2e\u0c47"\
- "\u0c1c\u0c42\u0c28\u0c4d"\
- "\u0c1c\u0c42\u0c32\u0c48"\
- "\u0c06\u0c17\u0c38\u0c4d\u0c1f\u0c41"\
- "\u0c38\u0c46\u0c2a\u0c4d\u0c1f\u0c46\u0c02\u0c2c\u0c30\u0c4d"\
- "\u0c05\u0c15\u0c4d\u0c1f\u0c4b\u0c2c\u0c30\u0c4d"\
- "\u0c28\u0c35\u0c02\u0c2c\u0c30\u0c4d"\
- "\u0c21\u0c3f\u0c38\u0c46\u0c02\u0c2c\u0c30\u0c4d"\
+ "జనవరి"\
+ "ఫిబ్రవరి"\
+ "మార్చి"\
+ "ఏప్రిల్"\
+ "మే"\
+ "జూన్"\
+ "జూలై"\
+ "ఆగస్టు"\
+ "సెప్టెంబర్"\
+ "అక్టోబర్"\
+ "నవంబర్"\
+ "డిసెంబర్"\
""]
}
diff --git a/library/msgs/te_in.msg b/library/msgs/te_in.msg
index 61638b5..84dd2b3 100644
--- a/library/msgs/te_in.msg
+++ b/library/msgs/te_in.msg
@@ -1,7 +1,7 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
- ::msgcat::mcset te_IN AM "\u0c2a\u0c42\u0c30\u0c4d\u0c35\u0c3e\u0c39\u0c4d\u0c28"
- ::msgcat::mcset te_IN PM "\u0c05\u0c2a\u0c30\u0c3e\u0c39\u0c4d\u0c28"
+ ::msgcat::mcset te_IN AM "పూర్వాహ్న"
+ ::msgcat::mcset te_IN PM "అపరాహ్న"
::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y"
::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P"
::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z"
diff --git a/library/msgs/th.msg b/library/msgs/th.msg
index 7486c35..edaa149 100644
--- a/library/msgs/th.msg
+++ b/library/msgs/th.msg
@@ -1,53 +1,53 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset th DAYS_OF_WEEK_ABBREV [list \
- "\u0e2d\u0e32."\
- "\u0e08."\
- "\u0e2d."\
- "\u0e1e."\
- "\u0e1e\u0e24."\
- "\u0e28."\
- "\u0e2a."]
+ "อา."\
+ "จ."\
+ "อ."\
+ "พ."\
+ "พฤ."\
+ "ศ."\
+ "ส."]
::msgcat::mcset th DAYS_OF_WEEK_FULL [list \
- "\u0e27\u0e31\u0e19\u0e2d\u0e32\u0e17\u0e34\u0e15\u0e22\u0e4c"\
- "\u0e27\u0e31\u0e19\u0e08\u0e31\u0e19\u0e17\u0e23\u0e4c"\
- "\u0e27\u0e31\u0e19\u0e2d\u0e31\u0e07\u0e04\u0e32\u0e23"\
- "\u0e27\u0e31\u0e19\u0e1e\u0e38\u0e18"\
- "\u0e27\u0e31\u0e19\u0e1e\u0e24\u0e2b\u0e31\u0e2a\u0e1a\u0e14\u0e35"\
- "\u0e27\u0e31\u0e19\u0e28\u0e38\u0e01\u0e23\u0e4c"\
- "\u0e27\u0e31\u0e19\u0e40\u0e2a\u0e32\u0e23\u0e4c"]
+ "วันอาทิตย์"\
+ "วันจันทร์"\
+ "วันอังคาร"\
+ "วันพุธ"\
+ "วันพฤหัสบดี"\
+ "วันศุกร์"\
+ "วันเสาร์"]
::msgcat::mcset th MONTHS_ABBREV [list \
- "\u0e21.\u0e04."\
- "\u0e01.\u0e1e."\
- "\u0e21\u0e35.\u0e04."\
- "\u0e40\u0e21.\u0e22."\
- "\u0e1e.\u0e04."\
- "\u0e21\u0e34.\u0e22."\
- "\u0e01.\u0e04."\
- "\u0e2a.\u0e04."\
- "\u0e01.\u0e22."\
- "\u0e15.\u0e04."\
- "\u0e1e.\u0e22."\
- "\u0e18.\u0e04."\
+ "ม.ค."\
+ "ก.พ."\
+ "มี.ค."\
+ "เม.ย."\
+ "พ.ค."\
+ "มิ.ย."\
+ "ก.ค."\
+ "ส.ค."\
+ "ก.ย."\
+ "ต.ค."\
+ "พ.ย."\
+ "ธ.ค."\
""]
::msgcat::mcset th MONTHS_FULL [list \
- "\u0e21\u0e01\u0e23\u0e32\u0e04\u0e21"\
- "\u0e01\u0e38\u0e21\u0e20\u0e32\u0e1e\u0e31\u0e19\u0e18\u0e4c"\
- "\u0e21\u0e35\u0e19\u0e32\u0e04\u0e21"\
- "\u0e40\u0e21\u0e29\u0e32\u0e22\u0e19"\
- "\u0e1e\u0e24\u0e29\u0e20\u0e32\u0e04\u0e21"\
- "\u0e21\u0e34\u0e16\u0e38\u0e19\u0e32\u0e22\u0e19"\
- "\u0e01\u0e23\u0e01\u0e0e\u0e32\u0e04\u0e21"\
- "\u0e2a\u0e34\u0e07\u0e2b\u0e32\u0e04\u0e21"\
- "\u0e01\u0e31\u0e19\u0e22\u0e32\u0e22\u0e19"\
- "\u0e15\u0e38\u0e25\u0e32\u0e04\u0e21"\
- "\u0e1e\u0e24\u0e28\u0e08\u0e34\u0e01\u0e32\u0e22\u0e19"\
- "\u0e18\u0e31\u0e19\u0e27\u0e32\u0e04\u0e21"\
+ "มกราคม"\
+ "กุมภาพันธ์"\
+ "มีนาคม"\
+ "เมษายน"\
+ "พฤษภาคม"\
+ "มิถุนายน"\
+ "กรกฎาคม"\
+ "สิงหาคม"\
+ "กันยายน"\
+ "ตุลาคม"\
+ "พฤศจิกายน"\
+ "ธันวาคม"\
""]
- ::msgcat::mcset th BCE "\u0e25\u0e17\u0e35\u0e48"
- ::msgcat::mcset th CE "\u0e04.\u0e28."
- ::msgcat::mcset th AM "\u0e01\u0e48\u0e2d\u0e19\u0e40\u0e17\u0e35\u0e48\u0e22\u0e07"
- ::msgcat::mcset th PM "\u0e2b\u0e25\u0e31\u0e07\u0e40\u0e17\u0e35\u0e48\u0e22\u0e07"
+ ::msgcat::mcset th BCE "ลที่"
+ ::msgcat::mcset th CE "ค.ศ."
+ ::msgcat::mcset th AM "ก่อนเที่ยง"
+ ::msgcat::mcset th PM "หลังเที่ยง"
::msgcat::mcset th DATE_FORMAT "%e/%m/%Y"
::msgcat::mcset th TIME_FORMAT "%k:%M:%S"
::msgcat::mcset th DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z"
diff --git a/library/msgs/tr.msg b/library/msgs/tr.msg
index 7b2ecf9..12869ee 100644
--- a/library/msgs/tr.msg
+++ b/library/msgs/tr.msg
@@ -4,27 +4,27 @@ namespace eval ::tcl::clock {
"Paz"\
"Pzt"\
"Sal"\
- "\u00c7ar"\
+ "Çar"\
"Per"\
"Cum"\
"Cmt"]
::msgcat::mcset tr DAYS_OF_WEEK_FULL [list \
"Pazar"\
"Pazartesi"\
- "Sal\u0131"\
- "\u00c7ar\u015famba"\
- "Per\u015fembe"\
+ "Salı"\
+ "Çarşamba"\
+ "Perşembe"\
"Cuma"\
"Cumartesi"]
::msgcat::mcset tr MONTHS_ABBREV [list \
"Oca"\
- "\u015eub"\
+ "Şub"\
"Mar"\
"Nis"\
"May"\
"Haz"\
"Tem"\
- "A\u011fu"\
+ "Ağu"\
"Eyl"\
"Eki"\
"Kas"\
@@ -32,17 +32,17 @@ namespace eval ::tcl::clock {
""]
::msgcat::mcset tr MONTHS_FULL [list \
"Ocak"\
- "\u015eubat"\
+ "Şubat"\
"Mart"\
"Nisan"\
- "May\u0131s"\
+ "Mayıs"\
"Haziran"\
"Temmuz"\
- "A\u011fustos"\
- "Eyl\u00fcl"\
+ "Ağustos"\
+ "Eylül"\
"Ekim"\
- "Kas\u0131m"\
- "Aral\u0131k"\
+ "Kasım"\
+ "Aralık"\
""]
::msgcat::mcset tr DATE_FORMAT "%d.%m.%Y"
::msgcat::mcset tr TIME_FORMAT "%H:%M:%S"
diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg
index 7d4c64a..42eb095 100644
--- a/library/msgs/uk.msg
+++ b/library/msgs/uk.msg
@@ -1,51 +1,51 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset uk DAYS_OF_WEEK_ABBREV [list \
- "\u043d\u0434"\
- "\u043f\u043d"\
- "\u0432\u0442"\
- "\u0441\u0440"\
- "\u0447\u0442"\
- "\u043f\u0442"\
- "\u0441\u0431"]
+ "нд"\
+ "пн"\
+ "вт"\
+ "ср"\
+ "чт"\
+ "пт"\
+ "сб"]
::msgcat::mcset uk DAYS_OF_WEEK_FULL [list \
- "\u043d\u0435\u0434\u0456\u043b\u044f"\
- "\u043f\u043e\u043d\u0435\u0434\u0456\u043b\u043e\u043a"\
- "\u0432\u0456\u0432\u0442\u043e\u0440\u043e\u043a"\
- "\u0441\u0435\u0440\u0435\u0434\u0430"\
- "\u0447\u0435\u0442\u0432\u0435\u0440"\
- "\u043f'\u044f\u0442\u043d\u0438\u0446\u044f"\
- "\u0441\u0443\u0431\u043e\u0442\u0430"]
+ "неділя"\
+ "понеділок"\
+ "вівторок"\
+ "середа"\
+ "четвер"\
+ "п'ятниця"\
+ "субота"]
::msgcat::mcset uk MONTHS_ABBREV [list \
- "\u0441\u0456\u0447"\
- "\u043b\u044e\u0442"\
- "\u0431\u0435\u0440"\
- "\u043a\u0432\u0456\u0442"\
- "\u0442\u0440\u0430\u0432"\
- "\u0447\u0435\u0440\u0432"\
- "\u043b\u0438\u043f"\
- "\u0441\u0435\u0440\u043f"\
- "\u0432\u0435\u0440"\
- "\u0436\u043e\u0432\u0442"\
- "\u043b\u0438\u0441\u0442"\
- "\u0433\u0440\u0443\u0434"\
+ "січ"\
+ "лют"\
+ "бер"\
+ "квіт"\
+ "трав"\
+ "черв"\
+ "лип"\
+ "серп"\
+ "вер"\
+ "жовт"\
+ "лист"\
+ "груд"\
""]
::msgcat::mcset uk MONTHS_FULL [list \
- "\u0441\u0456\u0447\u043d\u044f"\
- "\u043b\u044e\u0442\u043e\u0433\u043e"\
- "\u0431\u0435\u0440\u0435\u0437\u043d\u044f"\
- "\u043a\u0432\u0456\u0442\u043d\u044f"\
- "\u0442\u0440\u0430\u0432\u043d\u044f"\
- "\u0447\u0435\u0440\u0432\u043d\u044f"\
- "\u043b\u0438\u043f\u043d\u044f"\
- "\u0441\u0435\u0440\u043f\u043d\u044f"\
- "\u0432\u0435\u0440\u0435\u0441\u043d\u044f"\
- "\u0436\u043e\u0432\u0442\u043d\u044f"\
- "\u043b\u0438\u0441\u0442\u043e\u043f\u0430\u0434\u0430"\
- "\u0433\u0440\u0443\u0434\u043d\u044f"\
+ "січня"\
+ "лютого"\
+ "березня"\
+ "квітня"\
+ "травня"\
+ "червня"\
+ "липня"\
+ "серпня"\
+ "вересня"\
+ "жовтня"\
+ "листопада"\
+ "грудня"\
""]
- ::msgcat::mcset uk BCE "\u0434\u043e \u043d.\u0435."
- ::msgcat::mcset uk CE "\u043f\u0456\u0441\u043b\u044f \u043d.\u0435."
+ ::msgcat::mcset uk BCE "до н.е."
+ ::msgcat::mcset uk CE "після н.е."
::msgcat::mcset uk DATE_FORMAT "%e/%m/%Y"
::msgcat::mcset uk TIME_FORMAT "%k:%M:%S"
::msgcat::mcset uk DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z"
diff --git a/library/msgs/vi.msg b/library/msgs/vi.msg
index c98b2a6..3437ebf 100644
--- a/library/msgs/vi.msg
+++ b/library/msgs/vi.msg
@@ -9,13 +9,13 @@ namespace eval ::tcl::clock {
"Th 7"\
"CN"]
::msgcat::mcset vi DAYS_OF_WEEK_FULL [list \
- "Th\u01b0\u0301 hai"\
- "Th\u01b0\u0301 ba"\
- "Th\u01b0\u0301 t\u01b0"\
- "Th\u01b0\u0301 n\u0103m"\
- "Th\u01b0\u0301 s\u00e1u"\
- "Th\u01b0\u0301 ba\u0309y"\
- "Chu\u0309 nh\u00e2\u0323t"]
+ "Thứ hai"\
+ "Thứ ba"\
+ "Thứ tư"\
+ "Thứ năm"\
+ "Thứ sáu"\
+ "Thứ bảy"\
+ "Chủ nhật"]
::msgcat::mcset vi MONTHS_ABBREV [list \
"Thg 1"\
"Thg 2"\
@@ -31,18 +31,18 @@ namespace eval ::tcl::clock {
"Thg 12"\
""]
::msgcat::mcset vi MONTHS_FULL [list \
- "Th\u00e1ng m\u00f4\u0323t"\
- "Th\u00e1ng hai"\
- "Th\u00e1ng ba"\
- "Th\u00e1ng t\u01b0"\
- "Th\u00e1ng n\u0103m"\
- "Th\u00e1ng s\u00e1u"\
- "Th\u00e1ng ba\u0309y"\
- "Th\u00e1ng t\u00e1m"\
- "Th\u00e1ng ch\u00edn"\
- "Th\u00e1ng m\u01b0\u01a1\u0300i"\
- "Th\u00e1ng m\u01b0\u01a1\u0300i m\u00f4\u0323t"\
- "Th\u00e1ng m\u01b0\u01a1\u0300i hai"\
+ "Tháng một"\
+ "Tháng hai"\
+ "Tháng ba"\
+ "Tháng tư"\
+ "Tháng năm"\
+ "Tháng sáu"\
+ "Tháng bảy"\
+ "Tháng tám"\
+ "Tháng chín"\
+ "Tháng mười"\
+ "Tháng mười một"\
+ "Tháng mười hai"\
""]
::msgcat::mcset vi DATE_FORMAT "%d %b %Y"
::msgcat::mcset vi TIME_FORMAT "%H:%M:%S"
diff --git a/library/msgs/zh.msg b/library/msgs/zh.msg
index b799a32..9c1d08b 100644
--- a/library/msgs/zh.msg
+++ b/library/msgs/zh.msg
@@ -1,55 +1,55 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset zh DAYS_OF_WEEK_ABBREV [list \
- "\u661f\u671f\u65e5"\
- "\u661f\u671f\u4e00"\
- "\u661f\u671f\u4e8c"\
- "\u661f\u671f\u4e09"\
- "\u661f\u671f\u56db"\
- "\u661f\u671f\u4e94"\
- "\u661f\u671f\u516d"]
+ "星期日"\
+ "星期一"\
+ "星期二"\
+ "星期三"\
+ "星期四"\
+ "星期五"\
+ "星期六"]
::msgcat::mcset zh DAYS_OF_WEEK_FULL [list \
- "\u661f\u671f\u65e5"\
- "\u661f\u671f\u4e00"\
- "\u661f\u671f\u4e8c"\
- "\u661f\u671f\u4e09"\
- "\u661f\u671f\u56db"\
- "\u661f\u671f\u4e94"\
- "\u661f\u671f\u516d"]
+ "星期日"\
+ "星期一"\
+ "星期二"\
+ "星期三"\
+ "星期四"\
+ "星期五"\
+ "星期六"]
::msgcat::mcset zh MONTHS_ABBREV [list \
- "\u4e00\u6708"\
- "\u4e8c\u6708"\
- "\u4e09\u6708"\
- "\u56db\u6708"\
- "\u4e94\u6708"\
- "\u516d\u6708"\
- "\u4e03\u6708"\
- "\u516b\u6708"\
- "\u4e5d\u6708"\
- "\u5341\u6708"\
- "\u5341\u4e00\u6708"\
- "\u5341\u4e8c\u6708"\
+ "一月"\
+ "二月"\
+ "三月"\
+ "四月"\
+ "五月"\
+ "六月"\
+ "七月"\
+ "八月"\
+ "九月"\
+ "十月"\
+ "十一月"\
+ "十二月"\
""]
::msgcat::mcset zh MONTHS_FULL [list \
- "\u4e00\u6708"\
- "\u4e8c\u6708"\
- "\u4e09\u6708"\
- "\u56db\u6708"\
- "\u4e94\u6708"\
- "\u516d\u6708"\
- "\u4e03\u6708"\
- "\u516b\u6708"\
- "\u4e5d\u6708"\
- "\u5341\u6708"\
- "\u5341\u4e00\u6708"\
- "\u5341\u4e8c\u6708"\
+ "一月"\
+ "二月"\
+ "三月"\
+ "四月"\
+ "五月"\
+ "六月"\
+ "七月"\
+ "八月"\
+ "九月"\
+ "十月"\
+ "十一月"\
+ "十二月"\
""]
- ::msgcat::mcset zh BCE "\u516c\u5143\u524d"
- ::msgcat::mcset zh CE "\u516c\u5143"
- ::msgcat::mcset zh AM "\u4e0a\u5348"
- ::msgcat::mcset zh PM "\u4e0b\u5348"
- ::msgcat::mcset zh LOCALE_NUMERALS "\u3007 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03 \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c \u5341\u4e09 \u5341\u56db \u5341\u4e94 \u5341\u516d \u5341\u4e03 \u5341\u516b \u5341\u4e5d \u4e8c\u5341 \u5eff\u4e00 \u5eff\u4e8c \u5eff\u4e09 \u5eff\u56db \u5eff\u4e94 \u5eff\u516d \u5eff\u4e03 \u5eff\u516b \u5eff\u4e5d \u4e09\u5341 \u5345\u4e00 \u5345\u4e8c \u5345\u4e09 \u5345\u56db \u5345\u4e94 \u5345\u516d \u5345\u4e03 \u5345\u516b \u5345\u4e5d \u56db\u5341 \u56db\u5341\u4e00 \u56db\u5341\u4e8c \u56db\u5341\u4e09 \u56db\u5341\u56db \u56db\u5341\u4e94 \u56db\u5341\u516d \u56db\u5341\u4e03 \u56db\u5341\u516b \u56db\u5341\u4e5d \u4e94\u5341 \u4e94\u5341\u4e00 \u4e94\u5341\u4e8c \u4e94\u5341\u4e09 \u4e94\u5341\u56db \u4e94\u5341\u4e94 \u4e94\u5341\u516d \u4e94\u5341\u4e03 \u4e94\u5341\u516b \u4e94\u5341\u4e5d \u516d\u5341 \u516d\u5341\u4e00 \u516d\u5341\u4e8c \u516d\u5341\u4e09 \u516d\u5341\u56db \u516d\u5341\u4e94 \u516d\u5341\u516d \u516d\u5341\u4e03 \u516d\u5341\u516b \u516d\u5341\u4e5d \u4e03\u5341 \u4e03\u5341\u4e00 \u4e03\u5341\u4e8c \u4e03\u5341\u4e09 \u4e03\u5341\u56db \u4e03\u5341\u4e94 \u4e03\u5341\u516d \u4e03\u5341\u4e03 \u4e03\u5341\u516b \u4e03\u5341\u4e5d \u516b\u5341 \u516b\u5341\u4e00 \u516b\u5341\u4e8c \u516b\u5341\u4e09 \u516b\u5341\u56db \u516b\u5341\u4e94 \u516b\u5341\u516d \u516b\u5341\u4e03 \u516b\u5341\u516b \u516b\u5341\u4e5d \u4e5d\u5341 \u4e5d\u5341\u4e00 \u4e5d\u5341\u4e8c \u4e5d\u5341\u4e09 \u4e5d\u5341\u56db \u4e5d\u5341\u4e94 \u4e5d\u5341\u516d \u4e5d\u5341\u4e03 \u4e5d\u5341\u516b \u4e5d\u5341\u4e5d"
- ::msgcat::mcset zh LOCALE_DATE_FORMAT "\u516c\u5143%Y\u5e74%B%Od\u65e5"
- ::msgcat::mcset zh LOCALE_TIME_FORMAT "%OH\u65f6%OM\u5206%OS\u79d2"
- ::msgcat::mcset zh LOCALE_DATE_TIME_FORMAT "%A %Y\u5e74%B%Od\u65e5%OH\u65f6%OM\u5206%OS\u79d2 %z"
+ ::msgcat::mcset zh BCE "公元前"
+ ::msgcat::mcset zh CE "公元"
+ ::msgcat::mcset zh AM "上午"
+ ::msgcat::mcset zh PM "下午"
+ ::msgcat::mcset zh LOCALE_NUMERALS "〇 一 二 三 四 五 六 七 八 九 十 十一 十二 十三 十四 十五 十六 十七 十八 十九 二十 廿一 廿二 廿三 廿四 廿五 廿六 廿七 廿八 廿九 三十 卅一 卅二 卅三 卅四 卅五 卅六 卅七 卅八 卅九 四十 四十一 四十二 四十三 四十四 四十五 四十六 四十七 四十八 四十九 五十 五十一 五十二 五十三 五十四 五十五 五十六 五十七 五十八 五十九 六十 六十一 六十二 六十三 六十四 六十五 六十六 六十七 六十八 六十九 七十 七十一 七十二 七十三 七十四 七十五 七十六 七十七 七十八 七十九 八十 八十一 八十二 八十三 八十四 八十五 八十六 八十七 八十八 八十九 九十 九十一 九十二 九十三 九十四 九十五 九十六 九十七 九十八 九十九"
+ ::msgcat::mcset zh LOCALE_DATE_FORMAT "公元%Y年%B%Od日"
+ ::msgcat::mcset zh LOCALE_TIME_FORMAT "%OH时%OM分%OS秒"
+ ::msgcat::mcset zh LOCALE_DATE_TIME_FORMAT "%A %Y年%B%Od日%OH时%OM分%OS秒 %z"
}
diff --git a/library/msgs/zh_cn.msg b/library/msgs/zh_cn.msg
index d62ce77..da2869a 100644
--- a/library/msgs/zh_cn.msg
+++ b/library/msgs/zh_cn.msg
@@ -2,6 +2,6 @@
namespace eval ::tcl::clock {
::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e"
::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S"
- ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I\u65f6%M\u5206%S\u79d2"
+ ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I时%M分%S秒"
::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z"
}
diff --git a/library/msgs/zh_hk.msg b/library/msgs/zh_hk.msg
index badb1dd..7f1b181 100644
--- a/library/msgs/zh_hk.msg
+++ b/library/msgs/zh_hk.msg
@@ -1,28 +1,28 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \
- "\u65e5"\
- "\u4e00"\
- "\u4e8c"\
- "\u4e09"\
- "\u56db"\
- "\u4e94"\
- "\u516d"]
+ "日"\
+ "一"\
+ "二"\
+ "三"\
+ "四"\
+ "五"\
+ "六"]
::msgcat::mcset zh_HK MONTHS_ABBREV [list \
- "1\u6708"\
- "2\u6708"\
- "3\u6708"\
- "4\u6708"\
- "5\u6708"\
- "6\u6708"\
- "7\u6708"\
- "8\u6708"\
- "9\u6708"\
- "10\u6708"\
- "11\u6708"\
- "12\u6708"\
+ "1月"\
+ "2月"\
+ "3月"\
+ "4月"\
+ "5月"\
+ "6月"\
+ "7月"\
+ "8月"\
+ "9月"\
+ "10月"\
+ "11月"\
+ "12月"\
""]
- ::msgcat::mcset zh_HK DATE_FORMAT "%Y\u5e74%m\u6708%e\u65e5"
+ ::msgcat::mcset zh_HK DATE_FORMAT "%Y年%m月%e日"
::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S"
- ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y\u5e74%m\u6708%e\u65e5 %P%I:%M:%S %z"
+ ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y年%m月%e日 %P%I:%M:%S %z"
}
diff --git a/library/msgs/zh_sg.msg b/library/msgs/zh_sg.msg
index a2f3e39..690edf7 100644
--- a/library/msgs/zh_sg.msg
+++ b/library/msgs/zh_sg.msg
@@ -1,7 +1,7 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
- ::msgcat::mcset zh_SG AM "\u4e0a\u5348"
- ::msgcat::mcset zh_SG PM "\u4e2d\u5348"
+ ::msgcat::mcset zh_SG AM "上午"
+ ::msgcat::mcset zh_SG PM "中午"
::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y"
::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z"
diff --git a/library/msgs/zh_tw.msg b/library/msgs/zh_tw.msg
index e0796b1..17a6dd7 100644
--- a/library/msgs/zh_tw.msg
+++ b/library/msgs/zh_tw.msg
@@ -1,7 +1,7 @@
# created by tools/loadICU.tcl -- do not edit
namespace eval ::tcl::clock {
- ::msgcat::mcset zh_TW BCE "\u6c11\u570b\u524d"
- ::msgcat::mcset zh_TW CE "\u6c11\u570b"
+ ::msgcat::mcset zh_TW BCE "民國前"
+ ::msgcat::mcset zh_TW CE "民國"
::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e"
::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z"
diff --git a/library/package.tcl b/library/package.tcl
index 4ccc20a..2d72a7c 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,8 +3,8 @@
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1998 Sun Microsystems, Inc.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 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.
@@ -409,6 +409,7 @@ proc pkg_mkIndex {args} {
}
set f [open [file join $dir pkgIndex.tcl] w]
+ fconfigure $f -encoding utf-8 -translation lf
puts $f $index
close $f
}
@@ -491,12 +492,16 @@ proc tclPkgUnknown {name args} {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
- tclLog "error reading package index file $file: $msg"
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
+ tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
}
@@ -509,11 +514,15 @@ proc tclPkgUnknown {name args} {
# safe interps usually don't have "file exists",
if {([interp issafe] || [file exists $file])} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
@@ -594,11 +603,15 @@ proc tcl::MacOSXPkgUnknown {original name args} {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
try {
- source $file
+ ::tcl::Pkg::source $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
} on error msg {
+ if {[regexp {version conflict for package} $msg]} {
+ # In case of version conflict, silently ignore
+ continue
+ }
tclLog "error reading package index file $file: $msg"
} on ok {} {
set procdDirs($dir) 1
diff --git a/library/parray.tcl b/library/parray.tcl
index a9c2cb1..984bf47 100644
--- a/library/parray.tcl
+++ b/library/parray.tcl
@@ -1,8 +1,8 @@
# parray:
# Print the contents of a global array on stdout.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/library/readfile.tcl b/library/readfile.tcl
new file mode 100644
index 0000000..c1d5b84
--- /dev/null
+++ b/library/readfile.tcl
@@ -0,0 +1,23 @@
+# readFile:
+# Read the contents of a file.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc readFile {filename {mode text}} {
+ # Parse the arguments
+ set MODES {binary text}
+ set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]]
+ set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode]
+
+ # Read the file
+ set f [open $filename [dict get {text r binary rb} $mode]]
+ try {
+ return [read $f]
+ } finally {
+ close $f
+ }
+}
diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
deleted file mode 100644
index 6603e3e..0000000
--- a/library/reg/pkgIndex.tcl
+++ /dev/null
@@ -1,9 +0,0 @@
-if {![package vsatisfies [package provide Tcl] 8.5]} return
-if {[info sharedlibextension] != ".dll"} return
-if {[::tcl::pkgconfig get debug]} {
- package ifneeded registry 1.3.5 \
- [list load [file join $dir tclreg13g.dll] Registry]
-} else {
- package ifneeded registry 1.3.5 \
- [list load [file join $dir tclreg13.dll] Registry]
-}
diff --git a/library/registry/pkgIndex.tcl b/library/registry/pkgIndex.tcl
new file mode 100644
index 0000000..edb4729
--- /dev/null
+++ b/library/registry/pkgIndex.tcl
@@ -0,0 +1,9 @@
+if {![package vsatisfies [package provide Tcl] 8.5-]} return
+if {[info sharedlibextension] != ".dll"} return
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+ package ifneeded registry 1.3.7 \
+ [list load [file join $dir tcl9registry13.dll] Registry]
+} else {
+ package ifneeded registry 1.3.7 \
+ [list load [file join $dir tclregistry13.dll] Registry]
+}
diff --git a/library/safe.tcl b/library/safe.tcl
index 1eafec0..b84d2f5 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -1,13 +1,13 @@
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
-# It implements a virtual path mechanism to hide the real pathnames from the
+# It implements a virtual path mecanism to hide the real pathnames from the
# child. It runs in a parent interpreter and sets up data structure and
# aliases that will be invoked when used from a child interpreter.
#
# See the safe.n man page for details.
#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -78,20 +78,32 @@ proc ::safe::InterpNested {} {
# Interface/entry point function and front end for "Create"
proc ::safe::interpCreate {args} {
+ variable AutoPathSync
+ if {$AutoPathSync} {
+ set autoPath {}
+ }
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
- RejectExcessColons $slave
- InterpCreate $slave $accessPath \
- [InterpStatics] [InterpNested] $deleteHook
+ RejectExcessColons $child
+
+ set withAutoPath [::tcl::OptProcArgGiven -autoPath]
+ InterpCreate $child $accessPath \
+ [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}
proc ::safe::interpInit {args} {
+ variable AutoPathSync
+ if {$AutoPathSync} {
+ set autoPath {}
+ }
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
- if {![::interp exists $slave]} {
- return -code error "\"$slave\" is not an interpreter"
+ if {![::interp exists $child]} {
+ return -code error "\"$child\" is not an interpreter"
}
- RejectExcessColons $slave
- InterpInit $slave $accessPath \
- [InterpStatics] [InterpNested] $deleteHook
+ RejectExcessColons $child
+
+ set withAutoPath [::tcl::OptProcArgGiven -autoPath]
+ InterpInit $child $accessPath \
+ [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath
}
# Check that the given child is "one of us"
@@ -117,6 +129,7 @@ proc ::safe::CheckInterp {child} {
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
+ variable AutoPathSync
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
@@ -124,19 +137,24 @@ proc ::safe::interpConfigure {args} {
# we know that "child" is our given argument because it also
# checks for the "-help" option.
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
- CheckInterp $slave
- namespace upvar ::safe [VarName $slave] state
+ CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
- return [join [list \
+ set TMP [list \
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
- [list -deleteHook $state(cleanupHook)]]]
+ [list -deleteHook $state(cleanupHook)] \
+ ]
+ if {!$AutoPathSync} {
+ lappend TMP [list -autoPath $state(auto_path)]
+ }
+ return [join $TMP]
}
2 {
# If we have exactly 2 arguments the semantic is a "configure
# get"
- lassign $args slave arg
+ lassign $args child arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
@@ -147,8 +165,8 @@ proc ::safe::interpConfigure {args} {
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
- CheckInterp $slave
- namespace upvar ::safe [VarName $slave] state
+ CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
@@ -156,6 +174,13 @@ proc ::safe::interpConfigure {args} {
-accessPath {
return [list -accessPath $state(access_path)]
}
+ -autoPath {
+ if {$AutoPathSync} {
+ return -code error "unknown flag $name (bug)"
+ } else {
+ return [list -autoPath $state(auto_path)]
+ }
+ }
-statics {
return [list -statics $state(staticsok)]
}
@@ -188,8 +213,8 @@ proc ::safe::interpConfigure {args} {
# Otherwise we want to parse the arguments like init and
# create did
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
- CheckInterp $slave
- namespace upvar ::safe [VarName $slave] state
+ CheckInterp $child
+ namespace upvar ::safe [VarName $child] state
# Get the current (and not the default) values of whatever has
# not been given:
@@ -199,6 +224,12 @@ proc ::safe::interpConfigure {args} {
} else {
set doreset 1
}
+ if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} {
+ set autoPath $state(auto_path)
+ } elseif {$AutoPathSync} {
+ set autoPath {}
+ } else {
+ }
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
@@ -218,21 +249,23 @@ proc ::safe::interpConfigure {args} {
if {![::tcl::OptProcArgGiven -deleteHook]} {
set deleteHook $state(cleanupHook)
}
- # we can now reconfigure :
- InterpSetConfig $slave $accessPath $statics $nested $deleteHook
- # auto_reset the child (to completely synch the new access_path)
+ # Now reconfigure
+ set withAutoPath [::tcl::OptProcArgGiven -autoPath]
+ InterpSetConfig $child $accessPath $statics $nested $deleteHook $autoPath $withAutoPath
+
+ # auto_reset the child (to completely sync the new access_path) tests safe-9.8 safe-9.9
if {$doreset} {
- if {[catch {::interp eval $slave {auto_reset}} msg]} {
- Log $slave "auto_reset failed: $msg"
+ if {[catch {::interp eval $child {auto_reset}} msg]} {
+ Log $child "auto_reset failed: $msg"
} else {
- Log $slave "successful auto_reset" NOTICE
+ Log $child "successful auto_reset" NOTICE
}
# Sync the paths used to search for Tcl modules.
- ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]}
- if {[llength $state(tm_path_slave)] > 0} {
- ::interp eval $slave [list \
- ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
+ ::interp eval $child {tcl::tm::path remove {*}[tcl::tm::list]}
+ if {[llength $state(tm_path_child)] > 0} {
+ ::interp eval $child [list \
+ ::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
}
# Remove stale "package ifneeded" data for non-loaded packages.
@@ -240,9 +273,9 @@ proc ::safe::interpConfigure {args} {
# data from "package provide" as well as "package ifneeded".
# - This is OK because the script cannot reload any version of
# the package unless it first does "package forget".
- foreach pkg [::interp eval $slave {package names}] {
- if {[::interp eval $slave [list package provide $pkg]] eq ""} {
- ::interp eval $slave [list package forget $pkg]
+ foreach pkg [::interp eval $child {package names}] {
+ if {[::interp eval $child [list package provide $pkg]] eq ""} {
+ ::interp eval $child [list package forget $pkg]
}
}
}
@@ -270,10 +303,11 @@ proc ::safe::interpConfigure {args} {
# Optional Arguments :
# + child name : if empty, generated name will be used
# + access_path: path list controlling where load/source can occur,
-# if empty: the parent auto_path will be used.
+# if empty: the parent auto_path and its subdirectories will be
+# used.
# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx)
# if 1 :static packages are ok.
-# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub)
+# + nestedok : flag, if 0 :no loading to sub-sub interps (load xx xx sub)
# if 1 : multiple levels are ok.
# use the full name and no indent so auto_mkIndex can find us
@@ -283,6 +317,8 @@ proc ::safe::InterpCreate {
staticsok
nestedok
deletehook
+ autoPath
+ withAutoPath
} {
# Create the child.
# If evaluated in ::safe, the interpreter command for foo is ::foo;
@@ -296,20 +332,25 @@ proc ::safe::InterpCreate {
Log $child "Created" NOTICE
# Initialize it. (returns child name)
- InterpInit $child $access_path $staticsok $nestedok $deletehook
+ InterpInit $child $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath
}
#
# InterpSetConfig (was setAccessPath) :
-# Sets up child virtual auto_path and corresponding structure within
+# Sets up child virtual access path and corresponding structure within
# the parent. Also sets the tcl_library in the child to be the first
# directory in the path.
# NB: If you change the path after the child has been initialized you
# probably need to call "auto_reset" in the child in order that it gets
# the right auto_index() array values.
+#
+# It is the caller's responsibility, if it supplies a non-empty value for
+# access_path, to make the first directory in the path suitable for use as
+# tcl_library, and (if ![setSyncMode]), to set the child's ::auto_path.
-proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
+proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook autoPath withAutoPath} {
global auto_path
+ variable AutoPathSync
# determine and store the access path if empty
if {$access_path eq ""} {
@@ -322,24 +363,35 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
# not found, add it.
set access_path [linsert $access_path 0 [info library]]
Log $child "tcl_library was not in auto_path,\
- added it to slave's access_path" NOTICE
+ added it to child's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [linsert \
[lreplace $access_path $where $where] \
0 [info library]]
Log $child "tcl_libray was not in first in auto_path,\
- moved it to front of slave's access_path" NOTICE
+ moved it to front of child's access_path" NOTICE
}
+ set raw_auto_path $access_path
+
# Add 1st level subdirs (will searched by auto loading from tcl
# code in the child using glob and thus fail, so we add them here
# so by default it works the same).
set access_path [AddSubDirs $access_path]
+ } else {
+ set raw_auto_path $autoPath
+ }
+
+ if {$withAutoPath} {
+ set raw_auto_path $autoPath
}
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
+ if {!$AutoPathSync} {
+ Log $child "Setting auto_path=($raw_auto_path)" NOTICE
+ }
namespace upvar ::safe [VarName $child] state
@@ -347,25 +399,38 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
# build new one
# Extend the access list with the paths used to look for Tcl Modules.
# We save the virtual form separately as well, as syncing it with the
- # child has to be deferred until the necessary commands are present for
+ # child has to be defered until the necessary commands are present for
# setup.
-
set norm_access_path {}
- set slave_access_path {}
+ set child_access_path {}
set map_access_path {}
set remap_access_path {}
- set slave_tm_path {}
+ set child_tm_path {}
set i 0
foreach dir $access_path {
set token [PathToken $i]
- lappend slave_access_path $token
+ lappend child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
incr i
}
+ # Set the child auto_path to a tokenized raw_auto_path.
+ # Silently ignore any directories that are not in the access path.
+ # If [setSyncMode], SyncAccessPath will overwrite this value with the
+ # full access path.
+ # If ![setSyncMode], Safe Base code will not change this value.
+ set tokens_auto_path {}
+ foreach dir $raw_auto_path {
+ if {[dict exists $remap_access_path $dir]} {
+ lappend tokens_auto_path [dict get $remap_access_path $dir]
+ }
+ }
+ ::interp eval $child [list set auto_path $tokens_auto_path]
+
+ # Add the tcl::tm directories to the access path.
set morepaths [::tcl::tm::list]
set firstpass 1
while {[llength $morepaths]} {
@@ -377,25 +442,25 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
if {$firstpass} {
- # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
# Later passes handle subdirectories, which belong in the
# access path but not in the module path.
- lappend slave_tm_path [dict get $remap_access_path $dir]
+ lappend child_tm_path [dict get $remap_access_path $dir]
}
continue
}
set token [PathToken $i]
lappend access_path $dir
- lappend slave_access_path $token
+ lappend child_access_path $token
lappend map_access_path $token $dir
lappend remap_access_path $dir $token
lappend norm_access_path [file normalize $dir]
if {$firstpass} {
- # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path.
+ # $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
# Later passes handle subdirectories, which belong in the
# access path but not in the module path.
- lappend slave_tm_path $token
+ lappend child_tm_path $token
}
incr i
@@ -414,21 +479,48 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} {
set state(access_path,map) $map_access_path
set state(access_path,remap) $remap_access_path
set state(access_path,norm) $norm_access_path
- set state(access_path,slave) $slave_access_path
- set state(tm_path_slave) $slave_tm_path
+ set state(access_path,child) $child_access_path
+ set state(tm_path_child) $child_tm_path
set state(staticsok) $staticsok
set state(nestedok) $nestedok
set state(cleanupHook) $deletehook
+ if {!$AutoPathSync} {
+ set state(auto_path) $raw_auto_path
+ }
+
SyncAccessPath $child
return
}
+
+#
+# DetokPath:
+# Convert tokens to directories where possible.
+# Leave undefined tokens unconverted. They are
+# nonsense in both the child and the parent.
+#
+proc ::safe::DetokPath {child tokenPath} {
+ namespace upvar ::safe [VarName $child] state
+
+ set childPath {}
+ foreach token $tokenPath {
+ if {[dict exists $state(access_path,map) $token]} {
+ lappend childPath [dict get $state(access_path,map) $token]
+ } else {
+ lappend childPath $token
+ }
+ }
+ return $childPath
+}
+
#
#
-# FindInAccessPath:
+# interpFindInAccessPath:
# Search for a real directory and returns its virtual Id (including the
# "$")
+#
+# When debugging, use TranslatePath for the inverse operation.
proc ::safe::interpFindInAccessPath {child path} {
CheckInterp $child
namespace upvar ::safe [VarName $child] state
@@ -440,6 +532,7 @@ proc ::safe::interpFindInAccessPath {child path} {
return [dict get $state(access_path,remap) $path]
}
+
#
# addToAccessPath:
# add (if needed) a real directory to access path and return its
@@ -458,7 +551,7 @@ proc ::safe::interpAddToAccessPath {child path} {
set token [PathToken [llength $state(access_path)]]
lappend state(access_path) $path
- lappend state(access_path,slave) $token
+ lappend state(access_path,child) $token
lappend state(access_path,map) $token $path
lappend state(access_path,remap) $path $token
lappend state(access_path,norm) [file normalize $path]
@@ -476,9 +569,11 @@ proc ::safe::InterpInit {
staticsok
nestedok
deletehook
+ autoPath
+ withAutoPath
} {
# Configure will generate an access_path when access_path is empty.
- InterpSetConfig $child $access_path $staticsok $nestedok $deletehook
+ InterpSetConfig $child $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath
# NB we need to add [namespace current], aliases are always absolute
# paths.
@@ -494,37 +589,35 @@ proc ::safe::InterpInit {
foreach {command alias} {
source AliasSource
load AliasLoad
- encoding AliasEncoding
exit interpDelete
glob AliasGlob
} {
::interp alias $child $command {} [namespace current]::$alias $child
}
+ # UGLY POINT! These commands are safe (they're ensembles with unsafe
+ # subcommands), but is assumed to not be by existing policies so it is
+ # hidden by default. Hack it...
+ foreach command {encoding file} {
+ ::interp alias $child $command {} interp invokehidden $child $command
+ }
+
# This alias lets the child have access to a subset of the 'file'
# command functionality.
- ::interp expose $child file
foreach subcommand {dirname extension rootname tail} {
::interp alias $child ::tcl::file::$subcommand {} \
::safe::AliasFileSubcommand $child $subcommand
}
- foreach subcommand {
- atime attributes copy delete executable exists isdirectory isfile
- link lstat mtime mkdir nativename normalize owned readable readlink
- rename size stat tempfile type volumes writable
- } {
- ::interp alias $child ::tcl::file::$subcommand {} \
- ::safe::BadSubcommand $child file $subcommand
- }
+
+ # Subcommand of 'encoding' that has special handling; [encoding system] is
+ # OK provided it has no other arguments passed to it.
+ ::interp alias $child ::tcl::encoding::system {} \
+ ::safe::AliasEncodingSystem $child
# Subcommands of info
- foreach {subcommand alias} {
- nameofexecutable AliasExeName
- } {
- ::interp alias $child ::tcl::info::$subcommand \
- {} [namespace current]::$alias $child
- }
+ ::interp alias $child ::tcl::info::nameofexecutable {} \
+ ::safe::AliasExeName $child
# The allowed child variables already have been set by Tcl_MakeSafe(3)
@@ -535,22 +628,22 @@ proc ::safe::InterpInit {
source [file join $tcl_library init.tcl]
}} msg opt]} {
Log $child "can't source init.tcl ($msg)"
- return -options $opt "can't source init.tcl into slave $child ($msg)"
+ return -options $opt "can't source init.tcl into child $child ($msg)"
}
if {[catch {::interp eval $child {
source [file join $tcl_library tm.tcl]
}} msg opt]} {
Log $child "can't source tm.tcl ($msg)"
- return -options $opt "can't source tm.tcl into slave $child ($msg)"
+ return -options $opt "can't source tm.tcl into child $child ($msg)"
}
# Sync the paths used to search for Tcl modules. This can be done only
# now, after tm.tcl was loaded.
namespace upvar ::safe [VarName $child] state
- if {[llength $state(tm_path_slave)] > 0} {
+ if {[llength $state(tm_path_child)] > 0} {
::interp eval $child [list \
- ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]]
+ ::tcl::tm::add {*}[lreverse $state(tm_path_child)]]
}
return $child
}
@@ -658,7 +751,7 @@ proc ::safe::setLogCmd {args} {
proc ::safe::Log {child msg {type ERROR}} {
variable Log
- {*}$Log "$type for slave $child : $msg"
+ {*}$Log "$type for child $child : $msg"
return
}
}
@@ -667,24 +760,28 @@ proc ::safe::setLogCmd {args} {
# ------------------- END OF PUBLIC METHODS ------------
#
-# Sets the child auto_path to the parent recorded value. Also sets
-# tcl_library to the first token of the virtual path.
+# Sets the child auto_path to its recorded access path. Also sets
+# tcl_library to the first token of the access path.
#
proc ::safe::SyncAccessPath {child} {
+ variable AutoPathSync
namespace upvar ::safe [VarName $child] state
- set slave_access_path $state(access_path,slave)
- ::interp eval $child [list set auto_path $slave_access_path]
+ set child_access_path $state(access_path,child)
+ if {$AutoPathSync} {
+ ::interp eval $child [list set auto_path $child_access_path]
- Log $child "auto_path in $child has been set to $slave_access_path"\
- NOTICE
+ Log $child "auto_path in $child has been set to $child_access_path"\
+ NOTICE
+ }
# This code assumes that info library is the first element in the
- # list of auto_path's. See -> InterpSetConfig for the code which
+ # list of access path's. See -> InterpSetConfig for the code which
# ensures this condition.
::interp eval $child [list \
- set tcl_library [lindex $slave_access_path 0]]
+ set tcl_library [lindex $child_access_path 0]]
+ return
}
# Returns the virtual token for directory number N.
@@ -744,6 +841,7 @@ proc ::safe::AliasFileSubcommand {child subcommand name} {
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {child args} {
+ variable AutoPathSync
Log $child "GLOB ! $args" NOTICE
set cmd {}
set at 0
@@ -791,6 +889,7 @@ proc ::safe::AliasGlob {child args} {
-* {
Log $child "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
+ # unsafe/unnecessary options rejected: -path
}
default {
break
@@ -825,7 +924,7 @@ proc ::safe::AliasGlob {child args} {
return -code error "permission denied"
}
- # Apply the -join semantics ourselves.
+ # Apply the -join semantics ourselves (hence -join not copied to $cmd)
if {$got(-join)} {
set args [lreplace $args $at end [join [lrange $args $at end] "/"]]
}
@@ -939,7 +1038,7 @@ proc ::safe::AliasSource {child args} {
}
} else {
set at 0
- set encoding {}
+ set encoding utf-8
}
if {$argc != 1} {
set msg "wrong # args: should be \"source ?-encoding E? fileName\""
@@ -982,10 +1081,7 @@ proc ::safe::AliasSource {child args} {
set replacementMsg "script error"
set code [catch {
set f [open $realfile]
- fconfigure $f -eofchar "\032 {}"
- if {$encoding ne ""} {
- fconfigure $f -encoding $encoding
- }
+ fconfigure $f -encoding $encoding -eofchar "\x1A {}"
set contents [read $f]
close $f
::interp eval $child [list info script $file]
@@ -1014,8 +1110,8 @@ proc ::safe::AliasLoad {child file args} {
return -code error $msg
}
- # package name (can be empty if file is not).
- set package [lindex $args 0]
+ # prefix (can be empty if file is not).
+ set prefix [lindex $args 0]
namespace upvar ::safe [VarName $child] state
@@ -1027,23 +1123,23 @@ proc ::safe::AliasLoad {child file args} {
# authorize that.
if {!$state(nestedok)} {
Log $child "loading to a sub interp (nestedok)\
- disabled (trying to load $package to $target)"
+ disabled (trying to load $prefix to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {$file eq ""} {
- # static package loading
- if {$package eq ""} {
- set msg "load error: empty filename and no package name"
+ # static loading
+ if {$prefix eq ""} {
+ set msg "load error: empty filename and no prefix"
Log $child $msg
return -code error $msg
}
if {!$state(staticsok)} {
- Log $child "static packages loading disabled\
- (trying to load $package to $target)"
- return -code error "permission denied (static package)"
+ Log $child "static loading disabled\
+ (trying to load $prefix to $target)"
+ return -code error "permission denied (static library)"
}
} else {
# file loading
@@ -1066,10 +1162,10 @@ proc ::safe::AliasLoad {child file args} {
}
try {
- return [::interp invokehidden $child load $file $package $target]
+ return [::interp invokehidden $child load $file $prefix $target]
} on error msg {
- # Some packages return no error message.
- set msg0 "load of binary library for package $package failed"
+ # Some libraries return no error message.
+ set msg0 "load of library for prefix $prefix failed"
if {$msg eq {}} {
set msg $msg0
} else {
@@ -1131,16 +1227,13 @@ proc ::safe::BadSubcommand {child command subcommand args} {
return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
-# AliasEncoding is the target of the "encoding" alias in safe interpreters.
-
-proc ::safe::AliasEncoding {child option args} {
- # Note that [encoding dirs] is not supported in safe children at all
- set subcommands {convertfrom convertto names system}
+# AliasEncodingSystem is the target of the "encoding system" alias in safe
+# interpreters.
+proc ::safe::AliasEncodingSystem {child args} {
try {
- set option [tcl::prefix match -error [list -level 1 -errorcode \
- [list TCL LOOKUP INDEX option $option]] $subcommands $option]
- # Special case: [encoding system] ok, but [encoding system foo] not
- if {$option eq "system" && [llength $args]} {
+ # Must not pass extra arguments; safe interpreters may not set the
+ # system encoding but they may read it.
+ if {[llength $args]} {
return -code error -errorcode {TCL WRONGARGS} \
"wrong # args: should be \"encoding system\""
}
@@ -1148,7 +1241,7 @@ proc ::safe::AliasEncoding {child option args} {
Log $child $msg
return -options $options $msg
}
- tailcall ::interp invokehidden $child encoding $option {*}$args
+ tailcall ::interp invokehidden $child tcl:encoding:system
}
# Various minor hiding of platform features. [Bug 2913625]
@@ -1215,29 +1308,34 @@ proc ::safe::Setup {} {
# Setup the arguments parsing
#
####
+ variable AutoPathSync
# Share the descriptions
- set temp [::tcl::OptKeyRegister {
- {-accessPath -list {} "access path for the slave"}
+ set OptList {
+ {-accessPath -list {} "access path for the child"}
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
{-nested false "nested loading"}
{-deleteHook -script {} "delete hook"}
- }]
+ }
+ if {!$AutoPathSync} {
+ lappend OptList {-autoPath -list {} "::auto_path for the child"}
+ }
+ set temp [::tcl::OptKeyRegister $OptList]
- # create case (slave is optional)
+ # create case (child is optional)
::tcl::OptKeyRegister {
- {?slave? -name {} "name of the slave (optional)"}
+ {?child? -name {} "name of the child (optional)"}
} ::safe::interpCreate
# adding the flags sub programs to the command program (relying on Opt's
# internal implementation details)
lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
- # init and configure (slave is needed)
+ # init and configure (child is needed)
::tcl::OptKeyRegister {
- {slave -name {} "name of the slave"}
+ {child -name {} "name of the child"}
} ::safe::interpIC
# adding the flags sub programs to the command program (relying on Opt's
@@ -1261,8 +1359,72 @@ proc ::safe::Setup {} {
return
}
+# Accessor method for ::safe::AutoPathSync
+# Usage: ::safe::setSyncMode ?newValue?
+# Respond to changes by calling Setup again, preserving any
+# caller-defined logging. This allows complete equivalence with
+# prior Safe Base behavior if AutoPathSync is true.
+#
+# >>> WARNING <<<
+#
+# DO NOT CHANGE AutoPathSync EXCEPT BY THIS COMMAND - IT IS VITAL THAT WHENEVER
+# THE VALUE CHANGES, THE EXISTING PARSE TOKENS ARE DELETED AND Setup IS CALLED
+# AGAIN.
+# (The initialization of AutoPathSync at the end of this file is acceptable
+# because Setup has not yet been called.)
+
+proc ::safe::setSyncMode {args} {
+ variable AutoPathSync
+
+ if {[llength $args] == 0} {
+ } elseif {[llength $args] == 1} {
+ set newValue [lindex $args 0]
+ if {![string is boolean -strict $newValue]} {
+ return -code error "new value must be a valid boolean"
+ }
+ set args [expr {$newValue && $newValue}]
+ if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
+ return -code error \
+ "cannot set new value while Safe Base child interpreters exist"
+ }
+ if {($args != $AutoPathSync)} {
+ set AutoPathSync {*}$args
+ ::tcl::OptKeyDelete ::safe::interpCreate
+ ::tcl::OptKeyDelete ::safe::interpIC
+ set TmpLog [setLogCmd]
+ Setup
+ setLogCmd $TmpLog
+ }
+ } else {
+ set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
+ return -code error $msg
+ }
+
+ return $AutoPathSync
+}
+
namespace eval ::safe {
- # internal variables
+ # internal variables (must not begin with "S")
+
+ # AutoPathSync
+ #
+ # Set AutoPathSync to 0 to give a child's ::auto_path the same meaning as
+ # for an unsafe interpreter: the package command will search its directories
+ # and first-level subdirectories for pkgIndex.tcl files; the auto-loader
+ # will search its directories for tclIndex files. The access path and
+ # module path will be maintained as separate values, and ::auto_path will
+ # not be updated when the user calls ::safe::interpAddToAccessPath to add to
+ # the access path. If the user specifies an access path when calling
+ # interpCreate, interpInit or interpConfigure, it is the user's
+ # responsibility to define the child's auto_path. If these commands are
+ # called with no (or empty) access path, the child's auto_path will be set
+ # to a tokenized form of the parent's auto_path, and these directories and
+ # their first-level subdirectories will be added to the access path.
+ #
+ # Set to 1 for "traditional" behavior: a child's entire access path and
+ # module path are copied to its ::auto_path, which is updated whenever
+ # the user calls ::safe::interpAddToAccessPath to add to the access path.
+ variable AutoPathSync 1
# Log command, set via 'setLogCmd'. Logging is disabled when empty.
variable Log {}
@@ -1277,13 +1439,24 @@ namespace eval ::safe {
#
# access_path : List of paths accessible to the child.
# access_path,norm : Ditto, in normalized form.
- # access_path,slave : Ditto, as the path tokens as seen by the child.
+ # access_path,child : Ditto, as the path tokens as seen by the child.
# access_path,map : dict ( token -> path )
# access_path,remap : dict ( path -> token )
- # tm_path_slave : List of TM root directories, as tokens seen by the child.
+ # auto_path : List of paths requested by the caller as child's ::auto_path.
+ # tm_path_child : List of TM root directories, as tokens seen by the child.
# staticsok : Value of option -statics
# nestedok : Value of option -nested
# cleanupHook : Value of option -deleteHook
+ #
+ # In principle, the child can change its value of ::auto_path -
+ # - a package might add a path (that is already in the access path) for
+ # access to tclIndex files;
+ # - the script might remove some elements of the auto_path.
+ # However, this is really the business of the parent, and the auto_path will
+ # be reset whenever the token mapping changes (i.e. when option -accessPath is
+ # used to change the access path).
+ # -autoPath is now stored in the array and is no longer obtained from
+ # the child.
}
::safe::Setup
diff --git a/library/tclIndex b/library/tclIndex
index 0409d9b..8fd5a89 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -7,72 +7,73 @@
# element name is the name of a command and the value is
# a script that loads the command.
-set auto_index(auto_reset) [list source [file join $dir auto.tcl]]
-set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]]
-set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]]
-set auto_index(history) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]]
-set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]]
-set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]]
-set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]]
-set auto_index(::pkg::create) [list source [file join $dir package.tcl]]
-set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
-set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
-set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
-set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
-set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
-set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
-set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
-if {[namespace exists ::tcl::unsupported]} {
- set auto_index(timerate) {namespace import ::tcl::unsupported::timerate}
-}
+set auto_index(auto_reset) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(tcl_findLibrary) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(auto_mkindex_old) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::init) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::cleanup) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::mkindex) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::hook) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(foreachLine) [list ::tcl::Pkg::source [file join $dir foreachline.tcl]]
+set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistClear) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistInfo) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistRedo) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistIndex) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistEvent) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(::tcl::HistChange) [list ::tcl::Pkg::source [file join $dir history.tcl]]
+set auto_index(pkg_mkIndex) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(tclPkgSetup) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]]
+set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]]
+set auto_index(readFile) [list ::tcl::Pkg::source [file join $dir readfile.tcl]]
+set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::CheckInterp) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpConfigure) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpSetConfig) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpFindInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpAddToAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::InterpInit) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AddSubDirs) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::interpDelete) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::setLogCmd) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::SyncAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::PathToken) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::TranslatePath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::Log) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::CheckFileName) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasGlob) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasSource) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasLoad) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::FileInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(::safe::setSyncMode) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
+set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(writeFile) [list ::tcl::Pkg::source [file join $dir writefile.tcl]]
+set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::Defaults) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::UnknownHandler) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::roots) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::path) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index 18b05e5..9903e32 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -9,4 +9,4 @@
# 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]]
+package ifneeded tcltest 2.5.6 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index d3e9ea4..22a4dfd 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,13 +22,14 @@ 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
+ variable Version 2.5.6
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
+ variable fullutf [package vsatisfies $version 8.7-]
##### Export the public tcltest procs; several categories
#
@@ -400,7 +401,7 @@ namespace eval tcltest {
default {
set outputChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $outputChannel -encoding utf-8
+ fconfigure $outputChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
@@ -447,7 +448,7 @@ namespace eval tcltest {
default {
set errorChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $errorChannel -encoding utf-8
+ fconfigure $errorChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
@@ -792,7 +793,7 @@ namespace eval tcltest {
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $tmp -encoding utf-8
+ fconfigure $tmp -profile tcl8 -encoding utf-8
}
loadScript [read $tmp]
close $tmp
@@ -1134,6 +1135,38 @@ proc tcltest::SafeFetch {n1 n2 op} {
}
}
+# tcltest::Asciify --
+#
+# Transforms the passed string to contain only printable ascii characters.
+# Useful for printing to terminals. Non-printables are mapped to
+# \x, \u or \U sequences.
+#
+# Arguments:
+# s - string to transform
+#
+# Results:
+# The transformed strings
+#
+# Side effects:
+# None.
+
+proc tcltest::Asciify {s} {
+ variable fullutf
+ set print ""
+ foreach c [split $s ""] {
+ if {[string is print $c] && (($c <= "\x7E") || ($c == "\n"))} {
+ append print $c
+ } elseif {$c < "\u0100"} {
+ append print \\x[format %02X [scan $c %c]]
+ } elseif {$fullutf && ($c >= "\U10000")} {
+ append print \\U[format %08X [scan $c %c]]
+ } else {
+ append print \\u[format %04X [scan $c %c]]
+ }
+ }
+ return $print
+}
+
# tcltest::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
@@ -1340,7 +1373,7 @@ proc tcltest::DefineConstraintInitializers {} {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $f -encoding utf-8
+ fconfigure $f -profile tcl8 -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
@@ -2190,7 +2223,7 @@ proc tcltest::test {name description args} {
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $testFd -encoding utf-8
+ fconfigure $testFd -profile tcl8 -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
@@ -2221,9 +2254,13 @@ proc tcltest::test {name description args} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
- puts [outputChannel] "---- Result was:\n$actualAnswer"
+ if {[catch {
+ puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
+ } errMsg]} {
+ puts [outputChannel] "\n---- Result was:\n<error printing result: $errMsg>"
+ }
puts [outputChannel] "---- Result should have been\
- ($match matching):\n$result"
+ ($match matching):\n[Asciify $result]"
}
}
if {$errorCodeFailure} {
@@ -2902,7 +2939,7 @@ proc tcltest::runAllTests { {shell ""} } {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $pipeFd -encoding utf-8
+ fconfigure $pipeFd -profile tcl8 -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
@@ -3102,7 +3139,7 @@ proc tcltest::makeFile {contents name {directory ""}} {
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $fd -encoding utf-8
+ fconfigure $fd -profile tcl8 -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
@@ -3253,7 +3290,7 @@ proc tcltest::viewFile {name {directory ""}} {
set fullName [file join $directory $name]
set f [open $fullName]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
- fconfigure $f -encoding utf-8
+ fconfigure $f -profile tcl8 -encoding utf-8
}
set data [read -nonewline $f]
close $f
diff --git a/library/tm.tcl b/library/tm.tcl
index 02007d5..75abfb0 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -267,7 +267,7 @@ proc ::tcl::tm::UnknownHandler {original name args} {
# of the package file is the last element in the list.
package ifneeded $pkgname $pkgversion \
- "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
+ "[::list package provide $pkgname $pkgversion];[::list source $file]"
# We abort in this unknown handler only if we got a
# satisfying candidate for the requested package.
@@ -316,7 +316,7 @@ proc ::tcl::tm::UnknownHandler {original name args} {
proc ::tcl::tm::Defaults {} {
global env tcl_platform
- regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
+ regexp {^(\d+)\.(\d+)} [package provide tcl] - major minor
set exe [file normalize [info nameofexecutable]]
# Note that we're using [::list], not [list] because [list] means
@@ -359,7 +359,7 @@ proc ::tcl::tm::Defaults {} {
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
- regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
+ regexp {^(\d+)\.(\d+)} [package provide tcl] - major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
diff --git a/library/word.tcl b/library/word.tcl
index 0c8e01c..e86c44a 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -4,31 +4,21 @@
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998 Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 1998 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The following variables are used to determine which characters are
-# interpreted as white space.
+# interpreted as word characters. See bug [f1253530cdd8]. Will
+# probably be removed in Tcl 9.
-if {$::tcl_platform(platform) eq "windows"} {
- # Windows style - any but a Unicode space char
- if {![info exists ::tcl_wordchars]} {
- set ::tcl_wordchars {\S}
- }
- if {![info exists ::tcl_nonwordchars]} {
- set ::tcl_nonwordchars {\s}
- }
-} else {
- # Motif style - any Unicode word char (number, letter, or underscore)
- if {![info exists ::tcl_wordchars]} {
- set ::tcl_wordchars {\w}
- }
- if {![info exists ::tcl_nonwordchars]} {
- set ::tcl_nonwordchars {\W}
- }
+if {![info exists ::tcl_wordchars]} {
+ set ::tcl_wordchars {\w}
+}
+if {![info exists ::tcl_nonwordchars]} {
+ set ::tcl_nonwordchars {\W}
}
# Arrange for caches of the real matcher REs to be kept, which enables the REs
diff --git a/library/writefile.tcl b/library/writefile.tcl
new file mode 100644
index 0000000..fbd9138
--- /dev/null
+++ b/library/writefile.tcl
@@ -0,0 +1,37 @@
+# writeFile:
+# Write the contents of a file.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc writeFile {args} {
+ # Parse the arguments
+ switch [llength $args] {
+ 2 {
+ lassign $args filename data
+ set mode text
+ }
+ 3 {
+ lassign $args filename mode data
+ set MODES {binary text}
+ set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]]
+ set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode]
+ }
+ default {
+ set COMMAND [lindex [info level 0] 0]
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"$COMMAND filename ?mode? data\""
+ }
+ }
+
+ # Write the file
+ set f [open $filename [dict get {text w binary wb} $mode]]
+ try {
+ puts -nonewline $f $data
+ } finally {
+ close $f
+ }
+}
diff --git a/libtommath/bn_deprecated.c b/libtommath/bn_deprecated.c
index a4004f6..2056b20 100644
--- a/libtommath/bn_deprecated.c
+++ b/libtommath/bn_deprecated.c
@@ -219,7 +219,7 @@ mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
- return mp_root_u32(a, (unsigned int)b, c);
+ return mp_root_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_N_ROOT_C
@@ -228,7 +228,7 @@ mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c)
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
- return mp_root_u32(a, (unsigned int)b, c);
+ return mp_root_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
diff --git a/libtommath/bn_mp_expt_u32.c b/libtommath/bn_mp_expt_u32.c
index 67c8fd2..2ab67ba 100644
--- a/libtommath/bn_mp_expt_u32.c
+++ b/libtommath/bn_mp_expt_u32.c
@@ -4,7 +4,7 @@
/* SPDX-License-Identifier: Unlicense */
/* calculate c = a**b using a square-multiply algorithm */
-mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)
+mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c)
{
mp_err err;
diff --git a/libtommath/bn_mp_log_u32.c b/libtommath/bn_mp_log_u32.c
index 2531cd8..b86d789 100644
--- a/libtommath/bn_mp_log_u32.c
+++ b/libtommath/bn_mp_log_u32.c
@@ -70,11 +70,11 @@ static mp_digit s_digit_ilogb(mp_digit base, mp_digit n)
as is the output of mp_bitcount.
With the same problem: max size is INT_MAX * MP_DIGIT not INT_MAX only!
*/
-mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c)
+mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c)
{
mp_err err;
mp_ord cmp;
- unsigned int high, low, mid;
+ uint32_t high, low, mid;
mp_int bracket_low, bracket_high, bracket_mid, t, bi_base;
err = MP_OKAY;
@@ -98,12 +98,12 @@ mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c)
base >>= 1;
}
bit_count = mp_count_bits(a) - 1;
- *c = (unsigned int)(bit_count/y);
+ *c = (uint32_t)(bit_count/y);
return MP_OKAY;
}
if (a->used == 1) {
- *c = (unsigned int)s_digit_ilogb(base, a->dp[0]);
+ *c = (uint32_t)s_digit_ilogb(base, a->dp[0]);
return err;
}
@@ -146,7 +146,7 @@ mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c)
while ((high - low) > 1u) {
mid = (high + low) >> 1;
- if ((err = mp_expt_u32(&bi_base, mid - low, &t)) != MP_OKAY) {
+ if ((err = mp_expt_u32(&bi_base, (uint32_t)(mid - low), &t)) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = mp_mul(&bracket_low, &t, &bracket_mid)) != MP_OKAY) {
diff --git a/libtommath/bn_mp_radix_smap.c b/libtommath/bn_mp_radix_smap.c
index eb4765a..a16128d 100644
--- a/libtommath/bn_mp_radix_smap.c
+++ b/libtommath/bn_mp_radix_smap.c
@@ -5,7 +5,7 @@
/* chars used in radix conversions */
const char *const mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
-const unsigned char mp_s_rmap_reverse[] = {
+const uint8_t mp_s_rmap_reverse[] = {
0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, /* 01234567 */
0x08, 0x09, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, /* 89:;<=>? */
diff --git a/libtommath/bn_mp_root_u32.c b/libtommath/bn_mp_root_u32.c
index b60cf26..ba65549 100644
--- a/libtommath/bn_mp_root_u32.c
+++ b/libtommath/bn_mp_root_u32.c
@@ -12,7 +12,7 @@
* which will find the root in log(N) time where
* each step involves a fair bit.
*/
-mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c)
+mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c)
{
mp_int t1, t2, t3, a_;
mp_ord cmp;
@@ -40,7 +40,7 @@ mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c)
log_2(n) because the bit-length of the "n" is measured
with an int and hence the root is always < 2 (two).
*/
- if (b > (unsigned int)(INT_MAX/2)) {
+ if (b > (uint32_t)(INT_MAX/2)) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
diff --git a/libtommath/bn_mp_to_ubin.c b/libtommath/bn_mp_to_ubin.c
index 4913c3a..1681ca7 100644
--- a/libtommath/bn_mp_to_ubin.c
+++ b/libtommath/bn_mp_to_ubin.c
@@ -10,8 +10,7 @@ mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *wr
mp_err err;
mp_int t;
- size_t size = (size_t)mp_count_bits(a);
- count = (size / 8u) + (((size & 7u) != 0u) ? 1u : 0u);
+ count = mp_ubin_size(a);
if (count > maxlen) {
return MP_BUF;
}
diff --git a/libtommath/demo/shared.c b/libtommath/demo/shared.c
deleted file mode 100644
index dc8e05a..0000000
--- a/libtommath/demo/shared.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "shared.h"
-
-void ndraw(mp_int *a, const char *name)
-{
- char *buf = NULL;
- int size;
-
- mp_radix_size(a, 10, &size);
- buf = (char *)malloc((size_t) size);
- if (buf == NULL) {
- fprintf(stderr, "\nndraw: malloc(%d) failed\n", size);
- exit(EXIT_FAILURE);
- }
-
- printf("%s: ", name);
- mp_to_decimal(a, buf, (size_t) size);
- printf("%s\n", buf);
- mp_to_hex(a, buf, (size_t) size);
- printf("0x%s\n", buf);
-
- free(buf);
-}
-
-void print_header(void)
-{
-#ifdef MP_8BIT
- printf("Digit size 8 Bit \n");
-#endif
-#ifdef MP_16BIT
- printf("Digit size 16 Bit \n");
-#endif
-#ifdef MP_32BIT
- printf("Digit size 32 Bit \n");
-#endif
-#ifdef MP_64BIT
- printf("Digit size 64 Bit \n");
-#endif
- printf("Size of mp_digit: %u\n", (unsigned int)sizeof(mp_digit));
- printf("Size of mp_word: %u\n", (unsigned int)sizeof(mp_word));
- printf("MP_DIGIT_BIT: %d\n", MP_DIGIT_BIT);
- printf("MP_PREC: %d\n", MP_PREC);
-}
diff --git a/libtommath/demo/shared.h b/libtommath/demo/shared.h
deleted file mode 100644
index 4d5eb53..0000000
--- a/libtommath/demo/shared.h
+++ /dev/null
@@ -1,21 +0,0 @@
-#include <string.h>
-#include <stdlib.h>
-#include <time.h>
-
-/*
- * Configuration
- */
-#ifndef LTM_DEMO_TEST_REDUCE_2K_L
-/* This test takes a moment so we disable it by default, but it can be:
- * 0 to disable testing
- * 1 to make the test with P = 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF
- * 2 to make the test with P = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F
- */
-#define LTM_DEMO_TEST_REDUCE_2K_L 0
-#endif
-
-#define MP_WUR /* TODO: result checks disabled for now */
-#include "tommath_private.h"
-
-extern void ndraw(mp_int* a, const char* name);
-extern void print_header(void);
diff --git a/libtommath/demo/test.c b/libtommath/demo/test.c
deleted file mode 100644
index 14b0c58..0000000
--- a/libtommath/demo/test.c
+++ /dev/null
@@ -1,2522 +0,0 @@
-#include <inttypes.h>
-#include "shared.h"
-
-static long rand_long(void)
-{
- long x;
- if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) {
- fprintf(stderr, "s_mp_rand_source failed\n");
- exit(EXIT_FAILURE);
- }
- return x;
-}
-
-static int rand_int(void)
-{
- int x;
- if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) {
- fprintf(stderr, "s_mp_rand_source failed\n");
- exit(EXIT_FAILURE);
- }
- return x;
-}
-
-static int32_t rand_int32(void)
-{
- int32_t x;
- if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) {
- fprintf(stderr, "s_mp_rand_source failed\n");
- exit(EXIT_FAILURE);
- }
- return x;
-}
-
-static int64_t rand_int64(void)
-{
- int64_t x;
- if (s_mp_rand_source(&x, sizeof(x)) != MP_OKAY) {
- fprintf(stderr, "s_mp_rand_source failed\n");
- exit(EXIT_FAILURE);
- }
- return x;
-}
-
-static uint32_t uabs32(int32_t x)
-{
- return x > 0 ? (uint32_t)x : -(uint32_t)x;
-}
-
-static uint64_t uabs64(int64_t x)
-{
- return x > 0 ? (uint64_t)x : -(uint64_t)x;
-}
-
-/* This function prototype is needed
- * to test dead code elimination
- * which is used for feature detection.
- *
- * If the feature detection does not
- * work as desired we will get a linker error.
- */
-void does_not_exist(void);
-
-static int test_feature_detection(void)
-{
-#define BN_TEST_FEATURE1_C
- if (!MP_HAS(TEST_FEATURE1)) {
- does_not_exist();
- return EXIT_FAILURE;
- }
-
-#define BN_TEST_FEATURE2_C 1
- if (MP_HAS(TEST_FEATURE2)) {
- does_not_exist();
- return EXIT_FAILURE;
- }
-
-#define BN_TEST_FEATURE3_C 0
- if (MP_HAS(TEST_FEATURE3)) {
- does_not_exist();
- return EXIT_FAILURE;
- }
-
-#define BN_TEST_FEATURE4_C something
- if (MP_HAS(TEST_FEATURE4)) {
- does_not_exist();
- return EXIT_FAILURE;
- }
-
- if (MP_HAS(TEST_FEATURE5)) {
- does_not_exist();
- return EXIT_FAILURE;
- }
-
- return EXIT_SUCCESS;
-}
-
-static int test_trivial_stuff(void)
-{
- mp_int a, b, c, d;
- mp_err e;
- if ((e = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) {
- return EXIT_FAILURE;
- }
- (void)mp_error_to_string(e);
-
- /* a: 0->5 */
- mp_set(&a, 5u);
- /* a: 5-> b: -5 */
- mp_neg(&a, &b);
- if (mp_cmp(&a, &b) != MP_GT) {
- goto LBL_ERR;
- }
- if (mp_cmp(&b, &a) != MP_LT) {
- goto LBL_ERR;
- }
- /* a: 5-> a: -5 */
- mp_neg(&a, &a);
- if (mp_cmp(&b, &a) != MP_EQ) {
- goto LBL_ERR;
- }
- /* a: -5-> b: 5 */
- mp_abs(&a, &b);
- if (mp_isneg(&b) != MP_NO) {
- goto LBL_ERR;
- }
- /* a: -5-> b: -4 */
- mp_add_d(&a, 1uL, &b);
- if (mp_isneg(&b) != MP_YES) {
- goto LBL_ERR;
- }
- if (mp_get_i32(&b) != -4) {
- goto LBL_ERR;
- }
- if (mp_get_u32(&b) != (uint32_t)-4) {
- goto LBL_ERR;
- }
- if (mp_get_mag_u32(&b) != 4) {
- goto LBL_ERR;
- }
- /* a: -5-> b: 1 */
- mp_add_d(&a, 6uL, &b);
- if (mp_get_u32(&b) != 1) {
- goto LBL_ERR;
- }
- /* a: -5-> a: 1 */
- mp_add_d(&a, 6uL, &a);
- if (mp_get_u32(&a) != 1) {
- goto LBL_ERR;
- }
- mp_zero(&a);
- /* a: 0-> a: 6 */
- mp_add_d(&a, 6uL, &a);
- if (mp_get_u32(&a) != 6) {
- goto LBL_ERR;
- }
-
- mp_set(&a, 42u);
- mp_set(&b, 1u);
- mp_neg(&b, &b);
- mp_set(&c, 1u);
- mp_exptmod(&a, &b, &c, &d);
-
- mp_set(&c, 7u);
- mp_exptmod(&a, &b, &c, &d);
-
- if (mp_iseven(&a) == mp_isodd(&a)) {
- goto LBL_ERR;
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int check_get_set_i32(mp_int *a, int32_t b)
-{
- mp_clear(a);
- if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE;
-
- mp_set_i32(a, b);
- if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE;
- if (mp_get_i32(a) != b) return EXIT_FAILURE;
- if (mp_get_u32(a) != (uint32_t)b) return EXIT_FAILURE;
- if (mp_get_mag_u32(a) != uabs32(b)) return EXIT_FAILURE;
-
- mp_set_u32(a, (uint32_t)b);
- if (mp_get_u32(a) != (uint32_t)b) return EXIT_FAILURE;
- if (mp_get_i32(a) != (int32_t)(uint32_t)b) return EXIT_FAILURE;
-
- return EXIT_SUCCESS;
-}
-
-static int test_mp_get_set_i32(void)
-{
- int i;
- mp_int a;
-
- if (mp_init(&a) != MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- check_get_set_i32(&a, 0);
- check_get_set_i32(&a, -1);
- check_get_set_i32(&a, 1);
- check_get_set_i32(&a, INT32_MIN);
- check_get_set_i32(&a, INT32_MAX);
-
- for (i = 0; i < 1000; ++i) {
- int32_t b = rand_int32();
- if (check_get_set_i32(&a, b) != EXIT_SUCCESS) {
- goto LBL_ERR;
- }
- }
-
- mp_clear(&a);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear(&a);
- return EXIT_FAILURE;
-}
-
-static int check_get_set_i64(mp_int *a, int64_t b)
-{
- mp_clear(a);
- if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE;
-
- mp_set_i64(a, b);
- if (mp_shrink(a) != MP_OKAY) return EXIT_FAILURE;
- if (mp_get_i64(a) != b) return EXIT_FAILURE;
- if (mp_get_u64(a) != (uint64_t)b) return EXIT_FAILURE;
- if (mp_get_mag_u64(a) != uabs64(b)) return EXIT_FAILURE;
-
- mp_set_u64(a, (uint64_t)b);
- if (mp_get_u64(a) != (uint64_t)b) return EXIT_FAILURE;
- if (mp_get_i64(a) != (int64_t)(uint64_t)b) return EXIT_FAILURE;
-
- return EXIT_SUCCESS;
-}
-
-static int test_mp_get_set_i64(void)
-{
- int i;
- mp_int a;
-
- if (mp_init(&a) != MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- check_get_set_i64(&a, 0);
- check_get_set_i64(&a, -1);
- check_get_set_i64(&a, 1);
- check_get_set_i64(&a, INT64_MIN);
- check_get_set_i64(&a, INT64_MAX);
-
- for (i = 0; i < 1000; ++i) {
- int64_t b = rand_int64();
- if (check_get_set_i64(&a, b) != EXIT_SUCCESS) {
- goto LBL_ERR;
- }
- }
-
- mp_clear(&a);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear(&a);
- return EXIT_FAILURE;
-}
-
-static int test_mp_fread_fwrite(void)
-{
- mp_int a, b;
- mp_err e;
- FILE *tmp = NULL;
- if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- mp_set_ul(&a, 123456uL);
- tmp = tmpfile();
- if ((e = mp_fwrite(&a, 64, tmp)) != MP_OKAY) {
- goto LBL_ERR;
- }
- rewind(tmp);
- if ((e = mp_fread(&b, 64, tmp)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_get_u32(&b) != 123456uL) {
- goto LBL_ERR;
- }
- fclose(tmp);
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- if (tmp != NULL) fclose(tmp);
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static mp_err very_random_source(void *out, size_t size)
-{
- memset(out, 0xff, size);
- return MP_OKAY;
-}
-
-static int test_mp_rand(void)
-{
- mp_int a, b;
- int n;
- mp_err err;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
- mp_rand_source(very_random_source);
- for (n = 1; n < 1024; ++n) {
- if ((err = mp_rand(&a, n)) != MP_OKAY) {
- printf("Failed mp_rand() %s.\n", mp_error_to_string(err));
- break;
- }
- if ((err = mp_incr(&a)) != MP_OKAY) {
- printf("Failed mp_incr() %s.\n", mp_error_to_string(err));
- break;
- }
- if ((err = mp_div_2d(&a, n * MP_DIGIT_BIT, &b, NULL)) != MP_OKAY) {
- printf("Failed mp_div_2d() %s.\n", mp_error_to_string(err));
- break;
- }
- if (mp_cmp_d(&b, 1) != MP_EQ) {
- ndraw(&a, "mp_rand() a");
- ndraw(&b, "mp_rand() b");
- err = MP_ERR;
- break;
- }
- }
- mp_rand_source(s_mp_rand_jenkins);
- mp_clear_multi(&a, &b, NULL);
- return err == MP_OKAY ? EXIT_SUCCESS : EXIT_FAILURE;
-}
-
-static int test_mp_kronecker(void)
-{
- struct mp_kronecker_st {
- long n;
- int c[21];
- };
- static struct mp_kronecker_st kronecker[] = {
- /*-10, -9, -8, -7,-6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10*/
- { -10, { 0, -1, 0, -1, 0, 0, 0, 1, 0, -1, 0, 1, 0, -1, 0, 0, 0, 1, 0, 1, 0 } },
- { -9, { -1, 0, -1, 1, 0, -1, -1, 0, -1, -1, 0, 1, 1, 0, 1, 1, 0, -1, 1, 0, 1 } },
- { -8, { 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0 } },
- { -7, { 1, -1, -1, 0, 1, 1, -1, 1, -1, -1, 0, 1, 1, -1, 1, -1, -1, 0, 1, 1, -1 } },
- { -6, { 0, 0, 0, -1, 0, -1, 0, 0, 0, -1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0 } },
- { -5, { 0, -1, 1, -1, 1, 0, -1, -1, 1, -1, 0, 1, -1, 1, 1, 0, -1, 1, -1, 1, 0 } },
- { -4, { 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0 } },
- { -3, { -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1, -1, 0, 1 } },
- { -2, { 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0 } },
- { -1, { -1, -1, -1, 1, 1, -1, -1, 1, -1, -1, 1, 1, 1, -1, 1, 1, -1, -1, 1, 1, 1 } },
- { 0, { 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 } },
- { 1, { 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 } },
- { 2, { 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0 } },
- { 3, { 1, 0, -1, -1, 0, -1, 1, 0, -1, 1, 0, 1, -1, 0, 1, -1, 0, -1, -1, 0, 1 } },
- { 4, { 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0 } },
- { 5, { 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0, 1, -1, -1, 1, 0 } },
- { 6, { 0, 0, 0, -1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0, -1, 0, 0, 0 } },
- { 7, { -1, 1, 1, 0, 1, -1, 1, 1, 1, 1, 0, 1, 1, 1, 1, -1, 1, 0, 1, 1, -1 } },
- { 8, { 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0, -1, 0, -1, 0, 1, 0, 1, 0 } },
- { 9, { 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 1 } },
- { 10, { 0, 1, 0, -1, 0, 0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, -1, 0, 1, 0 } }
- };
-
- long k, m;
- int i, cnt;
- mp_err err;
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- mp_set_ul(&a, 0uL);
- mp_set_ul(&b, 1uL);
- if ((err = mp_kronecker(&a, &b, &i)) != MP_OKAY) {
- printf("Failed executing mp_kronecker(0 | 1) %s.\n", mp_error_to_string(err));
- goto LBL_ERR;
- }
- if (i != 1) {
- printf("Failed trivial mp_kronecker(0 | 1) %d != 1\n", i);
- goto LBL_ERR;
- }
- for (cnt = 0; cnt < (int)(sizeof(kronecker)/sizeof(kronecker[0])); ++cnt) {
- k = kronecker[cnt].n;
- mp_set_l(&a, k);
- /* only test positive values of a */
- for (m = -10; m <= 10; m++) {
- mp_set_l(&b, m);
- if ((err = mp_kronecker(&a, &b, &i)) != MP_OKAY) {
- printf("Failed executing mp_kronecker(%ld | %ld) %s.\n", kronecker[cnt].n, m, mp_error_to_string(err));
- goto LBL_ERR;
- }
- if ((err == MP_OKAY) && (i != kronecker[cnt].c[m + 10])) {
- printf("Failed trivial mp_kronecker(%ld | %ld) %d != %d\n", kronecker[cnt].n, m, i, kronecker[cnt].c[m + 10]);
- goto LBL_ERR;
- }
- }
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_complement(void)
-{
- int i;
-
- mp_int a, b, c;
- if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- long l = rand_long();
- mp_set_l(&a, l);
- mp_complement(&a, &b);
-
- l = ~l;
- mp_set_l(&c, l);
-
- if (mp_cmp(&b, &c) != MP_EQ) {
- printf("\nmp_complement() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_signed_rsh(void)
-{
- int i;
-
- mp_int a, b, d;
- if (mp_init_multi(&a, &b, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- long l;
- int em;
-
- l = rand_long();
- mp_set_l(&a, l);
-
- em = abs(rand_int()) % 32;
-
- mp_set_l(&d, l >> em);
-
- mp_signed_rsh(&a, em, &b);
- if (mp_cmp(&b, &d) != MP_EQ) {
- printf("\nmp_signed_rsh() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &d, NULL);
- return EXIT_FAILURE;
-
-}
-
-static int test_mp_xor(void)
-{
- int i;
-
- mp_int a, b, c, d;
- if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- long l, em;
-
- l = rand_long();
- mp_set_l(&a,l);
-
- em = rand_long();
- mp_set_l(&b, em);
-
- mp_set_l(&d, l ^ em);
-
- mp_xor(&a, &b, &c);
- if (mp_cmp(&c, &d) != MP_EQ) {
- printf("\nmp_xor() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-
-}
-
-static int test_mp_or(void)
-{
- int i;
-
- mp_int a, b, c, d;
- if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- long l, em;
-
- l = rand_long();
- mp_set_l(&a, l);
-
- em = rand_long();
- mp_set_l(&b, em);
-
- mp_set_l(&d, l | em);
-
- mp_or(&a, &b, &c);
- if (mp_cmp(&c, &d) != MP_EQ) {
- printf("\nmp_or() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_and(void)
-{
- int i;
-
- mp_int a, b, c, d;
- if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- long l, em;
-
- l = rand_long();
- mp_set_l(&a, l);
-
- em = rand_long();
- mp_set_l(&b, em);
-
- mp_set_l(&d, l & em);
-
- mp_and(&a, &b, &c);
- if (mp_cmp(&c, &d) != MP_EQ) {
- printf("\nmp_and() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_invmod(void)
-{
- mp_int a, b, c, d;
- if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* mp_invmod corner-case of https://github.com/libtom/libtommath/issues/118 */
- {
- const char *a_ = "47182BB8DF0FFE9F61B1F269BACC066B48BA145D35137D426328DC3F88A5EA44";
- const char *b_ = "FFFFFFFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFF";
- const char *should_ = "0521A82E10376F8E4FDEF9A32A427AC2A0FFF686E00290D39E3E4B5522409596";
-
- if (mp_read_radix(&a, a_, 16) != MP_OKAY) {
- printf("\nmp_read_radix(a) failed!");
- goto LBL_ERR;
- }
- if (mp_read_radix(&b, b_, 16) != MP_OKAY) {
- printf("\nmp_read_radix(b) failed!");
- goto LBL_ERR;
- }
- if (mp_read_radix(&c, should_, 16) != MP_OKAY) {
- printf("\nmp_read_radix(should) failed!");
- goto LBL_ERR;
- }
-
- if (mp_invmod(&a, &b, &d) != MP_OKAY) {
- printf("\nmp_invmod() failed!");
- goto LBL_ERR;
- }
-
- if (mp_cmp(&c, &d) != MP_EQ) {
- printf("\nmp_invmod() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-
-}
-
-#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
-static int test_mp_set_double(void)
-{
- int i;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test mp_get_double/mp_set_double */
- if (mp_set_double(&a, +1.0/0.0) != MP_VAL) {
- printf("\nmp_set_double should return MP_VAL for +inf");
- goto LBL_ERR;
- }
- if (mp_set_double(&a, -1.0/0.0) != MP_VAL) {
- printf("\nmp_set_double should return MP_VAL for -inf");
- goto LBL_ERR;
- }
- if (mp_set_double(&a, +0.0/0.0) != MP_VAL) {
- printf("\nmp_set_double should return MP_VAL for NaN");
- goto LBL_ERR;
- }
- if (mp_set_double(&a, -0.0/0.0) != MP_VAL) {
- printf("\nmp_set_double should return MP_VAL for NaN");
- goto LBL_ERR;
- }
-
- for (i = 0; i < 1000; ++i) {
- int tmp = rand_int();
- double dbl = (double)tmp * rand_int() + 1;
- if (mp_set_double(&a, dbl) != MP_OKAY) {
- printf("\nmp_set_double() failed");
- goto LBL_ERR;
- }
- if (dbl != mp_get_double(&a)) {
- printf("\nmp_get_double() bad result!");
- goto LBL_ERR;
- }
- if (mp_set_double(&a, -dbl) != MP_OKAY) {
- printf("\nmp_set_double() failed");
- goto LBL_ERR;
- }
- if (-dbl != mp_get_double(&a)) {
- printf("\nmp_get_double() bad result!");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-
-}
-#endif
-
-static int test_mp_get_u32(void)
-{
- unsigned long t;
- int i;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- t = (unsigned long)rand_long() & 0xFFFFFFFFuL;
- mp_set_ul(&a, t);
- if (t != mp_get_u32(&a)) {
- printf("\nmp_get_u32() bad result!");
- goto LBL_ERR;
- }
- }
- mp_set_ul(&a, 0uL);
- if (mp_get_u32(&a) != 0) {
- printf("\nmp_get_u32() bad result!");
- goto LBL_ERR;
- }
- mp_set_ul(&a, 0xFFFFFFFFuL);
- if (mp_get_u32(&a) != 0xFFFFFFFFuL) {
- printf("\nmp_get_u32() bad result!");
- goto LBL_ERR;
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_get_ul(void)
-{
- unsigned long s, t;
- int i;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < ((int)MP_SIZEOF_BITS(unsigned long) - 1); ++i) {
- t = (1UL << (i+1)) - 1;
- if (!t)
- t = ~0UL;
- printf(" t = 0x%lx i = %d\r", t, i);
- do {
- mp_set_ul(&a, t);
- s = mp_get_ul(&a);
- if (s != t) {
- printf("\nmp_get_ul() bad result! 0x%lx != 0x%lx", s, t);
- goto LBL_ERR;
- }
- t <<= 1;
- } while (t != 0uL);
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_get_u64(void)
-{
- uint64_t q, r;
- int i;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < (int)(MP_SIZEOF_BITS(uint64_t) - 1); ++i) {
- r = ((uint64_t)1 << (i+1)) - 1;
- if (!r)
- r = UINT64_MAX;
- printf(" r = 0x%" PRIx64 " i = %d\r", r, i);
- do {
- mp_set_u64(&a, r);
- q = mp_get_u64(&a);
- if (q != r) {
- printf("\nmp_get_u64() bad result! 0x%" PRIx64 " != 0x%" PRIx64, q, r);
- goto LBL_ERR;
- }
- r <<= 1;
- } while (r != 0u);
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-
-}
-
-static int test_mp_sqrt(void)
-{
- int i, n;
-
- mp_int a, b, c;
- if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- printf("%6d\r", i);
- fflush(stdout);
- n = (rand_int() & 15) + 1;
- mp_rand(&a, n);
- if (mp_sqrt(&a, &b) != MP_OKAY) {
- printf("\nmp_sqrt() error!");
- goto LBL_ERR;
- }
- mp_root_u32(&a, 2uL, &c);
- if (mp_cmp_mag(&b, &c) != MP_EQ) {
- printf("mp_sqrt() bad result!\n");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_is_square(void)
-{
- int i, n;
-
- mp_int a, b;
- mp_bool res;
-
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- for (i = 0; i < 1000; ++i) {
- printf("%6d\r", i);
- fflush(stdout);
-
- /* test mp_is_square false negatives */
- n = (rand_int() & 7) + 1;
- mp_rand(&a, n);
- mp_sqr(&a, &a);
- if (mp_is_square(&a, &res) != MP_OKAY) {
- printf("\nfn:mp_is_square() error!");
- goto LBL_ERR;
- }
- if (res == MP_NO) {
- printf("\nfn:mp_is_square() bad result!");
- goto LBL_ERR;
- }
-
- /* test for false positives */
- mp_add_d(&a, 1uL, &a);
- if (mp_is_square(&a, &res) != MP_OKAY) {
- printf("\nfp:mp_is_square() error!");
- goto LBL_ERR;
- }
- if (res == MP_YES) {
- printf("\nfp:mp_is_square() bad result!");
- goto LBL_ERR;
- }
-
- }
- printf("\n\n");
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_sqrtmod_prime(void)
-{
- struct mp_sqrtmod_prime_st {
- unsigned long p;
- unsigned long n;
- mp_digit r;
- };
-
- static struct mp_sqrtmod_prime_st sqrtmod_prime[] = {
- { 5, 14, 3 },
- { 7, 9, 4 },
- { 113, 2, 62 }
- };
- int i;
-
- mp_int a, b, c;
- if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* r^2 = n (mod p) */
- for (i = 0; i < (int)(sizeof(sqrtmod_prime)/sizeof(sqrtmod_prime[0])); ++i) {
- mp_set_ul(&a, sqrtmod_prime[i].p);
- mp_set_ul(&b, sqrtmod_prime[i].n);
- if (mp_sqrtmod_prime(&b, &a, &c) != MP_OKAY) {
- printf("Failed executing %d. mp_sqrtmod_prime\n", (i+1));
- goto LBL_ERR;
- }
- if (mp_cmp_d(&c, sqrtmod_prime[i].r) != MP_EQ) {
- printf("Failed %d. trivial mp_sqrtmod_prime\n", (i+1));
- ndraw(&c, "r");
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_prime_rand(void)
-{
- int ix;
- mp_err err;
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test for size */
- for (ix = 10; ix < 128; ix++) {
- printf("Testing (not safe-prime): %9d bits \r", ix);
- fflush(stdout);
- err = mp_prime_rand(&a, 8, ix, (rand_int() & 1) ? 0 : MP_PRIME_2MSB_ON);
- if (err != MP_OKAY) {
- printf("\nfailed with error: %s\n", mp_error_to_string(err));
- goto LBL_ERR;
- }
- if (mp_count_bits(&a) != ix) {
- printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix);
- goto LBL_ERR;
- }
- }
- printf("\n");
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_prime_is_prime(void)
-{
- int ix;
- mp_err err;
- mp_bool cnt, fu;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* strong Miller-Rabin pseudoprime to the first 200 primes (F. Arnault) */
- puts("Testing mp_prime_is_prime() with Arnault's pseudoprime 803...901 \n");
- mp_read_radix(&a,
- "91xLNF3roobhzgTzoFIG6P13ZqhOVYSN60Fa7Cj2jVR1g0k89zdahO9/kAiRprpfO1VAp1aBHucLFV/qLKLFb+zonV7R2Vxp1K13ClwUXStpV0oxTNQVjwybmFb5NBEHImZ6V7P6+udRJuH8VbMEnS0H8/pSqQrg82OoQQ2fPpAk6G1hkjqoCv5s/Yr",
- 64);
- mp_prime_is_prime(&a, mp_prime_rabin_miller_trials(mp_count_bits(&a)), &cnt);
- if (cnt == MP_YES) {
- printf("Arnault's pseudoprime is not prime but mp_prime_is_prime says it is.\n");
- goto LBL_ERR;
- }
- /* About the same size as Arnault's pseudoprime */
- puts("Testing mp_prime_is_prime() with certified prime 2^1119 + 53\n");
- mp_set(&a, 1uL);
- mp_mul_2d(&a,1119,&a);
- mp_add_d(&a, 53uL, &a);
- err = mp_prime_is_prime(&a, mp_prime_rabin_miller_trials(mp_count_bits(&a)), &cnt);
- /* small problem */
- if (err != MP_OKAY) {
- printf("\nfailed with error: %s\n", mp_error_to_string(err));
- }
- /* large problem */
- if (cnt == MP_NO) {
- printf("A certified prime is a prime but mp_prime_is_prime says it is not.\n");
- }
- if ((err != MP_OKAY) || (cnt == MP_NO)) {
- printf("prime tested was: 0x");
- mp_fwrite(&a,16,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
- for (ix = 16; ix < 128; ix++) {
- printf("Testing ( safe-prime): %9d bits \r", ix);
- fflush(stdout);
- err = mp_prime_rand(&a, 8, ix, ((rand_int() & 1) ? 0 : MP_PRIME_2MSB_ON) | MP_PRIME_SAFE);
- if (err != MP_OKAY) {
- printf("\nfailed with error: %s\n", mp_error_to_string(err));
- goto LBL_ERR;
- }
- if (mp_count_bits(&a) != ix) {
- printf("Prime is %d not %d bits!!!\n", mp_count_bits(&a), ix);
- goto LBL_ERR;
- }
- /* let's see if it's really a safe prime */
- mp_sub_d(&a, 1uL, &b);
- mp_div_2(&b, &b);
- err = mp_prime_is_prime(&b, mp_prime_rabin_miller_trials(mp_count_bits(&b)), &cnt);
- /* small problem */
- if (err != MP_OKAY) {
- printf("\nfailed with error: %s\n", mp_error_to_string(err));
- }
- /* large problem */
- if (cnt == MP_NO) {
- printf("\nsub is not prime!\n");
- }
- mp_prime_frobenius_underwood(&b, &fu);
- if (fu == MP_NO) {
- printf("\nfrobenius-underwood says sub is not prime!\n");
- }
- if ((err != MP_OKAY) || (cnt == MP_NO)) {
- printf("prime tested was: 0x");
- mp_fwrite(&a,16,stdout);
- putchar('\n');
- printf("sub tested was: 0x");
- mp_fwrite(&b,16,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- }
- /* Check regarding problem #143 */
-#ifndef MP_8BIT
- mp_read_radix(&a,
- "FFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A63A3620FFFFFFFFFFFFFFFF",
- 16);
- err = mp_prime_strong_lucas_selfridge(&a, &cnt);
- /* small problem */
- if (err != MP_OKAY) {
- printf("\nmp_prime_strong_lucas_selfridge failed with error: %s\n", mp_error_to_string(err));
- }
- /* large problem */
- if (cnt == MP_NO) {
- printf("\n\nissue #143 - mp_prime_strong_lucas_selfridge FAILED!\n");
- }
- if ((err != MP_OKAY) || (cnt == MP_NO)) {
- printf("prime tested was: 0x");
- mp_fwrite(&a,16,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-#endif
-
- printf("\n\n");
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-
-}
-
-
-static int test_mp_prime_next_prime(void)
-{
- mp_err err;
- mp_int a, b, c;
-
- mp_init_multi(&a, &b, &c, NULL);
-
-
- /* edge cases */
- mp_set(&a, 0u);
- if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp_d(&a, 2u) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been 2 but was: ");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- mp_set(&a, 0u);
- if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp_d(&a, 3u) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been 3 but was: ");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- mp_set(&a, 2u);
- if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp_d(&a, 3u) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been 3 but was: ");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- mp_set(&a, 2u);
- if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp_d(&a, 3u) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been 3 but was: ");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
- mp_set(&a, 8);
- if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp_d(&a, 11u) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been 11 but was: ");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
- /* 2^300 + 157 is a 300 bit large prime to guarantee a multi-limb bigint */
- if ((err = mp_2expt(&a, 300)) != MP_OKAY) {
- goto LBL_ERR;
- }
- mp_set_u32(&b, 157);
- if ((err = mp_add(&a, &b, &a)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if ((err = mp_copy(&a, &b)) != MP_OKAY) {
- goto LBL_ERR;
- }
-
- /* 2^300 + 385 is the next prime */
- mp_set_u32(&c, 228);
- if ((err = mp_add(&b, &c, &b)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if ((err = mp_prime_next_prime(&a, 5, 0)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp(&a, &b) != MP_EQ) {
- printf("mp_prime_next_prime: output should have been\n");
- mp_fwrite(&b,10,stdout);
- putchar('\n');
- printf("but was:\n");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- /* Use another temporary variable or recompute? Mmh... */
- if ((err = mp_2expt(&a, 300)) != MP_OKAY) {
- goto LBL_ERR;
- }
- mp_set_u32(&b, 157);
- if ((err = mp_add(&a, &b, &a)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if ((err = mp_copy(&a, &b)) != MP_OKAY) {
- goto LBL_ERR;
- }
-
- /* 2^300 + 631 is the next prime congruent to 3 mod 4*/
- mp_set_u32(&c, 474);
- if ((err = mp_add(&b, &c, &b)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if ((err = mp_prime_next_prime(&a, 5, 1)) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_cmp(&a, &b) != MP_EQ) {
- printf("mp_prime_next_prime (bbs): output should have been\n");
- mp_fwrite(&b,10,stdout);
- putchar('\n');
- printf("but was:\n");
- mp_fwrite(&a,10,stdout);
- putchar('\n');
- goto LBL_ERR;
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_montgomery_reduce(void)
-{
- mp_digit mp;
- int ix, i, n;
- char buf[4096];
-
- /* size_t written; */
-
- mp_int a, b, c, d, e;
- if (mp_init_multi(&a, &b, &c, &d, &e, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test montgomery */
- for (i = 1; i <= 10; i++) {
- if (i == 10)
- i = 1000;
- printf(" digit size: %2d\r", i);
- fflush(stdout);
- for (n = 0; n < 1000; n++) {
- mp_rand(&a, i);
- a.dp[0] |= 1;
-
- /* let's see if R is right */
- mp_montgomery_calc_normalization(&b, &a);
- mp_montgomery_setup(&a, &mp);
-
- /* now test a random reduction */
- for (ix = 0; ix < 100; ix++) {
- mp_rand(&c, 1 + abs(rand_int()) % (2*i));
- mp_copy(&c, &d);
- mp_copy(&c, &e);
-
- mp_mod(&d, &a, &d);
- mp_montgomery_reduce(&c, &a, mp);
- mp_mulmod(&c, &b, &a, &c);
-
- if (mp_cmp(&c, &d) != MP_EQ) {
-/* *INDENT-OFF* */
- printf("d = e mod a, c = e MOD a\n");
- mp_to_decimal(&a, buf, sizeof(buf)); printf("a = %s\n", buf);
- mp_to_decimal(&e, buf, sizeof(buf)); printf("e = %s\n", buf);
- mp_to_decimal(&d, buf, sizeof(buf)); printf("d = %s\n", buf);
- mp_to_decimal(&c, buf, sizeof(buf)); printf("c = %s\n", buf);
-
- printf("compare no compare!\n"); goto LBL_ERR;
-/* *INDENT-ON* */
- }
- /* only one big montgomery reduction */
- if (i > 10) {
- n = 1000;
- ix = 100;
- }
- }
- }
- }
-
- printf("\n\n");
-
- mp_clear_multi(&a, &b, &c, &d, &e, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, &e, NULL);
- return EXIT_FAILURE;
-
-}
-
-static int test_mp_read_radix(void)
-{
- char buf[4096];
- size_t written;
- mp_err err;
-
- mp_int a;
- if (mp_init_multi(&a, NULL)!= MP_OKAY) goto LTM_ERR;
-
- if ((err = mp_read_radix(&a, "123456", 10)) != MP_OKAY) goto LTM_ERR;
-
- if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR;
- printf(" '123456' a == %s, length = %zu\n", buf, written);
-
- /* See comment in bn_mp_to_radix.c */
- /*
- if( (err = mp_to_radix(&a, buf, 3u, &written, 10) ) != MP_OKAY) goto LTM_ERR;
- printf(" '56' a == %s, length = %zu\n", buf, written);
-
- if( (err = mp_to_radix(&a, buf, 4u, &written, 10) ) != MP_OKAY) goto LTM_ERR;
- printf(" '456' a == %s, length = %zu\n", buf, written);
- if( (err = mp_to_radix(&a, buf, 30u, &written, 10) ) != MP_OKAY) goto LTM_ERR;
- printf(" '123456' a == %s, length = %zu, error = %s\n",
- buf, written, mp_error_to_string(err));
- */
- if ((err = mp_read_radix(&a, "-123456", 10)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR;
- printf(" '-123456' a == %s, length = %zu\n", buf, written);
-
- if ((err = mp_read_radix(&a, "0", 10)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_to_radix(&a, buf, SIZE_MAX, &written, 10)) != MP_OKAY) goto LTM_ERR;
- printf(" '0' a == %s, length = %zu\n", buf, written);
-
-
-
- /* Although deprecated it needs to function as long as it isn't dropped */
- /*
- printf("Testing deprecated mp_toradix_n\n");
- if( (err = mp_read_radix(&a, "-123456", 10) ) != MP_OKAY) goto LTM_ERR;
- if( (err = mp_toradix_n(&a, buf, 10, 3) ) != MP_OKAY) goto LTM_ERR;
- printf("a == %s\n", buf);
- if( (err = mp_toradix_n(&a, buf, 10, 4) ) != MP_OKAY) goto LTM_ERR;
- printf("a == %s\n", buf);
- if( (err = mp_toradix_n(&a, buf, 10, 30) ) != MP_OKAY) goto LTM_ERR;
- printf("a == %s\n", buf);
- */
-
-
- while (0) {
- char *s = fgets(buf, sizeof(buf), stdin);
- if (s != buf) break;
- mp_read_radix(&a, buf, 10);
- mp_prime_next_prime(&a, 5, 1);
- mp_to_radix(&a, buf, sizeof(buf), NULL, 10);
- printf("%s, %lu\n", buf, (unsigned long)a.dp[0] & 3uL);
- }
-
- mp_clear(&a);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear(&a);
- return EXIT_FAILURE;
-}
-
-static int test_mp_cnt_lsb(void)
-{
- int ix;
-
- mp_int a, b;
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- mp_set(&a, 1uL);
- for (ix = 0; ix < 1024; ix++) {
- if (mp_cnt_lsb(&a) != ix) {
- printf("Failed at %d, %d\n", ix, mp_cnt_lsb(&a));
- goto LBL_ERR;
- }
- mp_mul_2(&a, &a);
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-
-}
-
-static int test_mp_reduce_2k(void)
-{
- int ix, cnt;
-
- mp_int a, b, c, d;
- if (mp_init_multi(&a, &b, &c, &d, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test mp_reduce_2k */
- for (cnt = 3; cnt <= 128; ++cnt) {
- mp_digit tmp;
-
- mp_2expt(&a, cnt);
- mp_sub_d(&a, 2uL, &a); /* a = 2**cnt - 2 */
-
- printf("\r %4d bits", cnt);
- printf("(%d)", mp_reduce_is_2k(&a));
- mp_reduce_2k_setup(&a, &tmp);
- printf("(%lu)", (unsigned long) tmp);
- for (ix = 0; ix < 1000; ix++) {
- if (!(ix & 127)) {
- printf(".");
- fflush(stdout);
- }
- mp_rand(&b, (cnt / MP_DIGIT_BIT + 1) * 2);
- mp_copy(&c, &b);
- mp_mod(&c, &a, &c);
- mp_reduce_2k(&b, &a, 2uL);
- if (mp_cmp(&c, &b) != MP_EQ) {
- printf("FAILED\n");
- goto LBL_ERR;
- }
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_div_3(void)
-{
- int cnt;
-
- mp_int a, b, c, d, e;
- if (mp_init_multi(&a, &b, &c, &d, &e, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test mp_div_3 */
- mp_set(&d, 3uL);
- for (cnt = 0; cnt < 10000;) {
- mp_digit r2;
-
- if (!(++cnt & 127)) {
- printf("%9d\r", cnt);
- fflush(stdout);
- }
- mp_rand(&a, abs(rand_int()) % 128 + 1);
- mp_div(&a, &d, &b, &e);
- mp_div_3(&a, &c, &r2);
-
- if (mp_cmp(&b, &c) || mp_cmp_d(&e, r2)) {
- printf("\nmp_div_3 => Failure\n");
- goto LBL_ERR;
- }
- }
- printf("\nPassed div_3 testing");
-
- mp_clear_multi(&a, &b, &c, &d, &e, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, &d, &e, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_dr_reduce(void)
-{
- mp_digit mp;
- int cnt;
- unsigned rr;
- int ix;
-
- mp_int a, b, c;
- if (mp_init_multi(&a, &b, &c, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
-
- /* test the DR reduction */
- for (cnt = 2; cnt < 32; cnt++) {
- printf("\r%d digit modulus", cnt);
- mp_grow(&a, cnt);
- mp_zero(&a);
- for (ix = 1; ix < cnt; ix++) {
- a.dp[ix] = MP_MASK;
- }
- a.used = cnt;
- a.dp[0] = 3;
-
- mp_rand(&b, cnt - 1);
- mp_copy(&b, &c);
-
- rr = 0;
- do {
- if (!(rr & 127)) {
- printf(".");
- fflush(stdout);
- }
- mp_sqr(&b, &b);
- mp_add_d(&b, 1uL, &b);
- mp_copy(&b, &c);
-
- mp_mod(&b, &a, &b);
- mp_dr_setup(&a, &mp);
- mp_dr_reduce(&c, &a, mp);
-
- if (mp_cmp(&b, &c) != MP_EQ) {
- printf("Failed on trial %u\n", rr);
- goto LBL_ERR;
- }
- } while (++rr < 500);
- printf(" passed");
- fflush(stdout);
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_reduce_2k_l(void)
-{
-# if LTM_DEMO_TEST_REDUCE_2K_L
- mp_int a, b, c, d;
- int cnt;
- char buf[4096];
- size_t length[1];
- if (mp_init_multi(&a, &b, NULL)!= MP_OKAY) {
- return EXIT_FAILURE;
- }
- /* test the mp_reduce_2k_l code */
-# if LTM_DEMO_TEST_REDUCE_2K_L == 1
- /* first load P with 2^1024 - 0x2A434 B9FDEC95 D8F9D550 FFFFFFFF FFFFFFFF */
- mp_2expt(&a, 1024);
- mp_read_radix(&b, "2A434B9FDEC95D8F9D550FFFFFFFFFFFFFFFF", 16);
- mp_sub(&a, &b, &a);
-# elif LTM_DEMO_TEST_REDUCE_2K_L == 2
- /* p = 2^2048 - 0x1 00000000 00000000 00000000 00000000 4945DDBF 8EA2A91D 5776399B B83E188F */
- mp_2expt(&a, 2048);
- mp_read_radix(&b,
- "1000000000000000000000000000000004945DDBF8EA2A91D5776399BB83E188F",
- 16);
- mp_sub(&a, &b, &a);
-# else
-# error oops
-# endif
- *length = sizeof(buf);
- mp_to_radix(&a, buf, length, 10);
- printf("\n\np==%s, length = %zu\n", buf, *length);
- /* now mp_reduce_is_2k_l() should return */
- if (mp_reduce_is_2k_l(&a) != 1) {
- printf("mp_reduce_is_2k_l() return 0, should be 1\n");
- goto LBL_ERR;
- }
- mp_reduce_2k_setup_l(&a, &d);
- /* now do a million square+1 to see if it varies */
- mp_rand(&b, 64);
- mp_mod(&b, &a, &b);
- mp_copy(&b, &c);
- printf("Testing: mp_reduce_2k_l...");
- fflush(stdout);
- for (cnt = 0; cnt < (int)(1uL << 20); cnt++) {
- mp_sqr(&b, &b);
- mp_add_d(&b, 1uL, &b);
- mp_reduce_2k_l(&b, &a, &d);
- mp_sqr(&c, &c);
- mp_add_d(&c, 1uL, &c);
- mp_mod(&c, &a, &c);
- if (mp_cmp(&b, &c) != MP_EQ) {
- printf("mp_reduce_2k_l() failed at step %d\n", cnt);
- mp_to_hex(&b, buf, sizeof(buf));
- printf("b == %s\n", buf);
- mp_to_hex(&c, buf, sizeof(buf));
- printf("c == %s\n", buf);
- goto LBL_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-#else
- return EXIT_SUCCESS;
-# endif /* LTM_DEMO_TEST_REDUCE_2K_L */
-}
-/* stripped down version of mp_radix_size. The faster version can be off by up t
-o +3 */
-/* TODO: This function should be removed, replaced by mp_radix_size, mp_radix_size_overestimate in 2.0 */
-static mp_err s_rs(const mp_int *a, int radix, uint32_t *size)
-{
- mp_err res;
- uint32_t digs = 0u;
- mp_int t;
- mp_digit d;
- *size = 0u;
- if (mp_iszero(a) == MP_YES) {
- *size = 2u;
- return MP_OKAY;
- }
- if (radix == 2) {
- *size = (uint32_t)mp_count_bits(a) + 1u;
- return MP_OKAY;
- }
- if ((res = mp_init_copy(&t, a)) != MP_OKAY) {
- return res;
- }
- t.sign = MP_ZPOS;
- while (mp_iszero(&t) == MP_NO) {
- if ((res = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) {
- mp_clear(&t);
- return res;
- }
- ++digs;
- }
- mp_clear(&t);
- *size = digs + 1;
- return MP_OKAY;
-}
-static int test_mp_log_u32(void)
-{
- mp_int a;
- mp_digit d;
- uint32_t base, lb, size;
- const uint32_t max_base = MP_MIN(UINT32_MAX, MP_DIGIT_MAX);
-
- if (mp_init(&a) != MP_OKAY) {
- goto LBL_ERR;
- }
-
- /*
- base a result
- 0 x MP_VAL
- 1 x MP_VAL
- */
- mp_set(&a, 42uL);
- base = 0u;
- if (mp_log_u32(&a, base, &lb) != MP_VAL) {
- goto LBL_ERR;
- }
- base = 1u;
- if (mp_log_u32(&a, base, &lb) != MP_VAL) {
- goto LBL_ERR;
- }
- /*
- base a result
- 2 0 MP_VAL
- 2 1 0
- 2 2 1
- 2 3 1
- */
- base = 2u;
- mp_zero(&a);
- if (mp_log_u32(&a, base, &lb) != MP_VAL) {
- goto LBL_ERR;
- }
-
- for (d = 1; d < 4; d++) {
- mp_set(&a, d);
- if (mp_log_u32(&a, base, &lb) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (lb != ((d == 1)?0uL:1uL)) {
- goto LBL_ERR;
- }
- }
- /*
- base a result
- 3 0 MP_VAL
- 3 1 0
- 3 2 0
- 3 3 1
- */
- base = 3u;
- mp_zero(&a);
- if (mp_log_u32(&a, base, &lb) != MP_VAL) {
- goto LBL_ERR;
- }
- for (d = 1; d < 4; d++) {
- mp_set(&a, d);
- if (mp_log_u32(&a, base, &lb) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (lb != ((d < base)?0uL:1uL)) {
- goto LBL_ERR;
- }
- }
-
- /*
- bases 2..64 with "a" a random large constant.
- The range of bases tested allows to check with
- radix_size.
- */
- if (mp_rand(&a, 10) != MP_OKAY) {
- goto LBL_ERR;
- }
- for (base = 2u; base < 65u; base++) {
- if (mp_log_u32(&a, base, &lb) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (s_rs(&a,(int)base, &size) != MP_OKAY) {
- goto LBL_ERR;
- }
- /* radix_size includes the memory needed for '\0', too*/
- size -= 2;
- if (lb != size) {
- goto LBL_ERR;
- }
- }
-
- /*
- bases 2..64 with "a" a random small constant to
- test the part of mp_ilogb that uses native types.
- */
- if (mp_rand(&a, 1) != MP_OKAY) {
- goto LBL_ERR;
- }
- for (base = 2u; base < 65u; base++) {
- if (mp_log_u32(&a, base, &lb) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (s_rs(&a,(int)base, &size) != MP_OKAY) {
- goto LBL_ERR;
- }
- size -= 2;
- if (lb != size) {
- goto LBL_ERR;
- }
- }
-
- /*Test upper edgecase with base UINT32_MAX and number (UINT32_MAX/2)*UINT32_MAX^10 */
- mp_set(&a, max_base);
- if (mp_expt_u32(&a, 10uL, &a) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_add_d(&a, max_base / 2, &a) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (mp_log_u32(&a, max_base, &lb) != MP_OKAY) {
- goto LBL_ERR;
- }
- if (lb != 10u) {
- goto LBL_ERR;
- }
-
- mp_clear(&a);
- return EXIT_SUCCESS;
-LBL_ERR:
- mp_clear(&a);
- return EXIT_FAILURE;
-}
-
-static int test_mp_incr(void)
-{
- mp_int a, b;
- mp_err e = MP_OKAY;
-
- if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- /* Does it increment inside the limits of a MP_xBIT limb? */
- mp_set(&a, MP_MASK/2);
- if ((e = mp_incr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp_d(&a, (MP_MASK/2uL) + 1uL) != MP_EQ) {
- goto LTM_ERR;
- }
-
- /* Does it increment outside of the limits of a MP_xBIT limb? */
- mp_set(&a, MP_MASK);
- mp_set(&b, MP_MASK);
- if ((e = mp_incr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((e = mp_add_d(&b, 1uL, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&a, &b) != MP_EQ) {
- goto LTM_ERR;
- }
-
- /* Does it increment from -1 to 0? */
- mp_set(&a, 1uL);
- a.sign = MP_NEG;
- if ((e = mp_incr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp_d(&a, 0uL) != MP_EQ) {
- goto LTM_ERR;
- }
-
- /* Does it increment from -(MP_MASK + 1) to -MP_MASK? */
- mp_set(&a, MP_MASK);
- if ((e = mp_add_d(&a, 1uL, &a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- a.sign = MP_NEG;
- if ((e = mp_incr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (a.sign != MP_NEG) {
- goto LTM_ERR;
- }
- a.sign = MP_ZPOS;
- if (mp_cmp_d(&a, MP_MASK) != MP_EQ) {
- goto LTM_ERR;
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_decr(void)
-{
- mp_int a, b;
- mp_err e = MP_OKAY;
-
- if ((e = mp_init_multi(&a, &b, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- /* Does it decrement inside the limits of a MP_xBIT limb? */
- mp_set(&a, MP_MASK/2);
- if ((e = mp_decr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp_d(&a, (MP_MASK/2uL) - 1uL) != MP_EQ) {
- goto LTM_ERR;
- }
-
- /* Does it decrement outside of the limits of a MP_xBIT limb? */
- mp_set(&a, MP_MASK);
- if ((e = mp_add_d(&a, 1uL, &a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((e = mp_decr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp_d(&a, MP_MASK) != MP_EQ) {
- goto LTM_ERR;
- }
-
- /* Does it decrement from 0 to -1? */
- mp_zero(&a);
- if ((e = mp_decr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (a.sign == MP_NEG) {
- a.sign = MP_ZPOS;
- if (mp_cmp_d(&a, 1uL) != MP_EQ) {
- goto LTM_ERR;
- }
- } else {
- goto LTM_ERR;
- }
-
-
- /* Does it decrement from -MP_MASK to -(MP_MASK + 1)? */
- mp_set(&a, MP_MASK);
- a.sign = MP_NEG;
- mp_set(&b, MP_MASK);
- b.sign = MP_NEG;
- if ((e = mp_sub_d(&b, 1uL, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((e = mp_decr(&a)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&a, &b) != MP_EQ) {
- goto LTM_ERR;
- }
-
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-/*
- Cannot test mp_exp(_d) without mp_root and vice versa.
- So one of the two has to be tested from scratch.
-
- Numbers generated by
- for i in {1..10}
- do
- seed=$(head -c 10000 /dev/urandom | tr -dc '[:digit:]' | head -c 120);
- echo $seed;
- convertbase $seed 10 64;
- done
-
- (The program "convertbase" uses libtommath's to/from_radix functions)
-
- Roots were precalculated with Pari/GP
-
- default(realprecision,1000);
- for(n=3,100,r = floor(a^(1/n));printf("\"" r "\", "))
-
- All numbers as strings to simplifiy things, especially for the
- low-mp branch.
-*/
-
-static int test_mp_root_u32(void)
-{
- mp_int a, c, r;
- mp_err e;
- int i, j;
-
- const char *input[] = {
- "4n9cbk886QtLQmofprid3l2Q0GD8Yv979Lh8BdZkFE8g2pDUUSMBET/+M/YFyVZ3mBp",
- "5NlgzHhmIX05O5YoW5yW5reAlVNtRAlIcN2dfoATnNdc1Cw5lHZUTwNthmK6/ZLKfY6",
- "3gweiHDX+ji5utraSe46IJX+uuh7iggs63xIpMP5MriU4Np+LpHI5are8RzS9pKh9xP",
- "5QOJUSKMrfe7LkeyJOlupS8h7bjT+TXmZkDzOjZtfj7mdA7cbg0lRX3CuafhjIrpK8S",
- "4HtYFldVkyVbrlg/s7kmaA7j45PvLQm+1bbn6ehgP8tVoBmGbv2yDQI1iQQze4AlHyN",
- "3bwCUx79NAR7c68OPSp5ZabhZ9aBEr7rWNTO2oMY7zhbbbw7p6shSMxqE9K9nrTNucf",
- "4j5RGb78TfuYSzrXn0z6tiAoWiRI81hGY3el9AEa9S+gN4x/AmzotHT2Hvj6lyBpE7q",
- "4lwg30SXqZhEHNsl5LIXdyu7UNt0VTWebP3m7+WUL+hsnFW9xJe7UnzYngZsvWh14IE",
- "1+tcqFeRuGqjRADRoRUJ8gL4UUSFQVrVVoV6JpwVcKsuBq5G0pABn0dLcQQQMViiVRj",
- "hXwxuFySNSFcmbrs/coz4FUAaUYaOEt+l4V5V8vY71KyBvQPxRq/6lsSrG2FHvWDax"
- };
- /* roots 3-100 of the above */
- const char *root[10][100] = {
- {
- "9163694094944489658600517465135586130944",
- "936597377180979771960755204040", "948947857956884030956907",
- "95727185767390496595", "133844854039712620", "967779611885360",
- "20926191452627", "974139547476", "79203891950", "9784027073",
- "1667309744", "365848129", "98268452", "31109156", "11275351",
- "4574515", "2040800", "986985", "511525", "281431", "163096",
- "98914", "62437", "40832", "27556", "19127", "13614", "9913",
- "7367", "5577", "4294", "3357", "2662", "2138", "1738", "1428",
- "1185", "993", "839", "715", "613", "530", "461", "403", "355",
- "314", "279", "249", "224", "202", "182", "166", "151", "138",
- "126", "116", "107", "99", "92", "85", "79", "74", "69", "65", "61",
- "57", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34",
- "32", "31", "30", "28", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "9534798256755061606359588498764080011382",
- "964902943621813525741417593772", "971822399862464674540423",
- "97646291566833512831", "136141536090599560", "982294733581430",
- "21204945933335", "985810529393", "80066084985", "9881613813",
- "1682654547", "368973625", "99051783", "31341581", "11354620",
- "4604882", "2053633", "992879", "514434", "282959", "163942",
- "99406", "62736", "41020", "27678", "19208", "13670", "9952",
- "7395", "5598", "4310", "3369", "2671", "2145", "1744", "1433",
- "1189", "996", "842", "717", "615", "531", "462", "404", "356",
- "315", "280", "250", "224", "202", "183", "166", "151", "138",
- "127", "116", "107", "99", "92", "85", "80", "74", "70", "65", "61",
- "58", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34",
- "32", "31", "30", "29", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "8398539113202579297642815367509019445624",
- "877309458945432597462853440936", "900579899458998599215071",
- "91643543761699761637", "128935656335800903", "936647990947203",
- "20326748623514", "948988882684", "77342677787", "9573063447",
- "1634096832", "359076114", "96569670", "30604705", "11103188",
- "4508519", "2012897", "974160", "505193", "278105", "161251",
- "97842", "61788", "40423", "27291", "18949", "13492", "9826",
- "7305", "5532", "4260", "3332", "2642", "2123", "1726", "1418",
- "1177", "986", "834", "710", "610", "527", "458", "401", "353",
- "312", "278", "248", "223", "201", "181", "165", "150", "137",
- "126", "116", "107", "99", "91", "85", "79", "74", "69", "65", "61",
- "57", "54", "51", "48", "46", "43", "41", "39", "37", "35", "34",
- "32", "31", "30", "28", "27", "26", "25", "24", "23", "22", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "9559098494021810340217797724866627755195",
- "966746709063325235560830083787", "973307706084821682248292",
- "97770642291138756434", "136290128605981259", "983232784778520",
- "21222944848922", "986563584410", "80121684894", "9887903837",
- "1683643206", "369174929", "99102220", "31356542", "11359721",
- "4606836", "2054458", "993259", "514621", "283057", "163997",
- "99437", "62755", "41032", "27686", "19213", "13674", "9955",
- "7397", "5599", "4311", "3370", "2672", "2146", "1744", "1433",
- "1189", "996", "842", "717", "615", "532", "462", "404", "356",
- "315", "280", "250", "224", "202", "183", "166", "151", "138",
- "127", "116", "107", "99", "92", "86", "80", "74", "70", "65", "61",
- "58", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34",
- "32", "31", "30", "29", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "8839202025813295923132694443541993309220",
- "911611499784863252820288596270", "928640961450376817534853",
- "94017030509441723821", "131792686685970629", "954783483196511",
- "20676214073400", "963660189823", "78428929840", "9696237956",
- "1653495486", "363032624", "97562430", "30899570", "11203842",
- "4547110", "2029216", "981661", "508897", "280051", "162331",
- "98469", "62168", "40663", "27446", "19053", "13563", "9877",
- "7341", "5558", "4280", "3347", "2654", "2132", "1733", "1424",
- "1182", "990", "837", "713", "612", "529", "460", "402", "354",
- "313", "279", "249", "223", "201", "182", "165", "150", "138",
- "126", "116", "107", "99", "92", "85", "79", "74", "69", "65", "61",
- "57", "54", "51", "48", "46", "43", "41", "39", "37", "36", "34",
- "32", "31", "30", "28", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "8338442683973420410660145045849076963795",
- "872596990706967613912664152945", "896707843885562730147307",
- "91315073695274540969", "128539440806486007", "934129001105825",
- "20278149285734", "946946589774", "77191347471", "9555892093",
- "1631391010", "358523975", "96431070", "30563524", "11089126",
- "4503126", "2010616", "973111", "504675", "277833", "161100",
- "97754", "61734", "40390", "27269", "18934", "13482", "9819",
- "7300", "5528", "4257", "3330", "2641", "2122", "1725", "1417",
- "1177", "986", "833", "710", "609", "527", "458", "401", "353",
- "312", "278", "248", "222", "200", "181", "165", "150", "137",
- "126", "116", "107", "99", "91", "85", "79", "74", "69", "65", "61",
- "57", "54", "51", "48", "46", "43", "41", "39", "37", "35", "34",
- "32", "31", "30", "28", "27", "26", "25", "24", "23", "22", "22",
- "21", "20", "20", "19", "18", "18", "17", "17", "16", "16", "15"
- }, {
- "9122818552483814953977703257848970704164",
- "933462289569511464780529972314", "946405863353935713909178",
- "95513446972056321834", "133588658082928446",
- "966158521967027", "20895030642048", "972833934108",
- "79107381638", "9773098125", "1665590516", "365497822",
- "98180628", "31083090", "11266459", "4571108", "2039360",
- "986323", "511198", "281260", "163001", "98858",
- "62404", "40811", "27543", "19117", "13608", "9908",
- "7363", "5575", "4292", "3356", "2661", "2138",
- "1737", "1428", "1185", "993", "839", "714", "613",
- "530", "461", "403", "355", "314", "279", "249",
- "224", "202", "182", "165", "151", "138", "126",
- "116", "107", "99", "92", "85", "79", "74", "69",
- "65", "61", "57", "54", "51", "48", "46", "43",
- "41", "39", "37", "36", "34", "32", "31", "30",
- "28", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17",
- "16", "16", "15"
- }, {
- "9151329724083804100369546479681933027521",
- "935649419557299174433860420387", "948179413831316112751907",
- "95662582675170358900", "133767426788182384",
- "967289728859610", "20916775466497", "973745045600",
- "79174731802", "9780725058", "1666790321", "365742295",
- "98241919", "31101281", "11272665", "4573486", "2040365",
- "986785", "511426", "281380", "163067", "98897",
- "62427", "40826", "27552", "19124", "13612", "9911",
- "7366", "5576", "4294", "3357", "2662", "2138",
- "1738", "1428", "1185", "993", "839", "715", "613",
- "530", "461", "403", "355", "314", "279", "249",
- "224", "202", "182", "165", "151", "138", "126",
- "116", "107", "99", "92", "85", "79", "74", "69",
- "65", "61", "57", "54", "51", "48", "46", "43",
- "41", "39", "37", "36", "34", "32", "31", "30",
- "28", "27", "26", "25", "24", "23", "23", "22",
- "21", "20", "20", "19", "18", "18", "17", "17",
- "16", "16", "15"
- }, {
- "6839396355168045468586008471269923213531",
- "752078770083218822016981965090", "796178899357307807726034",
- "82700643015444840424", "118072966296549115",
- "867224751770392", "18981881485802", "892288574037",
- "73130030771", "9093989389", "1558462688", "343617470",
- "92683740", "29448679", "10708016", "4356820", "1948676",
- "944610", "490587", "270425", "156989", "95362",
- "60284", "39477", "26675", "18536", "13208", "9627",
- "7161", "5426", "4181", "3272", "2596", "2087",
- "1697", "1395", "1159", "971", "821", "700", "601",
- "520", "452", "396", "348", "308", "274", "245",
- "220", "198", "179", "163", "148", "136", "124",
- "114", "106", "98", "91", "84", "78", "73", "68",
- "64", "60", "57", "53", "50", "48", "45", "43",
- "41", "39", "37", "35", "34", "32", "31", "29",
- "28", "27", "26", "25", "24", "23", "22", "22",
- "21", "20", "19", "19", "18", "18", "17", "17",
- "16", "16", "15"
- }, {
- "4788090721380022347683138981782307670424",
- "575601315594614059890185238256", "642831903229558719812840",
- "69196031110028430211", "101340693763170691",
- "758683936560287", "16854690815260", "801767985909",
- "66353290503", "8318415180", "1435359033", "318340531",
- "86304307", "27544217", "10054988", "4105446", "1841996",
- "895414", "466223", "257591", "149855", "91205",
- "57758", "37886", "25639", "17842", "12730", "9290",
- "6918", "5248", "4048", "3170", "2518", "2026",
- "1649", "1357", "1128", "946", "800", "682", "586",
- "507", "441", "387", "341", "302", "268", "240",
- "215", "194", "176", "160", "146", "133", "122",
- "112", "104", "96", "89", "83", "77", "72", "67",
- "63", "59", "56", "53", "50", "47", "45", "42",
- "40", "38", "36", "35", "33", "32", "30", "29",
- "28", "27", "26", "25", "24", "23", "22", "21",
- "21", "20", "19", "19", "18", "17", "17", "16",
- "16", "15", "15"
- }
- };
-
- if ((e = mp_init_multi(&a, &c, &r, NULL)) != MP_OKAY) {
- return EXIT_FAILURE;
- }
-#ifdef MP_8BIT
- for (i = 0; i < 1; i++) {
-#else
- for (i = 0; i < 10; i++) {
-#endif
- mp_read_radix(&a, input[i], 64);
-#ifdef MP_8BIT
- for (j = 3; j < 10; j++) {
-#else
- for (j = 3; j < 100; j++) {
-#endif
- mp_root_u32(&a, (uint32_t)j, &c);
- mp_read_radix(&r, root[i][j-3], 10);
- if (mp_cmp(&r, &c) != MP_EQ) {
- fprintf(stderr, "mp_root_u32 failed at input #%d, root #%d\n", i, j);
- goto LTM_ERR;
- }
- }
- }
- mp_clear_multi(&a, &c, &r, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &c, &r, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_s_mp_balance_mul(void)
-{
- mp_int a, b, c;
- mp_err e = MP_OKAY;
-
- const char *na =
- "4b0I5uMTujCysw+1OOuOyH2FX2WymrHUqi8BBDb7XpkV/4i7vXTbEYUy/kdIfCKu5jT5JEqYkdmnn3jAYo8XShPzNLxZx9yoLjxYRyptSuOI2B1DspvbIVYXY12sxPZ4/HCJ4Usm2MU5lO/006KnDMxuxiv1rm6YZJZ0eZU";
- const char *nb = "3x9vs0yVi4hIq7poAeVcggC3WoRt0zRLKO";
- const char *nc =
- "HzrSq9WVt1jDTVlwUxSKqxctu2GVD+N8+SVGaPFRqdxyld6IxDBbj27BPJzYUdR96k3sWpkO8XnDBvupGPnehpQe4KlO/KmN1PjFov/UTZYM+LYzkFcBPyV6hkkL8ePC1rlFLAHzgJMBCXVp4mRqtkQrDsZXXlcqlbTFu69wF6zDEysiX2cAtn/kP9ldblJiwYPCD8hG";
-
- if ((e = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((e = mp_read_radix(&a, na, 64)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((e = mp_read_radix(&b, nb, 64)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((e = s_mp_balance_mul(&a, &b, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((e = mp_read_radix(&b, nc, 64)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if (mp_cmp(&b, &c) != MP_EQ) {
- goto LTM_ERR;
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
-static int test_s_mp_karatsuba_mul(void)
-{
- mp_int a, b, c, d;
- int size, err;
-
- if ((err = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
- for (size = MP_KARATSUBA_MUL_CUTOFF; size < MP_KARATSUBA_MUL_CUTOFF + 20; size++) {
- if ((err = mp_rand(&a, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_rand(&b, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_karatsuba_mul(&a, &b, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_mul(&a,&b,&d)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&c, &d) != MP_EQ) {
- fprintf(stderr, "Karatsuba multiplication failed at size %d\n", size);
- goto LTM_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_s_mp_karatsuba_sqr(void)
-{
- mp_int a, b, c;
- int size, err;
-
- if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
- for (size = MP_KARATSUBA_SQR_CUTOFF; size < MP_KARATSUBA_SQR_CUTOFF + 20; size++) {
- if ((err = mp_rand(&a, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_karatsuba_sqr(&a, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_sqr(&a, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&b, &c) != MP_EQ) {
- fprintf(stderr, "Karatsuba squaring failed at size %d\n", size);
- goto LTM_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_s_mp_toom_mul(void)
-{
- mp_int a, b, c, d;
- int size, err;
-
-#if (MP_DIGIT_BIT == 60)
- int tc_cutoff;
-#endif
-
- if ((err = mp_init_multi(&a, &b, &c, &d, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
- /* This number construction is limb-size specific */
-#if (MP_DIGIT_BIT == 60)
- if ((err = mp_rand(&a, 1196)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_mul_2d(&a,71787 - mp_count_bits(&a), &a)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((err = mp_rand(&b, 1338)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_mul_2d(&b, 80318 - mp_count_bits(&b), &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_mul_2d(&b, 6310, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_2expt(&c, 99000 - 1000)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_add(&b, &c, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- tc_cutoff = TOOM_MUL_CUTOFF;
- TOOM_MUL_CUTOFF = INT_MAX;
- if ((err = mp_mul(&a, &b, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
- TOOM_MUL_CUTOFF = tc_cutoff;
- if ((err = mp_mul(&a, &b, &d)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&c, &d) != MP_EQ) {
- fprintf(stderr, "Toom-Cook 3-way multiplication failed for edgecase f1 * f2\n");
- goto LTM_ERR;
- }
-#endif
-
- for (size = MP_TOOM_MUL_CUTOFF; size < MP_TOOM_MUL_CUTOFF + 20; size++) {
- if ((err = mp_rand(&a, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = mp_rand(&b, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_toom_mul(&a, &b, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_mul(&a,&b,&d)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&c, &d) != MP_EQ) {
- fprintf(stderr, "Toom-Cook 3-way multiplication failed at size %d\n", size);
- goto LTM_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, &c, &d, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_s_mp_toom_sqr(void)
-{
- mp_int a, b, c;
- int size, err;
-
- if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
- for (size = MP_TOOM_SQR_CUTOFF; size < MP_TOOM_SQR_CUTOFF + 20; size++) {
- if ((err = mp_rand(&a, size)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_toom_sqr(&a, &b)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if ((err = s_mp_sqr(&a, &c)) != MP_OKAY) {
- goto LTM_ERR;
- }
- if (mp_cmp(&b, &c) != MP_EQ) {
- fprintf(stderr, "Toom-Cook 3-way squaring failed at size %d\n", size);
- goto LTM_ERR;
- }
- }
-
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_read_write_ubin(void)
-{
- mp_int a, b, c;
- int err;
- size_t size, len;
- unsigned char *buf = NULL;
-
- if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_neg(&a, &b)) != MP_OKAY) goto LTM_ERR;
-
- size = mp_ubin_size(&a);
- printf("mp_to_ubin_size %zu\n", size);
- buf = (unsigned char *)malloc(sizeof(*buf) * size);
- if (buf == NULL) {
- fprintf(stderr, "test_read_write_binaries (u) failed to allocate %zu bytes\n",
- sizeof(*buf) * size);
- goto LTM_ERR;
- }
-
- if ((err = mp_to_ubin(&a, buf, size, &len)) != MP_OKAY) goto LTM_ERR;
- printf("mp_to_ubin len = %zu\n", len);
-
- if ((err = mp_from_ubin(&c, buf, len)) != MP_OKAY) goto LTM_ERR;
-
- if (mp_cmp(&a, &c) != MP_EQ) {
- fprintf(stderr, "to/from ubin cycle failed\n");
- goto LTM_ERR;
- }
- free(buf);
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- free(buf);
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_read_write_sbin(void)
-{
- mp_int a, b, c;
- int err;
- size_t size, len;
- unsigned char *buf = NULL;
-
- if ((err = mp_init_multi(&a, &b, &c, NULL)) != MP_OKAY) {
- goto LTM_ERR;
- }
-
- if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_neg(&a, &b)) != MP_OKAY) goto LTM_ERR;
-
- size = mp_sbin_size(&a);
- printf("mp_to_sbin_size %zu\n", size);
- buf = (unsigned char *)malloc(sizeof(*buf) * size);
- if (buf == NULL) {
- fprintf(stderr, "test_read_write_binaries (s) failed to allocate %zu bytes\n",
- sizeof(*buf) * size);
- goto LTM_ERR;
- }
-
- if ((err = mp_to_sbin(&b, buf, size, &len)) != MP_OKAY) goto LTM_ERR;
- printf("mp_to_sbin len = %zu\n", len);
-
- if ((err = mp_from_sbin(&c, buf, len)) != MP_OKAY) goto LTM_ERR;
-
- if (mp_cmp(&b, &c) != MP_EQ) {
- fprintf(stderr, "to/from ubin cycle failed\n");
- goto LTM_ERR;
- }
-
- free(buf);
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- free(buf);
- mp_clear_multi(&a, &b, &c, NULL);
- return EXIT_FAILURE;
-}
-
-static int test_mp_pack_unpack(void)
-{
- mp_int a, b;
- int err;
- size_t written, count;
- unsigned char *buf = NULL;
-
- mp_order order = MP_LSB_FIRST;
- mp_endian endianess = MP_NATIVE_ENDIAN;
-
- if ((err = mp_init_multi(&a, &b, NULL)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_rand(&a, 15)) != MP_OKAY) goto LTM_ERR;
-
- count = mp_pack_count(&a, 0, 1);
-
- buf = (unsigned char *)malloc(count);
- if (buf == NULL) {
- fprintf(stderr, "test_pack_unpack failed to allocate\n");
- goto LTM_ERR;
- }
-
- if ((err = mp_pack((void *)buf, count, &written, order, 1,
- endianess, 0, &a)) != MP_OKAY) goto LTM_ERR;
- if ((err = mp_unpack(&b, count, order, 1,
- endianess, 0, (const void *)buf)) != MP_OKAY) goto LTM_ERR;
-
- if (mp_cmp(&a, &b) != MP_EQ) {
- fprintf(stderr, "pack/unpack cycle failed\n");
- goto LTM_ERR;
- }
-
- free(buf);
- mp_clear_multi(&a, &b, NULL);
- return EXIT_SUCCESS;
-LTM_ERR:
- free(buf);
- mp_clear_multi(&a, &b, NULL);
- return EXIT_FAILURE;
-}
-
-static int unit_tests(int argc, char **argv)
-{
- static const struct {
- const char *name;
- int (*fn)(void);
- } test[] = {
-#define T0(n) { #n, test_##n }
-#define T1(n, o) { #n, MP_HAS(o) ? test_##n : NULL }
-#define T2(n, o1, o2) { #n, MP_HAS(o1) && MP_HAS(o2) ? test_##n : NULL }
- T0(feature_detection),
- T0(trivial_stuff),
- T2(mp_get_set_i32, MP_GET_I32, MP_GET_MAG_U32),
- T2(mp_get_set_i64, MP_GET_I64, MP_GET_MAG_U64),
- T1(mp_and, MP_AND),
- T1(mp_cnt_lsb, MP_CNT_LSB),
- T1(mp_complement, MP_COMPLEMENT),
- T1(mp_decr, MP_DECR),
- T1(mp_div_3, MP_DIV_3),
- T1(mp_dr_reduce, MP_DR_REDUCE),
- T2(mp_pack_unpack,MP_PACK, MP_UNPACK),
- T2(mp_fread_fwrite, MP_FREAD, MP_FWRITE),
- T1(mp_get_u32, MP_GET_I32),
- T1(mp_get_u64, MP_GET_I64),
- T1(mp_get_ul, MP_GET_L),
- T1(mp_log_u32, MP_LOG_U32),
- T1(mp_incr, MP_INCR),
- T1(mp_invmod, MP_INVMOD),
- T1(mp_is_square, MP_IS_SQUARE),
- T1(mp_kronecker, MP_KRONECKER),
- T1(mp_montgomery_reduce, MP_MONTGOMERY_REDUCE),
- T1(mp_root_u32, MP_ROOT_U32),
- T1(mp_or, MP_OR),
- T1(mp_prime_is_prime, MP_PRIME_IS_PRIME),
- T1(mp_prime_next_prime, MP_PRIME_NEXT_PRIME),
- T1(mp_prime_rand, MP_PRIME_RAND),
- T1(mp_rand, MP_RAND),
- T1(mp_read_radix, MP_READ_RADIX),
- T1(mp_read_write_ubin, MP_TO_UBIN),
- T1(mp_read_write_sbin, MP_TO_SBIN),
- T1(mp_reduce_2k, MP_REDUCE_2K),
- T1(mp_reduce_2k_l, MP_REDUCE_2K_L),
-#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
- T1(mp_set_double, MP_SET_DOUBLE),
-#endif
- T1(mp_signed_rsh, MP_SIGNED_RSH),
- T1(mp_sqrt, MP_SQRT),
- T1(mp_sqrtmod_prime, MP_SQRTMOD_PRIME),
- T1(mp_xor, MP_XOR),
- T1(s_mp_balance_mul, S_MP_BALANCE_MUL),
- T1(s_mp_karatsuba_mul, S_MP_KARATSUBA_MUL),
- T1(s_mp_karatsuba_sqr, S_MP_KARATSUBA_SQR),
- T1(s_mp_toom_mul, S_MP_TOOM_MUL),
- T1(s_mp_toom_sqr, S_MP_TOOM_SQR)
-#undef T2
-#undef T1
- };
- unsigned long i, ok, fail, nop;
- uint64_t t;
- int j;
-
- ok = fail = nop = 0;
-
- t = (uint64_t)time(NULL);
- printf("SEED: 0x%" PRIx64 "\n\n", t);
- s_mp_rand_jenkins_init(t);
- mp_rand_source(s_mp_rand_jenkins);
-
- for (i = 0; i < sizeof(test) / sizeof(test[0]); ++i) {
- if (argc > 1) {
- for (j = 1; j < argc; ++j) {
- if (strstr(test[i].name, argv[j]) != NULL) {
- break;
- }
- }
- if (j == argc) continue;
- }
- printf("TEST %s\n\n", test[i].name);
- if (test[i].fn == NULL) {
- nop++;
- printf("NOP %s\n\n", test[i].name);
- } else if (test[i].fn() == EXIT_SUCCESS) {
- ok++;
- printf("\n\n");
- } else {
- fail++;
- printf("\n\nFAIL %s\n\n", test[i].name);
- }
- }
- printf("Tests OK/NOP/FAIL: %lu/%lu/%lu\n", ok, nop, fail);
-
- if (fail != 0) return EXIT_FAILURE;
- else return EXIT_SUCCESS;
-}
-
-int main(int argc, char **argv)
-{
- print_header();
-
- return unit_tests(argc, argv);
-}
diff --git a/libtommath/testme.sh b/libtommath/testme.sh
deleted file mode 100755
index 40fa32d..0000000
--- a/libtommath/testme.sh
+++ /dev/null
@@ -1,394 +0,0 @@
-#!/bin/bash
-#
-# return values of this script are:
-# 0 success
-# 128 a test failed
-# >0 the number of timed-out tests
-# 255 parsing of parameters failed
-
-set -e
-
-if [ -f /proc/cpuinfo ]
-then
- MAKE_JOBS=$(( ($(cat /proc/cpuinfo | grep -E '^processor[[:space:]]*:' | tail -n -1 | cut -d':' -f2) + 1) * 2 + 1 ))
-else
- MAKE_JOBS=8
-fi
-
-ret=0
-TEST_CFLAGS=""
-
-_help()
-{
- echo "Usage options for $(basename $0) [--with-cc=arg [other options]]"
- echo
- echo "Executing this script without any parameter will only run the default"
- echo "configuration that has automatically been determined for the"
- echo "architecture you're running."
- echo
- echo " --with-cc=* The compiler(s) to use for the tests"
- echo " This is an option that will be iterated."
- echo
- echo " --test-vs-mtest=* Run test vs. mtest for '*' operations."
- echo " Only the first of each options will be"
- echo " taken into account."
- echo
- echo "To be able to specify options a compiler has to be given with"
- echo "the option --with-cc=compilername"
- echo "All other options will be tested with all MP_xBIT configurations."
- echo
- echo " --with-{m64,m32,mx32} The architecture(s) to build and test"
- echo " for, e.g. --with-mx32."
- echo " This is an option that will be iterated,"
- echo " multiple selections are possible."
- echo " The mx32 architecture is not supported"
- echo " by clang and will not be executed."
- echo
- echo " --cflags=* Give an option to the compiler,"
- echo " e.g. --cflags=-g"
- echo " This is an option that will always be"
- echo " passed as parameter to CC."
- echo
- echo " --make-option=* Give an option to make,"
- echo " e.g. --make-option=\"-f makefile.shared\""
- echo " This is an option that will always be"
- echo " passed as parameter to make."
- echo
- echo " --with-low-mp Also build&run tests with -DMP_{8,16,32}BIT."
- echo
- echo " --mtest-real-rand Use real random data when running mtest."
- echo
- echo " --with-valgrind"
- echo " --with-valgrind=* Run in valgrind (slow!)."
- echo
- echo " --with-travis-valgrind Run with valgrind on Travis on specific branches."
- echo
- echo " --valgrind-options Additional Valgrind options"
- echo " Some of the options like e.g.:"
- echo " --track-origins=yes add a lot of extra"
- echo " runtime and may trigger the 30 minutes"
- echo " timeout."
- echo
- echo "Godmode:"
- echo
- echo " --all Choose all architectures and gcc and clang"
- echo " as compilers but does not run valgrind."
- echo
- echo " --format Runs the various source-code formatters"
- echo " and generators and checks if the sources"
- echo " are clean."
- echo
- echo " -h"
- echo " --help This message"
- echo
- echo " -v"
- echo " --version Prints the version. It is just the number"
- echo " of git commits to this file, no deeper"
- echo " meaning attached"
- exit 0
-}
-
-_die()
-{
- echo "error $2 while $1"
- if [ "$2" != "124" ]
- then
- exit 128
- else
- echo "assuming timeout while running test - continue"
- local _tail=""
- which tail >/dev/null && _tail="tail -n 1 test_${suffix}.log" && \
- echo "last line of test_"${suffix}".log was:" && $_tail && echo ""
- ret=$(( $ret + 1 ))
- fi
-}
-
-_make()
-{
- echo -ne " Compile $1 $2"
- suffix=$(echo ${1}${2} | tr ' ' '_')
- CC="$1" CFLAGS="$2 $TEST_CFLAGS" make -j$MAKE_JOBS $3 $MAKE_OPTIONS > /dev/null 2>gcc_errors_${suffix}.log
- errcnt=$(wc -l < gcc_errors_${suffix}.log)
- if [[ ${errcnt} -gt 1 ]]; then
- echo " failed"
- cat gcc_errors_${suffix}.log
- exit 128
- fi
-}
-
-
-_runtest()
-{
- make clean > /dev/null
- local _timeout=""
- which timeout >/dev/null && _timeout="timeout --foreground 90"
- if [[ "$MAKE_OPTIONS" =~ "tune" ]]
- then
- # "make tune" will run "tune_it.sh" automatically, hence "autotune", but it cannot
- # get switched off without some effort, so we just let it run twice for testing purposes
- echo -e "\rRun autotune $1 $2"
- _make "$1" "$2" ""
- $_timeout $TUNE_CMD > test_${suffix}.log || _die "running autotune" $?
- else
- _make "$1" "$2" "test"
- echo -e "\rRun test $1 $2"
- $_timeout ./test > test_${suffix}.log || _die "running tests" $?
- fi
-}
-
-# This is not much more of a C&P of _runtest with a different timeout
-# and the additional valgrind call.
-# TODO: merge
-_runvalgrind()
-{
- make clean > /dev/null
- local _timeout=""
- # 30 minutes? Yes. Had it at 20 minutes and the Valgrind run needed over 25 minutes.
- # A bit too close for comfort.
- which timeout >/dev/null && _timeout="timeout --foreground 1800"
-echo "MAKE_OPTIONS = \"$MAKE_OPTIONS\""
- if [[ "$MAKE_OPTIONS" =~ "tune" ]]
- then
-echo "autotune branch"
- _make "$1" "$2" ""
- # The shell used for /bin/sh is DASH 0.5.7-4ubuntu1 on the author's machine which fails valgrind, so
- # we just run on instance of etc/tune with the same options as in etc/tune_it.sh
- echo -e "\rRun etc/tune $1 $2 once inside valgrind"
- $_timeout $VALGRIND_BIN $VALGRIND_OPTS $TUNE_CMD > test_${suffix}.log || _die "running etc/tune" $?
- else
- _make "$1" "$2" "test"
- echo -e "\rRun test $1 $2 inside valgrind"
- $_timeout $VALGRIND_BIN $VALGRIND_OPTS ./test > test_${suffix}.log || _die "running tests" $?
- fi
-}
-
-
-_banner()
-{
- echo "uname="$(uname -a)
- [[ "$#" != "0" ]] && (echo $1=$($1 -dumpversion)) || true
-}
-
-_exit()
-{
- if [ "$ret" == "0" ]
- then
- echo "Tests successful"
- else
- echo "$ret tests timed out"
- fi
-
- exit $ret
-}
-
-ARCHFLAGS=""
-COMPILERS=""
-CFLAGS=""
-WITH_LOW_MP=""
-TEST_VS_MTEST=""
-MTEST_RAND=""
-# timed with an AMD A8-6600K
-# 25 minutes
-#VALGRIND_OPTS=" --track-origins=yes --leak-check=full --show-leak-kinds=all --error-exitcode=1 "
-# 9 minutes (14 minutes with --test-vs-mtest=333333 --mtest-real-rand)
-VALGRIND_OPTS=" --leak-check=full --show-leak-kinds=all --error-exitcode=1 "
-#VALGRIND_OPTS=""
-VALGRIND_BIN=""
-CHECK_FORMAT=""
-TUNE_CMD="./etc/tune -t -r 10 -L 3"
-
-alive_pid=0
-
-function kill_alive() {
- disown $alive_pid || true
- kill $alive_pid 2>/dev/null
-}
-
-function start_alive_printing() {
- [ "$alive_pid" == "0" ] || return 0;
- for i in `seq 1 10` ; do sleep 300 && echo "Tests still in Progress..."; done &
- alive_pid=$!
- trap kill_alive EXIT
-}
-
-while [ $# -gt 0 ];
-do
- case $1 in
- "--with-m64" | "--with-m32" | "--with-mx32")
- ARCHFLAGS="$ARCHFLAGS ${1:6}"
- ;;
- --with-cc=*)
- COMPILERS="$COMPILERS ${1#*=}"
- ;;
- --cflags=*)
- CFLAGS="$CFLAGS ${1#*=}"
- ;;
- --valgrind-options=*)
- VALGRIND_OPTS="$VALGRIND_OPTS ${1#*=}"
- ;;
- --with-valgrind*)
- if [[ ${1#*d} != "" ]]
- then
- VALGRIND_BIN="${1#*=}"
- else
- VALGRIND_BIN="valgrind"
- fi
- start_alive_printing
- ;;
- --with-travis-valgrind*)
- if [[ ("$TRAVIS_BRANCH" == "develop" && "$TRAVIS_PULL_REQUEST" == "false") || "$TRAVIS_BRANCH" == *"valgrind"* || "$TRAVIS_COMMIT_MESSAGE" == *"valgrind"* ]]
- then
- if [[ ${1#*d} != "" ]]
- then
- VALGRIND_BIN="${1#*=}"
- else
- VALGRIND_BIN="valgrind"
- fi
- start_alive_printing
- fi
- ;;
- --make-option=*)
- MAKE_OPTIONS="$MAKE_OPTIONS ${1#*=}"
- ;;
- --with-low-mp)
- WITH_LOW_MP="1"
- ;;
- --test-vs-mtest=*)
- TEST_VS_MTEST="${1#*=}"
- if ! [ "$TEST_VS_MTEST" -eq "$TEST_VS_MTEST" ] 2> /dev/null
- then
- echo "--test-vs-mtest Parameter has to be int"
- exit 255
- fi
- start_alive_printing
- ;;
- --mtest-real-rand)
- MTEST_RAND="-DLTM_MTEST_REAL_RAND"
- ;;
- --format)
- CHECK_FORMAT="1"
- ;;
- --all)
- COMPILERS="gcc clang"
- ARCHFLAGS="-m64 -m32 -mx32"
- ;;
- --help | -h)
- _help
- ;;
- --version | -v)
- echo $(git rev-list HEAD --count -- testme.sh) || echo "Unknown. Please run in original libtommath git repository."
- exit 0
- ;;
- *)
- echo "Ignoring option ${1}"
- ;;
- esac
- shift
-done
-
-function _check_git() {
- git update-index --refresh >/dev/null || true
- git diff-index --quiet HEAD -- . || ( echo "FAILURE: $*" && exit 1 )
-}
-
-if [[ "$CHECK_FORMAT" == "1" ]]
-then
- make astyle
- _check_git "make astyle"
- perl helper.pl --update-files
- _check_git "helper.pl --update-files"
- perl helper.pl --check-all
- _check_git "helper.pl --check-all"
- exit $?
-fi
-
-[[ "$VALGRIND_BIN" == "" ]] && VALGRIND_OPTS=""
-
-# default to CC environment variable if no compiler is defined but some other options
-if [[ "$COMPILERS" == "" ]] && [[ "$ARCHFLAGS$MAKE_OPTIONS$CFLAGS" != "" ]]
-then
- COMPILERS="$CC"
-# default to CC environment variable and run only default config if no option is given
-elif [[ "$COMPILERS" == "" ]]
-then
- _banner "$CC"
- if [[ "$VALGRIND_BIN" != "" ]]
- then
- _runvalgrind "$CC" ""
- else
- _runtest "$CC" ""
- fi
- _exit
-fi
-
-
-archflags=( $ARCHFLAGS )
-compilers=( $COMPILERS )
-
-# choosing a compiler without specifying an architecture will use the default architecture
-if [ "${#archflags[@]}" == "0" ]
-then
- archflags[0]=" "
-fi
-
-_banner
-
-if [[ "$TEST_VS_MTEST" != "" ]]
-then
- make clean > /dev/null
- _make "${compilers[0]} ${archflags[0]}" "$CFLAGS" "mtest_opponent"
- echo
- _make "gcc" "$MTEST_RAND" "mtest"
- echo
- echo "Run test vs. mtest for $TEST_VS_MTEST iterations"
- _timeout=""
- which timeout >/dev/null && _timeout="timeout --foreground 1800"
- $_timeout ./mtest/mtest $TEST_VS_MTEST | $VALGRIND_BIN $VALGRIND_OPTS ./mtest_opponent > valgrind_test.log 2> test_vs_mtest_err.log
- retval=$?
- head -n 5 valgrind_test.log
- tail -n 2 valgrind_test.log
- exit $retval
-fi
-
-for i in "${compilers[@]}"
-do
- if [ -z "$(which $i)" ]
- then
- echo "Skipped compiler $i, file not found"
- continue
- fi
- compiler_version=$(echo "$i="$($i -dumpversion))
- if [ "$compiler_version" == "clang=4.2.1" ]
- then
- # one of my versions of clang complains about some stuff in stdio.h and stdarg.h ...
- TEST_CFLAGS="-Wno-typedef-redefinition"
- else
- TEST_CFLAGS=""
- fi
- echo $compiler_version
-
- for a in "${archflags[@]}"
- do
- if [[ $(expr "$i" : "clang") -ne 0 && "$a" == "-mx32" ]]
- then
- echo "clang -mx32 tests skipped"
- continue
- fi
- if [[ "$VALGRIND_BIN" != "" ]]
- then
- _runvalgrind "$i $a" "$CFLAGS"
- [ "$WITH_LOW_MP" != "1" ] && continue
- _runvalgrind "$i $a" "-DMP_8BIT $CFLAGS"
- _runvalgrind "$i $a" "-DMP_16BIT $CFLAGS"
- _runvalgrind "$i $a" "-DMP_32BIT $CFLAGS"
- else
- _runtest "$i $a" "$CFLAGS"
- [ "$WITH_LOW_MP" != "1" ] && continue
- _runtest "$i $a" "-DMP_8BIT $CFLAGS"
- _runtest "$i $a" "-DMP_16BIT $CFLAGS"
- _runtest "$i $a" "-DMP_32BIT $CFLAGS"
- fi
- done
-done
-
-_exit
diff --git a/libtommath/tommath.def b/libtommath/tommath.def
index 229fae4..879767f 100644
--- a/libtommath/tommath.def
+++ b/libtommath/tommath.def
@@ -143,3 +143,14 @@ EXPORTS
mp_unpack
mp_xor
mp_zero
+ s_mp_mul_digs
+ s_mp_sub
+ s_mp_add
+ s_mp_toom_mul
+ s_mp_mul_digs_fast
+ s_mp_karatsuba_mul
+ s_mp_sqr_fast
+ s_mp_reverse
+ s_mp_karatsuba_sqr
+ s_mp_toom_sqr
+ s_mp_sqr
diff --git a/libtommath/tommath.h b/libtommath/tommath.h
index fe26962..a235210 100644
--- a/libtommath/tommath.h
+++ b/libtommath/tommath.h
@@ -4,9 +4,7 @@
#ifndef BN_H_
#define BN_H_
-#ifndef MP_NO_STDINT
-# include <stdint.h>
-#endif
+#include <stdint.h>
#include <stddef.h>
#include <limits.h>
@@ -32,7 +30,7 @@ extern "C" {
#endif
/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
-#if (defined(_WIN32) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT)
+#if (defined(_MSC_VER) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_32BIT) && !defined(MP_64BIT)
# define MP_32BIT
#endif
@@ -44,7 +42,7 @@ extern "C" {
defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \
defined(__LP64__) || defined(_LP64) || defined(__64BIT__)
# if !(defined(MP_64BIT) || defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
-# if defined(__GNUC__) && !defined(__hppa)
+# if defined(__GNUC__) && defined(__SIZEOF_INT128__) && !defined(__hppa)
/* we support 128bit integers only via: __attribute__((mode(TI))) */
# define MP_64BIT
# else
@@ -68,23 +66,23 @@ extern "C" {
*/
#ifdef MP_8BIT
-typedef unsigned char mp_digit;
-typedef unsigned short private_mp_word;
+typedef uint8_t mp_digit;
+typedef uint16_t private_mp_word;
# define MP_DIGIT_BIT 7
#elif defined(MP_16BIT)
-typedef unsigned short mp_digit;
-typedef unsigned int private_mp_word;
+typedef uint16_t mp_digit;
+typedef uint32_t private_mp_word;
# define MP_DIGIT_BIT 15
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
-typedef Tcl_WideUInt mp_digit;
+typedef uint64_t mp_digit;
#if defined(__GNUC__)
typedef unsigned long private_mp_word __attribute__((mode(TI)));
#endif
# define MP_DIGIT_BIT 60
#else
-typedef unsigned int mp_digit;
-typedef Tcl_WideUInt private_mp_word;
+typedef uint32_t mp_digit;
+typedef uint64_t private_mp_word;
# ifdef MP_31BIT
/*
* This is an extension that uses 31-bit digits.
@@ -261,11 +259,15 @@ TOOM_SQR_CUTOFF;
#define SIGN(m) (MP_DEPRECATED_PRAGMA("SIGN macro is deprecated, use z->sign instead") (m)->sign)
/* the infamous mp_int structure */
-typedef struct {
+#ifndef MP_INT_DECLARED
+#define MP_INT_DECLARED
+typedef struct mp_int mp_int;
+#endif
+struct mp_int {
int used, alloc;
mp_sign sign;
mp_digit *dp;
-} mp_int;
+};
/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
@@ -313,7 +315,6 @@ double mp_get_double(const mp_int *a) MP_WUR;
mp_err mp_set_double(mp_int *a, double b) MP_WUR;
/* get integer, set integer and init with integer (int32_t) */
-#ifndef MP_NO_STDINT
int32_t mp_get_i32(const mp_int *a) MP_WUR;
void mp_set_i32(mp_int *a, int32_t b);
mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR;
@@ -336,9 +337,8 @@ mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
/* get magnitude */
uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
-#endif
unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
-Tcl_WideUInt mp_get_mag_ull(const mp_int *a) MP_WUR;
+#define mp_get_mag_ull(a) ((unsigned long long)mp_get_mag_u64(a))
/* get integer, set integer (long) */
long mp_get_l(const mp_int *a) MP_WUR;
@@ -350,15 +350,15 @@ mp_err mp_init_l(mp_int *a, long b) MP_WUR;
void mp_set_ul(mp_int *a, unsigned long b);
mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
-/* get integer, set integer (Tcl_WideInt) */
-Tcl_WideInt mp_get_ll(const mp_int *a) MP_WUR;
-void mp_set_ll(mp_int *a, Tcl_WideInt b);
-mp_err mp_init_ll(mp_int *a, Tcl_WideInt b) MP_WUR;
+/* get integer, set integer (long long) */
+#define mp_get_ll(a) ((long long)mp_get_i64(a))
+#define mp_set_ll(a,b) mp_set_i64(a,b)
+#define mp_init_ll(a,b) mp_init_i64(a,b)
-/* get integer, set integer (Tcl_WideUInt) */
-#define mp_get_ull(a) ((Tcl_WideUInt)mp_get_ll(a))
-void mp_set_ull(mp_int *a, Tcl_WideUInt b);
-mp_err mp_init_ull(mp_int *a, Tcl_WideUInt b) MP_WUR;
+/* get integer, set integer (unsigned long long) */
+#define mp_get_ull(a) ((unsigned long long)mp_get_i64(a))
+#define mp_set_ull(a,b) mp_set_u64(a,b)
+#define mp_init_ull(a,b) mp_init_u64(a,b)
/* set to single unsigned digit, up to MP_DIGIT_MAX */
void mp_set(mp_int *a, mp_digit b);
@@ -367,10 +367,10 @@ mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
/* get integer, set integer and init with integer (deprecated) */
MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) Tcl_WideUInt mp_get_long_long(const mp_int *a) MP_WUR;
+MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) unsigned long long mp_get_long_long(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, Tcl_WideUInt b);
+MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned long long b);
MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
/* copy, b = a */
@@ -567,7 +567,7 @@ mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
*
* returns error if a < 0 and b is even
*/
-mp_err mp_root_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
+mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
@@ -730,10 +730,10 @@ MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int siz
mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
/* Integer logarithm to integer base */
-mp_err mp_log_u32(const mp_int *a, unsigned int base, unsigned int *c) MP_WUR;
+mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c) MP_WUR;
/* c = a**b */
-mp_err mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) MP_WUR;
+mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
diff --git a/libtommath/tommath_private.h b/libtommath/tommath_private.h
index 41d1ea2..8aab7c3 100644
--- a/libtommath/tommath_private.h
+++ b/libtommath/tommath_private.h
@@ -4,7 +4,8 @@
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_
-#include <tommath.h>
+#include <stdint.h>
+#include "tclTomMath.h"
#include "tommath_class.h"
/*
@@ -150,8 +151,10 @@ extern void MP_FREE(void *mem, size_t size);
#define MP_HAS(x) (sizeof(MP_STRINGIZE(BN_##x##_C)) == 1u)
/* TODO: Remove private_mp_word as soon as deprecated mp_word is removed from tommath. */
+#if !defined(MP_64BIT) || defined(__GNUC__)
#undef mp_word
typedef private_mp_word mp_word;
+#endif
#define MP_MIN(x, y) (((x) < (y)) ? (x) : (y))
#define MP_MAX(x, y) (((x) > (y)) ? (x) : (y))
@@ -178,13 +181,16 @@ typedef private_mp_word mp_word;
#endif
/* Minimum number of available digits in mp_int, MP_PREC >= MP_MIN_PREC */
-#define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(Tcl_WideInt) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT)
+#define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(uintmax_t) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT)
MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC)
/* random number source */
extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size);
+#ifdef __cplusplus
+extern "C" {
+#endif
/* lowlevel functions, do not call! */
MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b);
MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
@@ -212,17 +218,14 @@ MP_PRIVATE mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result);
/* TODO: jenkins prng is not thread safe as of now */
MP_PRIVATE mp_err s_mp_rand_jenkins(void *p, size_t n) MP_WUR;
-#ifndef MP_NO_STDINT
MP_PRIVATE void s_mp_rand_jenkins_init(uint64_t seed);
-#endif
extern MP_PRIVATE const char *const mp_s_rmap;
-extern MP_PRIVATE const unsigned char mp_s_rmap_reverse[];
+extern MP_PRIVATE const uint8_t mp_s_rmap_reverse[];
extern MP_PRIVATE const size_t mp_s_rmap_reverse_sz;
extern MP_PRIVATE const mp_digit *s_mp_prime_tab;
/* deprecated functions */
-#if 0
MP_DEPRECATED(s_mp_invmod_fast) mp_err fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_montgomery_reduce_fast) mp_err fast_mp_montgomery_reduce(mp_int *x, const mp_int *n,
mp_digit rho);
@@ -242,11 +245,19 @@ MP_DEPRECATED(s_mp_karatsuba_sqr) mp_err mp_karatsuba_sqr(const mp_int *a, mp_in
MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len);
+
+#ifdef __cplusplus
+}
+#endif
+
+#ifndef TCL_WITH_EXTERNAL_TOMMATH
+#undef mp_sqr
+#define mp_sqr TclBN_mp_sqr
#endif
#define MP_GET_ENDIANNESS(x) \
do{\
- short n = 0x1; \
+ int16_t n = 0x1; \
char *p = (char *)&n; \
x = (p[0] == '\x01') ? MP_LITTLE_ENDIAN : MP_BIG_ENDIAN; \
} while (0)
@@ -304,7 +315,4 @@ MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len);
return (a->sign == MP_NEG) ? (type)-res : (type)res; \
}
-#undef mp_isodd
-#define mp_isodd TclBN_mp_isodd
-
#endif
diff --git a/libtommath/win32/libtommath.dll b/libtommath/win32/libtommath.dll
new file mode 100755
index 0000000..62779fa
--- /dev/null
+++ b/libtommath/win32/libtommath.dll
Binary files differ
diff --git a/libtommath/win32/tommath.lib b/libtommath/win32/tommath.lib
new file mode 100644
index 0000000..dd3e82e
--- /dev/null
+++ b/libtommath/win32/tommath.lib
Binary files differ
diff --git a/libtommath/win64-arm/libtommath.dll b/libtommath/win64-arm/libtommath.dll
new file mode 100755
index 0000000..e795d6d
--- /dev/null
+++ b/libtommath/win64-arm/libtommath.dll
Binary files differ
diff --git a/libtommath/win64-arm/libtommath.dll.a b/libtommath/win64-arm/libtommath.dll.a
new file mode 100644
index 0000000..0108f90
--- /dev/null
+++ b/libtommath/win64-arm/libtommath.dll.a
Binary files differ
diff --git a/libtommath/win64-arm/tommath.lib b/libtommath/win64-arm/tommath.lib
new file mode 100644
index 0000000..f14fbe7
--- /dev/null
+++ b/libtommath/win64-arm/tommath.lib
Binary files differ
diff --git a/libtommath/win64/libtommath.dll b/libtommath/win64/libtommath.dll
new file mode 100755
index 0000000..3667593
--- /dev/null
+++ b/libtommath/win64/libtommath.dll
Binary files differ
diff --git a/libtommath/win64/libtommath.dll.a b/libtommath/win64/libtommath.dll.a
new file mode 100644
index 0000000..81be3c8
--- /dev/null
+++ b/libtommath/win64/libtommath.dll.a
Binary files differ
diff --git a/libtommath/win64/tommath.lib b/libtommath/win64/tommath.lib
new file mode 100644
index 0000000..434fa7c
--- /dev/null
+++ b/libtommath/win64/tommath.lib
Binary files differ
diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile
index b2e3614..77886c7 100644
--- a/macosx/GNUmakefile
+++ b/macosx/GNUmakefile
@@ -104,7 +104,7 @@ PROJECT := tcl
PRODUCT_NAME := Tcl
UNIX_DIR := ${CURDIR}/../unix
-VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in)
+VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.ac)
TCLSH := tclsh${VERSION}
BUILD_TARGET := all tcltest
@@ -144,7 +144,7 @@ ${objdir}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \
mkdir -p "${OBJ_DIR}" && cd "${OBJ_DIR}" && \
if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure -C \
--prefix="${PREFIX}" --bindir="${BINDIR}" --libdir="${LIBDIR}" \
- --mandir="${MANDIR}" --enable-threads --enable-framework --enable-dtrace \
+ --mandir="${MANDIR}" --enable-framework --enable-dtrace --disable-zipfs \
${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
build-${PROJECT}: ${objdir}/Makefile
diff --git a/macosx/README b/macosx/README
index d170bce..73be6c4 100644
--- a/macosx/README
+++ b/macosx/README
@@ -80,7 +80,6 @@ select based notifier).
- It is also possible to build with the Xcode IDE via the projects in
tcl/macosx, take care to use the project matching your DevTools and OS version:
- Tcl.xcode: for Xcode 3.1 on 10.5
Tcl.xcodeproj: for Xcode 3.2 on 10.6
These have the following targets:
Tcl: calls through to tcl/macosx/GNUMakefile.
@@ -93,14 +92,10 @@ The following build configurations are available:
Debug llvm-gcc: use llvm-gcc compiler.
Debug gcc40: use gcc 4.0 compiler.
DebugNoFixAndContinue: disable Fix & Continue.
- DebugUnthreaded: disable threading.
DebugNoCF: disable corefoundation.
- DebugNoCFUnthreaded: disable corefoundation an threading.
DebugMemCompile: enable memory and bytecode debugging.
DebugLeaks: define PURIFY.
DebugGCov: enable generation of gcov data files.
- Debug64bit: configure with --enable-64bit (requires
- building on a 64bit capable processor).
Release: release build for the active architecture.
ReleaseUniversal: 32/64-bit universal build.
ReleaseUniversal clang: use clang compiler.
@@ -109,22 +104,19 @@ The following build configurations are available:
ReleaseUniversal10.5SDK: build against the 10.5 SDK (with 10.5
deployment target).
Note that the non-SDK configurations have their deployment target set to
- 10.5 (Tcl.xcode) resp. 10.6 (Tcl.xcodeproj).
+ 10.6 (Tcl.xcodeproj).
The Xcode projects refer to the toplevel tcl source directory via the
TCL_SRCROOT user build setting, by default this is set to the project-relative
path '../../tcl', if your tcl source directory is named differently, e.g.
-'../../tcl8.6', you need to manually change the TCL_SRCROOT setting by editing
+'../../tcl8.7', you need to manually change the TCL_SRCROOT setting by editing
your ${USER}.pbxuser file (located inside the Tcl.xcodeproj bundle directory)
with a text editor.
- To build universal binaries outside of the Xcode IDE, set CFLAGS as follows:
- export CFLAGS="-arch i386 -arch x86_64 -arch ppc"
-This requires Mac OS X 10.4 and Xcode 2.4 (or Xcode 2.2 if -arch x86_64 is
-omitted, but _not_ Xcode 2.1) and will work on any architecture (on PowerPC
-Tiger you need to add "-isysroot /Developer/SDKs/MacOSX10.4u.sdk").
+ export CFLAGS="-arch x86_64 -arch arm64"
+This requires Mac OS X 10.6 and Xcode 10.2 and will work on any architecture.
Note that configure requires CFLAGS to contain a least one architecture that can
-be run on the build machine (i.e. ppc on G3/G4, ppc or ppc64 on G5, ppc or i386
-on Core and ppc, i386 or x86_64 on Core2/Xeon).
+be run on the build machine (i.e. x86_64 on Core2/Xeon).
Universal builds of Tcl TEA extensions are also possible with CFLAGS set as
above, they will be [load]able by universal as well as thin binaries of Tcl.
@@ -134,12 +126,12 @@ Detailed Instructions for building with macosx/GNUmakefile
- Unpack the Tcl source release archive.
- The following instructions assume the Tcl source tree is named "tcl${ver}",
-(where ${ver} is a shell variable containing the Tcl version number e.g. '8.6').
+(where ${ver} is a shell variable containing the Tcl version number e.g. '8.7').
Setup this shell variable as follows:
- ver="8.6"
+ ver="8.7"
- Setup environment variables as desired, e.g. for a universal build on 10.5:
- CFLAGS="-arch i386 -arch x86_64 -arch ppc -mmacosx-version-min=10.5"
+ CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.5"
export CFLAGS
- Change to the directory containing the Tcl source tree and build:
diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig
index 9c47547..5193b70 100644
--- a/macosx/Tcl-Common.xcconfig
+++ b/macosx/Tcl-Common.xcconfig
@@ -19,7 +19,7 @@ GCC_NO_COMMON_BLOCKS = YES
GCC_DYNAMIC_NO_PIC = YES
GCC_VERSION = 4.2
GCC = gcc-$(GCC_VERSION)
-WARNING_CFLAGS = -Wall -Wextra -Wno-unused-parameter -Wno-missing-field-initializers -Wno-unused-value -Winit-self -Wpointer-arith -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS)
+WARNING_CFLAGS = -Wall -Wextra -Wshadow -Wwrite-strings -Wpointer-arith -Wc++-compat -Winit-self -Wcast-align -Wdisabled-optimization -Winline $(WARNING_CFLAGS)
BINDIR = $(PREFIX)/bin
CFLAGS = $(CFLAGS)
CPPFLAGS = -mmacosx-version-min=$(MACOSX_DEPLOYMENT_TARGET) $(CPPFLAGS)
@@ -30,8 +30,8 @@ MANDIR = $(PREFIX)/man
PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc)
PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64)
PREFIX = /usr/local
-TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace
+TCL_CONFIGURE_ARGS = --enable-dtrace
TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION)
TCL_PACKAGE_PATH = "$(LIBDIR)"
TCL_DEFS = HAVE_TCL_CONFIG_H
-VERSION = 8.6
+VERSION = 8.7
diff --git a/macosx/Tcl.xcode/default.pbxuser b/macosx/Tcl.xcode/default.pbxuser
deleted file mode 100644
index 22ffa9e..0000000
--- a/macosx/Tcl.xcode/default.pbxuser
+++ /dev/null
@@ -1,200 +0,0 @@
-// !$*UTF8*$!
-{
- 08FB7793FE84155DC02AAC07 /* Project object */ = {
- activeBuildConfigurationName = Debug;
- activeExecutable = F9E61D1C090A4282002B3151 /* tclsh */;
- activeTarget = F9E61D16090A3E94002B3151 /* Tcl */;
- codeSenseManager = F944EB9D08F798180049FDD4 /* Code sense */;
- executables = (
- F9E61D1C090A4282002B3151 /* tclsh */,
- F944EB8F08F798100049FDD4 /* tcltest */,
- );
- perUserDictionary = {
- com.apple.ide.smrt.PBXUserSmartGroupsKey.Rev10 = <040b73747265616d747970656481e8038401408484840e4e534d757461626c654172726179008484074e534172726179008484084e534f626a65637400858401690192848484134e534d757461626c6544696374696f6e6172790084840c4e5344696374696f6e6172790095960792848484084e53537472696e67019584012b046e616d658692849a9a14496d706c656d656e746174696f6e2046696c65738692849a9a146162736f6c75746550617468546f42756e646c658692849a9a008692849a9a195042585472616e7369656e744c6f636174696f6e4174546f708692849a9a06626f74746f6d8692849a9a03636c7a8692849a9a1550425846696c656e616d65536d61727447726f75708692849a9a0b6465736372697074696f6e8692849a9a103c6e6f206465736372697074696f6e3e8692849a9a0b707265666572656e63657386928497960892849a9a07666e6d617463688692849a9a008692849a9a05696d6167658692849a9a0b536d617274466f6c6465728692849a9a04726f6f748692849a9a093c50524f4a4543543e8692849a9a0572656765788692849a9a065c2e286329248692849a9a097265637572736976658692848484084e534e756d626572008484074e5356616c7565009584012a849696018692849a9a0669734c656166869284b09db296008692849a9a0763616e536176658692af92849a9a1250425850726f6a65637453636f70654b65798692849a9a03594553868692849a9a08676c6f62616c49448692849a9a18314343304541343030343335304546393030343434313042868686>;
- };
- sourceControlManager = F944EB9C08F798180049FDD4 /* Source Control */;
- userBuildSettings = {
- SYMROOT = "${SRCROOT}/../../build/tcl";
- TCL_SRCROOT = "${SRCROOT}/../../tcl";
- };
- };
- 8DD76FA90486AB0100D96B5E /* tcltest */ = {
- activeExec = 0;
- executables = (
- F944EB8F08F798100049FDD4 /* tcltest */,
- );
- };
- F944EB8F08F798100049FDD4 /* tcltest */ = {
- isa = PBXExecutable;
- activeArgIndices = (
- NO,
- NO,
- NO,
- );
- argumentStrings = (
- "${TCL_SRCROOT}/tests/all.tcl",
- "-singleproc 1",
- "-verbose \"bet\"",
- );
- autoAttachOnCrash = 1;
- breakpointsEnabled = 1;
- configStateDict = {
- "PBXLSLaunchAction-0" = {
- PBXLSLaunchAction = 0;
- PBXLSLaunchStartAction = 1;
- PBXLSLaunchStdioStyle = 2;
- PBXLSLaunchStyle = 0;
- class = PBXLSRunLaunchConfig;
- displayName = "Executable Runner";
- identifier = com.apple.Xcode.launch.runConfig;
- remoteHostInfo = "";
- startActionInfo = "";
- };
- "PBXLSLaunchAction-1" = {
- PBXLSLaunchAction = 1;
- PBXLSLaunchStartAction = 1;
- PBXLSLaunchStdioStyle = 2;
- PBXLSLaunchStyle = 0;
- class = PBXGDB_LaunchConfig;
- displayName = GDB;
- identifier = com.apple.Xcode.launch.GDBMI_Config;
- remoteHostInfo = "";
- startActionInfo = "";
- };
- };
- customDataFormattersEnabled = 1;
- debuggerPlugin = GDBDebugging;
- disassemblyDisplayState = 0;
- dylibVariantSuffix = "";
- enableDebugStr = 0;
- environmentEntries = (
- {
- active = YES;
- name = TCL_LIBRARY;
- value = "${TCL_SRCROOT}/library";
- },
- {
- active = YES;
- name = TCLLIBPATH;
- value = /Library/Tcl;
- },
- {
- active = NO;
- name = DYLD_PRINT_LIBRARIES;
- },
- {
- active = NO;
- name = MallocBadFreeAbort;
- value = 1;
- },
- {
- active = NO;
- name = MallocLogFile;
- value = /tmp/malloc.log;
- },
- {
- active = NO;
- name = MallocStackLogging;
- value = 1;
- },
- {
- active = NO;
- name = MallocStackLoggingNoCompact;
- value = 1;
- },
- {
- active = NO;
- name = MallocPreScribble;
- value = 1;
- },
- {
- active = NO;
- name = MallocScribble;
- value = 1;
- },
- );
- executableSystemSymbolLevel = 0;
- executableUserSymbolLevel = 0;
- libgmallocEnabled = 0;
- name = tcltest;
- sourceDirectories = (
- );
- };
- F944EB9C08F798180049FDD4 /* Source Control */ = {
- isa = PBXSourceControlManager;
- fallbackIsa = XCSourceControlManager;
- isSCMEnabled = 0;
- scmConfiguration = {
- CVSToolPath = /usr/bin/cvs;
- CVSUseSSH = NO;
- SubversionToolPath = /usr/bin/svn;
- repositoryNamesForRoots = {
- .. = "";
- };
- };
- scmType = scm.cvs;
- };
- F944EB9D08F798180049FDD4 /* Code sense */ = {
- isa = PBXCodeSenseManager;
- indexTemplatePath = "";
- };
- F97258A50A86873C00096C78 /* tests */ = {
- activeExec = 0;
- };
- F9E61D16090A3E94002B3151 /* Tcl */ = {
- activeExec = 0;
- executables = (
- F9E61D1C090A4282002B3151 /* tclsh */,
- );
- };
- F9E61D1C090A4282002B3151 /* tclsh */ = {
- isa = PBXExecutable;
- activeArgIndices = (
- );
- argumentStrings = (
- );
- autoAttachOnCrash = 1;
- breakpointsEnabled = 1;
- configStateDict = {
- "PBXLSLaunchAction-0" = {
- PBXLSLaunchAction = 0;
- PBXLSLaunchStartAction = 1;
- PBXLSLaunchStdioStyle = 2;
- PBXLSLaunchStyle = 0;
- class = PBXLSRunLaunchConfig;
- displayName = "Executable Runner";
- identifier = com.apple.Xcode.launch.runConfig;
- remoteHostInfo = "";
- startActionInfo = "";
- };
- "PBXLSLaunchAction-1" = {
- PBXLSLaunchAction = 1;
- PBXLSLaunchStartAction = 1;
- PBXLSLaunchStdioStyle = 2;
- PBXLSLaunchStyle = 0;
- class = PBXGDB_LaunchConfig;
- displayName = GDB;
- identifier = com.apple.Xcode.launch.GDBMI_Config;
- remoteHostInfo = "";
- startActionInfo = "";
- };
- };
- customDataFormattersEnabled = 1;
- debuggerPlugin = GDBDebugging;
- disassemblyDisplayState = 0;
- dylibVariantSuffix = _debug;
- enableDebugStr = 0;
- environmentEntries = (
- {
- active = NO;
- name = DYLD_PRINT_LIBRARIES;
- },
- );
- executableSystemSymbolLevel = 0;
- executableUserSymbolLevel = 0;
- libgmallocEnabled = 0;
- name = tclsh;
- sourceDirectories = (
- );
- };
-}
diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj
deleted file mode 100644
index aceb929..0000000
--- a/macosx/Tcl.xcode/project.pbxproj
+++ /dev/null
@@ -1,2922 +0,0 @@
-// !$*UTF8*$!
-{
- archiveVersion = 1;
- classes = {
- };
- objectVersion = 45;
- objects = {
-
-/* Begin PBXBuildFile section */
- F90509300913A72400327603 /* tclAppInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445508F272B9004A47F5 /* tclAppInit.c */; settings = {COMPILER_FLAGS = "-DTCL_TEST -DTCL_BUILDTIME_LIBRARY=\\\"$(TCL_SRCROOT)/library\\\""; }; };
- F93599B30DF1F75400E04F67 /* tclOO.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599B20DF1F75400E04F67 /* tclOO.c */; };
- F93599B70DF1F76100E04F67 /* tclOOBasic.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599B60DF1F76100E04F67 /* tclOOBasic.c */; };
- F93599B90DF1F76600E04F67 /* tclOOCall.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599B80DF1F76600E04F67 /* tclOOCall.c */; };
- F93599BC0DF1F77000E04F67 /* tclOODefineCmds.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599BB0DF1F77000E04F67 /* tclOODefineCmds.c */; };
- F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599BD0DF1F77400E04F67 /* tclOOInfo.c */; };
- F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C10DF1F78300E04F67 /* tclOOMethod.c */; };
- F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C30DF1F78800E04F67 /* tclOOStubInit.c */; };
- F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */ = {isa = PBXBuildFile; fileRef = F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */; };
- F95D77EA0DFD820D00A8BF6F /* tclIORTrans.c in Sources */ = {isa = PBXBuildFile; fileRef = F95D77E90DFD820D00A8BF6F /* tclIORTrans.c */; };
- F96437CA0EF0D4B2003F468E /* tclZlib.c in Sources */ = {isa = PBXBuildFile; fileRef = F96437C90EF0D4B2003F468E /* tclZlib.c */; };
- F96437E70EF0D652003F468E /* libz.dylib in Frameworks */ = {isa = PBXBuildFile; fileRef = F96437E60EF0D652003F468E /* libz.dylib */; };
- F966C07508F2820D005CB29B /* CoreFoundation.framework in Frameworks */ = {isa = PBXBuildFile; fileRef = F966C07408F2820D005CB29B /* CoreFoundation.framework */; };
- F96D456F08F272BB004A47F5 /* regcomp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED008F272A7004A47F5 /* regcomp.c */; };
- F96D457208F272BB004A47F5 /* regerror.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED308F272A7004A47F5 /* regerror.c */; };
- F96D457508F272BB004A47F5 /* regexec.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED608F272A7004A47F5 /* regexec.c */; };
- F96D457608F272BB004A47F5 /* regfree.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3ED708F272A7004A47F5 /* regfree.c */; };
- F96D457B08F272BB004A47F5 /* tclAlloc.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EDC08F272A7004A47F5 /* tclAlloc.c */; settings = {COMPILER_FLAGS = "-DUSE_TCLALLOC=0"; }; };
- F96D457C08F272BB004A47F5 /* tclAsync.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EDD08F272A7004A47F5 /* tclAsync.c */; };
- F96D457D08F272BB004A47F5 /* tclBasic.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EDE08F272A7004A47F5 /* tclBasic.c */; };
- F96D457E08F272BC004A47F5 /* tclBinary.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EDF08F272A7004A47F5 /* tclBinary.c */; };
- F96D457F08F272BC004A47F5 /* tclCkalloc.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE008F272A7004A47F5 /* tclCkalloc.c */; };
- F96D458008F272BC004A47F5 /* tclClock.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE108F272A7004A47F5 /* tclClock.c */; };
- F96D458108F272BC004A47F5 /* tclCmdAH.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE208F272A7004A47F5 /* tclCmdAH.c */; };
- F96D458208F272BC004A47F5 /* tclCmdIL.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE308F272A7004A47F5 /* tclCmdIL.c */; };
- F96D458308F272BC004A47F5 /* tclCmdMZ.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE408F272A7004A47F5 /* tclCmdMZ.c */; };
- F96D458408F272BC004A47F5 /* tclCompCmds.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE508F272A7004A47F5 /* tclCompCmds.c */; };
- F96D458508F272BC004A47F5 /* tclCompExpr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE608F272A7004A47F5 /* tclCompExpr.c */; };
- F96D458608F272BC004A47F5 /* tclCompile.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE708F272A7004A47F5 /* tclCompile.c */; };
- F96D458808F272BC004A47F5 /* tclConfig.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EE908F272A7004A47F5 /* tclConfig.c */; };
- F96D458908F272BC004A47F5 /* tclDate.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EEA08F272A7004A47F5 /* tclDate.c */; };
- F96D458B08F272BC004A47F5 /* tclDictObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EEC08F272A7004A47F5 /* tclDictObj.c */; };
- F96D458C08F272BC004A47F5 /* tclEncoding.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EED08F272A7004A47F5 /* tclEncoding.c */; };
- F96D458D08F272BC004A47F5 /* tclEnv.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EEE08F272A7004A47F5 /* tclEnv.c */; };
- F96D458E08F272BC004A47F5 /* tclEvent.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EEF08F272A7004A47F5 /* tclEvent.c */; };
- F96D458F08F272BC004A47F5 /* tclExecute.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF008F272A7004A47F5 /* tclExecute.c */; };
- F96D459008F272BC004A47F5 /* tclFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF108F272A7004A47F5 /* tclFCmd.c */; };
- F96D459108F272BC004A47F5 /* tclFileName.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF208F272A7004A47F5 /* tclFileName.c */; };
- F96D459308F272BC004A47F5 /* tclGet.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF408F272A7004A47F5 /* tclGet.c */; };
- F96D459508F272BC004A47F5 /* tclHash.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF608F272A7004A47F5 /* tclHash.c */; };
- F96D459608F272BC004A47F5 /* tclHistory.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF708F272A7004A47F5 /* tclHistory.c */; };
- F96D459708F272BC004A47F5 /* tclIndexObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EF808F272A7004A47F5 /* tclIndexObj.c */; };
- F96D459B08F272BC004A47F5 /* tclInterp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EFC08F272A7004A47F5 /* tclInterp.c */; };
- F96D459D08F272BC004A47F5 /* tclIO.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3EFE08F272A7004A47F5 /* tclIO.c */; };
- F96D459F08F272BC004A47F5 /* tclIOCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0008F272A7004A47F5 /* tclIOCmd.c */; };
- F96D45A008F272BC004A47F5 /* tclIOGT.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0108F272A7004A47F5 /* tclIOGT.c */; };
- F96D45A108F272BC004A47F5 /* tclIORChan.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0208F272A7004A47F5 /* tclIORChan.c */; };
- F96D45A208F272BC004A47F5 /* tclIOSock.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0308F272A7004A47F5 /* tclIOSock.c */; };
- F96D45A308F272BC004A47F5 /* tclIOUtil.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0408F272A7004A47F5 /* tclIOUtil.c */; };
- F96D45A408F272BC004A47F5 /* tclLink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0508F272A7004A47F5 /* tclLink.c */; };
- F96D45A508F272BC004A47F5 /* tclListObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0608F272A7004A47F5 /* tclListObj.c */; };
- F96D45A608F272BC004A47F5 /* tclLiteral.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0708F272A7004A47F5 /* tclLiteral.c */; };
- F96D45A708F272BC004A47F5 /* tclLoad.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0808F272A7004A47F5 /* tclLoad.c */; };
- F96D45A908F272BC004A47F5 /* tclMain.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0A08F272A7004A47F5 /* tclMain.c */; };
- F96D45AA08F272BC004A47F5 /* tclNamesp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0B08F272A7004A47F5 /* tclNamesp.c */; };
- F96D45AB08F272BC004A47F5 /* tclNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0C08F272A7004A47F5 /* tclNotify.c */; };
- F96D45AC08F272BC004A47F5 /* tclObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0D08F272A7004A47F5 /* tclObj.c */; };
- F96D45AD08F272BC004A47F5 /* tclPanic.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0E08F272A7004A47F5 /* tclPanic.c */; };
- F96D45AE08F272BC004A47F5 /* tclParse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F0F08F272A7004A47F5 /* tclParse.c */; };
- F96D45B008F272BC004A47F5 /* tclPathObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1108F272A7004A47F5 /* tclPathObj.c */; };
- F96D45B108F272BC004A47F5 /* tclPipe.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1208F272A7004A47F5 /* tclPipe.c */; };
- F96D45B208F272BC004A47F5 /* tclPkg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1308F272A7004A47F5 /* tclPkg.c */; };
- F96D45B308F272BC004A47F5 /* tclPkgConfig.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1408F272A7004A47F5 /* tclPkgConfig.c */; settings = {COMPILER_FLAGS = "-DCFG_INSTALL_LIBDIR=\\\"$(LIBDIR)\\\" -DCFG_INSTALL_BINDIR=\\\"$(BINDIR)\\\" -DCFG_INSTALL_SCRDIR=\\\"$(TCL_LIBRARY)\\\" -DCFG_INSTALL_INCDIR=\\\"$(INCLUDEDIR)\\\" -DCFG_INSTALL_DOCDIR=\\\"$(MANDIR)\\\" -DCFG_RUNTIME_LIBDIR=\\\"$(LIBDIR)\\\" -DCFG_RUNTIME_BINDIR=\\\"$(BINDIR)\\\" -DCFG_RUNTIME_SCRDIR=\\\"$(TCL_LIBRARY)\\\" -DCFG_RUNTIME_INCDIR=\\\"$(INCLUDEDIR)\\\" -DCFG_RUNTIME_DOCDIR=\\\"$(MANDIR)\\\""; }; };
- F96D45B608F272BC004A47F5 /* tclPosixStr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1708F272A7004A47F5 /* tclPosixStr.c */; };
- F96D45B708F272BC004A47F5 /* tclPreserve.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1808F272A7004A47F5 /* tclPreserve.c */; };
- F96D45B808F272BC004A47F5 /* tclProc.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1908F272A7004A47F5 /* tclProc.c */; };
- F96D45B908F272BC004A47F5 /* tclRegexp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1A08F272A7004A47F5 /* tclRegexp.c */; };
- F96D45BB08F272BC004A47F5 /* tclResolve.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1C08F272A7004A47F5 /* tclResolve.c */; };
- F96D45BC08F272BC004A47F5 /* tclResult.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1D08F272A7004A47F5 /* tclResult.c */; };
- F96D45BD08F272BC004A47F5 /* tclScan.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1E08F272A7004A47F5 /* tclScan.c */; };
- F96D45BE08F272BC004A47F5 /* tclStringObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F1F08F272A7004A47F5 /* tclStringObj.c */; };
- F96D45C308F272BC004A47F5 /* tclStrToD.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2408F272A7004A47F5 /* tclStrToD.c */; };
- F96D45C408F272BC004A47F5 /* tclStubInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2508F272A7004A47F5 /* tclStubInit.c */; };
- F96D45C508F272BC004A47F5 /* tclStubLib.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2608F272A7004A47F5 /* tclStubLib.c */; };
- F96D45C608F272BC004A47F5 /* tclTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2708F272A7004A47F5 /* tclTest.c */; };
- F96D45C708F272BC004A47F5 /* tclTestObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2808F272A7004A47F5 /* tclTestObj.c */; };
- F96D45C808F272BC004A47F5 /* tclTestProcBodyObj.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2908F272A7004A47F5 /* tclTestProcBodyObj.c */; };
- F96D45C908F272BC004A47F5 /* tclThread.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2A08F272A7004A47F5 /* tclThread.c */; };
- F96D45CA08F272BC004A47F5 /* tclThreadAlloc.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2B08F272A7004A47F5 /* tclThreadAlloc.c */; };
- F96D45CB08F272BC004A47F5 /* tclThreadJoin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2C08F272A7004A47F5 /* tclThreadJoin.c */; };
- F96D45CC08F272BC004A47F5 /* tclThreadStorage.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2D08F272A7004A47F5 /* tclThreadStorage.c */; };
- F96D45CD08F272BC004A47F5 /* tclThreadTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2E08F272A7004A47F5 /* tclThreadTest.c */; };
- F96D45CE08F272BC004A47F5 /* tclTimer.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F2F08F272A7004A47F5 /* tclTimer.c */; };
- F96D45D008F272BC004A47F5 /* tclTomMathInterface.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */; };
- F96D45D108F272BC004A47F5 /* tclTrace.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F3208F272A7004A47F5 /* tclTrace.c */; };
- F96D45D308F272BC004A47F5 /* tclUtf.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F3408F272A7004A47F5 /* tclUtf.c */; };
- F96D45D408F272BC004A47F5 /* tclUtil.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F3508F272A7004A47F5 /* tclUtil.c */; };
- F96D45D508F272BC004A47F5 /* tclVar.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D3F3608F272A7004A47F5 /* tclVar.c */; };
- F96D48E208F272C3004A47F5 /* bn_fast_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426408F272B3004A47F5 /* bn_fast_s_mp_mul_digs.c */; };
- F96D48E408F272C3004A47F5 /* bn_fast_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426608F272B3004A47F5 /* bn_fast_s_mp_sqr.c */; };
- F96D48E708F272C3004A47F5 /* bn_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426908F272B3004A47F5 /* bn_mp_add.c */; };
- F96D48E808F272C3004A47F5 /* bn_mp_add_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426A08F272B3004A47F5 /* bn_mp_add_d.c */; };
- F96D48EB08F272C3004A47F5 /* bn_mp_clamp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426D08F272B3004A47F5 /* bn_mp_clamp.c */; };
- F96D48EC08F272C3004A47F5 /* bn_mp_clear.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426E08F272B3004A47F5 /* bn_mp_clear.c */; };
- F96D48ED08F272C3004A47F5 /* bn_mp_clear_multi.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426F08F272B3004A47F5 /* bn_mp_clear_multi.c */; };
- F96D48EE08F272C3004A47F5 /* bn_mp_cmp.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427008F272B3004A47F5 /* bn_mp_cmp.c */; };
- F96D48F008F272C3004A47F5 /* bn_mp_cmp_mag.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427208F272B3004A47F5 /* bn_mp_cmp_mag.c */; };
- F96D48F208F272C3004A47F5 /* bn_mp_cnt_lsb.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427408F272B3004A47F5 /* bn_mp_cnt_lsb.c */; };
- F96D48F208F272C3004A47F5 /* bn_mp_copy.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427408F272B3004A47F5 /* bn_mp_copy.c */; };
- F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */; };
- F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427608F272B3004A47F5 /* bn_mp_div.c */; };
- F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427708F272B3004A47F5 /* bn_mp_div_2.c */; };
- F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */; };
- F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427908F272B3004A47F5 /* bn_mp_div_3.c */; };
- F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */; };
- F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427E08F272B3004A47F5 /* bn_mp_exch.c */; };
- F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428708F272B3004A47F5 /* bn_mp_grow.c */; };
- F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428808F272B3004A47F5 /* bn_mp_init.c */; };
- F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */; };
- F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */; };
- F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */; };
- F96D490B08F272C3004A47F5 /* bn_mp_init_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */; };
- F96D491008F272C3004A47F5 /* bn_mp_karatsuba_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429208F272B3004A47F5 /* bn_mp_karatsuba_mul.c */; };
- F96D491108F272C3004A47F5 /* bn_mp_karatsuba_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429308F272B3004A47F5 /* bn_mp_karatsuba_sqr.c */; };
- F96D491308F272C3004A47F5 /* bn_mp_lshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429508F272B3004A47F5 /* bn_mp_lshd.c */; };
- F96D491408F272C3004A47F5 /* bn_mp_mod.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429608F272B3004A47F5 /* bn_mp_mod.c */; };
- F96D491508F272C3004A47F5 /* bn_mp_mod_2d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429708F272B3004A47F5 /* bn_mp_mod_2d.c */; };
- F96D491A08F272C3004A47F5 /* bn_mp_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429C08F272B3004A47F5 /* bn_mp_mul.c */; };
- F96D491B08F272C3004A47F5 /* bn_mp_mul_2.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429D08F272B3004A47F5 /* bn_mp_mul_2.c */; };
- F96D491C08F272C3004A47F5 /* bn_mp_mul_2d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429E08F272B3004A47F5 /* bn_mp_mul_2d.c */; };
- F96D491D08F272C3004A47F5 /* bn_mp_mul_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D429F08F272B3004A47F5 /* bn_mp_mul_d.c */; };
- F96D492908F272C3004A47F5 /* bn_mp_radix_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42AB08F272B3004A47F5 /* bn_mp_radix_size.c */; };
- F96D492A08F272C3004A47F5 /* bn_mp_radix_smap.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42AC08F272B3004A47F5 /* bn_mp_radix_smap.c */; };
- F96D492C08F272C3004A47F5 /* bn_mp_read_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42AE08F272B3004A47F5 /* bn_mp_read_radix.c */; };
- F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */; };
- F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BA08F272B3004A47F5 /* bn_mp_set.c */; };
- F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; };
- F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; };
- F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; };
- F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; };
- F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
- F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; };
- F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
- F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
- F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
- F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
- F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
- F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
- F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */; };
- F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */; };
- F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */; };
- F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445B08F272B9004A47F5 /* tclLoadDyld.c */; settings = {COMPILER_FLAGS = "-Wno-deprecated-declarations"; }; };
- F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D445F08F272B9004A47F5 /* tclUnixChan.c */; };
- F96D4ACB08F272C9004A47F5 /* tclUnixEvent.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446008F272B9004A47F5 /* tclUnixEvent.c */; };
- F96D4ACC08F272C9004A47F5 /* tclUnixFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446108F272B9004A47F5 /* tclUnixFCmd.c */; };
- F96D4ACD08F272C9004A47F5 /* tclUnixFile.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446208F272B9004A47F5 /* tclUnixFile.c */; };
- F96D4ACE08F272C9004A47F5 /* tclUnixInit.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446308F272B9004A47F5 /* tclUnixInit.c */; settings = {COMPILER_FLAGS = "-DTCL_LIBRARY=\\\"$(TCL_LIBRARY)\\\" -DTCL_PACKAGE_PATH=\\\"$(TCL_PACKAGE_PATH)\\\""; }; };
- F96D4ACF08F272C9004A47F5 /* tclUnixNotfy.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446408F272B9004A47F5 /* tclUnixNotfy.c */; };
- F96D4AD008F272C9004A47F5 /* tclUnixPipe.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446508F272B9004A47F5 /* tclUnixPipe.c */; };
- F96D4AD208F272CA004A47F5 /* tclUnixSock.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446708F272B9004A47F5 /* tclUnixSock.c */; };
- F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446808F272B9004A47F5 /* tclUnixTest.c */; };
- F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446908F272B9004A47F5 /* tclUnixThrd.c */; };
- F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; };
- F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; };
- F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; };
- F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; };
- F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; };
- F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */; };
- F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */; };
- F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A308F272B3004A47F5 /* bn_mp_or.c */; };
- F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */; };
- F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */; };
- F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */; };
- F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */ = {isa = PBXBuildFile; fileRef = F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */; };
- F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */ = {isa = PBXBuildFile; fileRef = F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */; };
-/* End PBXBuildFile section */
-
-/* Begin PBXContainerItemProxy section */
- F97258D20A868C6F00096C78 /* PBXContainerItemProxy */ = {
- isa = PBXContainerItemProxy;
- containerPortal = 08FB7793FE84155DC02AAC07 /* Project object */;
- proxyType = 1;
- remoteGlobalIDString = 8DD76FA90486AB0100D96B5E;
- remoteInfo = tcltest;
- };
-/* End PBXContainerItemProxy section */
-
-/* Begin PBXFileReference section */
- 8DD76FB20486AB0100D96B5E /* tcltest */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tcltest; sourceTree = BUILT_PRODUCTS_DIR; };
- F915432A0EF201CF0032D1E8 /* zlib.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = zlib.test; sourceTree = "<group>"; };
- F915432D0EF201EE0032D1E8 /* zlib.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = zlib.n; sourceTree = "<group>"; };
- F9183E640EFC80CD0030B814 /* throw.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = throw.n; sourceTree = "<group>"; };
- F9183E650EFC80D70030B814 /* try.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = try.n; sourceTree = "<group>"; };
- F9183E6A0EFC81560030B814 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F9183E8F0EFC817B0030B814 /* tdbc */ = {isa = PBXFileReference; lastKnownFileType = folder; path = tdbc; sourceTree = "<group>"; };
- F91DC23C0E44C51B002CB8D1 /* nre.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = nre.test; sourceTree = "<group>"; };
- F91E62260C1AE686006C9D96 /* Tclsh-Info.plist.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xml; path = "Tclsh-Info.plist.in"; sourceTree = "<group>"; };
- F92D7F100DE777240033A13A /* tsdPerf.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tsdPerf.tcl; sourceTree = "<group>"; };
- F93599B20DF1F75400E04F67 /* tclOO.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOO.c; sourceTree = "<group>"; };
- F93599B40DF1F75900E04F67 /* tclOO.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclOO.decls; sourceTree = "<group>"; };
- F93599B50DF1F75D00E04F67 /* tclOO.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOO.h; sourceTree = "<group>"; };
- F93599B60DF1F76100E04F67 /* tclOOBasic.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOBasic.c; sourceTree = "<group>"; };
- F93599B80DF1F76600E04F67 /* tclOOCall.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOCall.c; sourceTree = "<group>"; };
- F93599BA0DF1F76A00E04F67 /* tclOODecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOODecls.h; sourceTree = "<group>"; };
- F93599BB0DF1F77000E04F67 /* tclOODefineCmds.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOODefineCmds.c; sourceTree = "<group>"; };
- F93599BD0DF1F77400E04F67 /* tclOOInfo.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOInfo.c; sourceTree = "<group>"; };
- F93599BF0DF1F77900E04F67 /* tclOOInt.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOOInt.h; sourceTree = "<group>"; };
- F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclOOIntDecls.h; sourceTree = "<group>"; };
- F93599C10DF1F78300E04F67 /* tclOOMethod.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOMethod.c; sourceTree = "<group>"; };
- F93599C30DF1F78800E04F67 /* tclOOStubInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubInit.c; sourceTree = "<group>"; };
- F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclOOStubLib.c; sourceTree = "<group>"; };
- F93599C80DF1F81900E04F67 /* oo.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = oo.test; sourceTree = "<group>"; };
- F93599CF0DF1F87F00E04F67 /* Class.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Class.3; sourceTree = "<group>"; };
- F93599D00DF1F89E00E04F67 /* class.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = class.n; sourceTree = "<group>"; };
- F93599D20DF1F8DF00E04F67 /* copy.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = copy.n; sourceTree = "<group>"; };
- F93599D30DF1F8F500E04F67 /* define.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = define.n; sourceTree = "<group>"; };
- F93599D40DF1F91900E04F67 /* Method.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Method.3; sourceTree = "<group>"; };
- F93599D50DF1F93700E04F67 /* my.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = my.n; sourceTree = "<group>"; };
- F93599D60DF1F95000E04F67 /* next.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = next.n; sourceTree = "<group>"; };
- F93599D70DF1F96800E04F67 /* object.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = object.n; sourceTree = "<group>"; };
- F93599D80DF1F98300E04F67 /* self.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = self.n; sourceTree = "<group>"; };
- F946FB8B0FBE3AED00CD6495 /* itcl */ = {isa = PBXFileReference; lastKnownFileType = folder; path = itcl; sourceTree = "<group>"; };
- F95D77E90DFD820D00A8BF6F /* tclIORTrans.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIORTrans.c; sourceTree = "<group>"; };
- F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = macOSXLoad.test; sourceTree = "<group>"; };
- F96437C90EF0D4B2003F468E /* tclZlib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclZlib.c; sourceTree = "<group>"; };
- F96437E60EF0D652003F468E /* libz.dylib */ = {isa = PBXFileReference; lastKnownFileType = "compiled.mach-o.dylib"; name = libz.dylib; path = /usr/lib/libz.dylib; sourceTree = "<absolute>"; };
- F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; };
- F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; };
- F96D3DFB08F272A4004A47F5 /* changes */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = changes; sourceTree = "<group>"; };
- F96D3DFD08F272A4004A47F5 /* Access.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Access.3; sourceTree = "<group>"; };
- F96D3DFE08F272A4004A47F5 /* AddErrInfo.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AddErrInfo.3; sourceTree = "<group>"; };
- F96D3DFF08F272A4004A47F5 /* after.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = after.n; sourceTree = "<group>"; };
- F96D3E0008F272A4004A47F5 /* Alloc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Alloc.3; sourceTree = "<group>"; };
- F96D3E0108F272A4004A47F5 /* AllowExc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AllowExc.3; sourceTree = "<group>"; };
- F96D3E0208F272A4004A47F5 /* append.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = append.n; sourceTree = "<group>"; };
- F96D3E0308F272A4004A47F5 /* AppInit.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AppInit.3; sourceTree = "<group>"; };
- F96D3E0408F272A5004A47F5 /* array.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = array.n; sourceTree = "<group>"; };
- F96D3E0508F272A5004A47F5 /* AssocData.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AssocData.3; sourceTree = "<group>"; };
- F96D3E0608F272A5004A47F5 /* Async.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Async.3; sourceTree = "<group>"; };
- F96D3E0708F272A5004A47F5 /* BackgdErr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = BackgdErr.3; sourceTree = "<group>"; };
- F96D3E0808F272A5004A47F5 /* Backslash.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Backslash.3; sourceTree = "<group>"; };
- F96D3E0908F272A5004A47F5 /* bgerror.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = bgerror.n; sourceTree = "<group>"; };
- F96D3E0A08F272A5004A47F5 /* binary.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = binary.n; sourceTree = "<group>"; };
- F96D3E0B08F272A5004A47F5 /* BoolObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = BoolObj.3; sourceTree = "<group>"; };
- F96D3E0C08F272A5004A47F5 /* break.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = break.n; sourceTree = "<group>"; };
- F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ByteArrObj.3; sourceTree = "<group>"; };
- F96D3E0E08F272A5004A47F5 /* CallDel.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CallDel.3; sourceTree = "<group>"; };
- F96D3E0F08F272A5004A47F5 /* case.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = case.n; sourceTree = "<group>"; };
- F96D3E1008F272A5004A47F5 /* catch.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = catch.n; sourceTree = "<group>"; };
- F96D3E1108F272A5004A47F5 /* cd.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = cd.n; sourceTree = "<group>"; };
- F96D3E1208F272A5004A47F5 /* chan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = chan.n; sourceTree = "<group>"; };
- F96D3E1308F272A5004A47F5 /* ChnlStack.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ChnlStack.3; sourceTree = "<group>"; };
- F96D3E1408F272A5004A47F5 /* clock.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = clock.n; sourceTree = "<group>"; };
- F96D3E1508F272A5004A47F5 /* close.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = close.n; sourceTree = "<group>"; };
- F96D3E1608F272A5004A47F5 /* CmdCmplt.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CmdCmplt.3; sourceTree = "<group>"; };
- F96D3E1708F272A5004A47F5 /* Concat.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Concat.3; sourceTree = "<group>"; };
- F96D3E1808F272A5004A47F5 /* concat.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = concat.n; sourceTree = "<group>"; };
- F96D3E1908F272A5004A47F5 /* continue.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = continue.n; sourceTree = "<group>"; };
- F96D3E1A08F272A5004A47F5 /* CrtChannel.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChannel.3; sourceTree = "<group>"; };
- F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtChnlHdlr.3; sourceTree = "<group>"; };
- F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCloseHdlr.3; sourceTree = "<group>"; };
- F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtCommand.3; sourceTree = "<group>"; };
- F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtFileHdlr.3; sourceTree = "<group>"; };
- F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtInterp.3; sourceTree = "<group>"; };
- F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtMathFnc.3; sourceTree = "<group>"; };
- F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtObjCmd.3; sourceTree = "<group>"; };
- F96D3E2208F272A5004A47F5 /* CrtAlias.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtAlias.3; sourceTree = "<group>"; };
- F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTimerHdlr.3; sourceTree = "<group>"; };
- F96D3E2408F272A5004A47F5 /* CrtTrace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = CrtTrace.3; sourceTree = "<group>"; };
- F96D3E2508F272A5004A47F5 /* dde.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dde.n; sourceTree = "<group>"; };
- F96D3E2608F272A5004A47F5 /* DetachPids.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DetachPids.3; sourceTree = "<group>"; };
- F96D3E2708F272A5004A47F5 /* dict.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = dict.n; sourceTree = "<group>"; };
- F96D3E2808F272A5004A47F5 /* DictObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DictObj.3; sourceTree = "<group>"; };
- F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoOneEvent.3; sourceTree = "<group>"; };
- F96D3E2A08F272A5004A47F5 /* DoubleObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoubleObj.3; sourceTree = "<group>"; };
- F96D3E2B08F272A5004A47F5 /* DoWhenIdle.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DoWhenIdle.3; sourceTree = "<group>"; };
- F96D3E2C08F272A5004A47F5 /* DString.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DString.3; sourceTree = "<group>"; };
- F96D3E2D08F272A5004A47F5 /* DumpActiveMemory.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = DumpActiveMemory.3; sourceTree = "<group>"; };
- F96D3E2E08F272A5004A47F5 /* Encoding.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Encoding.3; sourceTree = "<group>"; };
- F96D3E2F08F272A5004A47F5 /* encoding.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = encoding.n; sourceTree = "<group>"; };
- F96D3E3008F272A5004A47F5 /* Ensemble.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Ensemble.3; sourceTree = "<group>"; };
- F96D3E3108F272A5004A47F5 /* Environment.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Environment.3; sourceTree = "<group>"; };
- F96D3E3208F272A5004A47F5 /* eof.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = eof.n; sourceTree = "<group>"; };
- F96D3E3308F272A5004A47F5 /* error.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = error.n; sourceTree = "<group>"; };
- F96D3E3408F272A5004A47F5 /* Eval.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Eval.3; sourceTree = "<group>"; };
- F96D3E3508F272A5004A47F5 /* eval.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = eval.n; sourceTree = "<group>"; };
- F96D3E3608F272A5004A47F5 /* exec.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = exec.n; sourceTree = "<group>"; };
- F96D3E3708F272A5004A47F5 /* Exit.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Exit.3; sourceTree = "<group>"; };
- F96D3E3808F272A5004A47F5 /* exit.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = exit.n; sourceTree = "<group>"; };
- F96D3E3908F272A5004A47F5 /* expr.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = expr.n; sourceTree = "<group>"; };
- F96D3E3A08F272A5004A47F5 /* ExprLong.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ExprLong.3; sourceTree = "<group>"; };
- F96D3E3B08F272A5004A47F5 /* ExprLongObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ExprLongObj.3; sourceTree = "<group>"; };
- F96D3E3C08F272A5004A47F5 /* fblocked.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fblocked.n; sourceTree = "<group>"; };
- F96D3E3D08F272A5004A47F5 /* fconfigure.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fconfigure.n; sourceTree = "<group>"; };
- F96D3E3E08F272A5004A47F5 /* fcopy.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fcopy.n; sourceTree = "<group>"; };
- F96D3E3F08F272A5004A47F5 /* file.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = file.n; sourceTree = "<group>"; };
- F96D3E4008F272A5004A47F5 /* fileevent.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = fileevent.n; sourceTree = "<group>"; };
- F96D3E4108F272A5004A47F5 /* filename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = filename.n; sourceTree = "<group>"; };
- F96D3E4208F272A5004A47F5 /* FileSystem.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = FileSystem.3; sourceTree = "<group>"; };
- F96D3E4308F272A5004A47F5 /* FindExec.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = FindExec.3; sourceTree = "<group>"; };
- F96D3E4408F272A5004A47F5 /* flush.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = flush.n; sourceTree = "<group>"; };
- F96D3E4508F272A5004A47F5 /* for.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = for.n; sourceTree = "<group>"; };
- F96D3E4608F272A5004A47F5 /* foreach.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = foreach.n; sourceTree = "<group>"; };
- F96D3E4708F272A5004A47F5 /* format.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = format.n; sourceTree = "<group>"; };
- F96D3E4808F272A5004A47F5 /* GetCwd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetCwd.3; sourceTree = "<group>"; };
- F96D3E4908F272A5004A47F5 /* GetHostName.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetHostName.3; sourceTree = "<group>"; };
- F96D3E4A08F272A5004A47F5 /* GetIndex.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetIndex.3; sourceTree = "<group>"; };
- F96D3E4B08F272A5004A47F5 /* GetInt.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetInt.3; sourceTree = "<group>"; };
- F96D3E4C08F272A5004A47F5 /* GetOpnFl.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetOpnFl.3; sourceTree = "<group>"; };
- F96D3E4D08F272A5004A47F5 /* gets.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = gets.n; sourceTree = "<group>"; };
- F96D3E4E08F272A5004A47F5 /* GetStdChan.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetStdChan.3; sourceTree = "<group>"; };
- F96D3E4F08F272A5004A47F5 /* GetTime.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetTime.3; sourceTree = "<group>"; };
- F96D3E5008F272A5004A47F5 /* GetVersion.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = GetVersion.3; sourceTree = "<group>"; };
- F96D3E5108F272A5004A47F5 /* glob.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = glob.n; sourceTree = "<group>"; };
- F96D3E5208F272A6004A47F5 /* global.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = global.n; sourceTree = "<group>"; };
- F96D3E5308F272A6004A47F5 /* Hash.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Hash.3; sourceTree = "<group>"; };
- F96D3E5408F272A6004A47F5 /* history.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = history.n; sourceTree = "<group>"; };
- F96D3E5508F272A6004A47F5 /* http.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = http.n; sourceTree = "<group>"; };
- F96D3E5608F272A6004A47F5 /* if.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = if.n; sourceTree = "<group>"; };
- F96D3E5708F272A6004A47F5 /* incr.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = incr.n; sourceTree = "<group>"; };
- F96D3E5808F272A6004A47F5 /* info.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = info.n; sourceTree = "<group>"; };
- F96D3E5908F272A6004A47F5 /* Init.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Init.3; sourceTree = "<group>"; };
- F96D3E5A08F272A6004A47F5 /* InitStubs.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = InitStubs.3; sourceTree = "<group>"; };
- F96D3E5B08F272A6004A47F5 /* Interp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Interp.3; sourceTree = "<group>"; };
- F96D3E5C08F272A6004A47F5 /* interp.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = interp.n; sourceTree = "<group>"; };
- F96D3E5D08F272A6004A47F5 /* IntObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = IntObj.3; sourceTree = "<group>"; };
- F96D3E5E08F272A6004A47F5 /* join.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = join.n; sourceTree = "<group>"; };
- F96D3E5F08F272A6004A47F5 /* lappend.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lappend.n; sourceTree = "<group>"; };
- F96D3E6008F272A6004A47F5 /* lassign.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lassign.n; sourceTree = "<group>"; };
- F96D3E6108F272A6004A47F5 /* library.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = library.n; sourceTree = "<group>"; };
- F96D3E6208F272A6004A47F5 /* Limit.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Limit.3; sourceTree = "<group>"; };
- F96D3E6308F272A6004A47F5 /* lindex.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lindex.n; sourceTree = "<group>"; };
- F96D3E6408F272A6004A47F5 /* LinkVar.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = LinkVar.3; sourceTree = "<group>"; };
- F96D3E6508F272A6004A47F5 /* linsert.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = linsert.n; sourceTree = "<group>"; };
- F96D3E6608F272A6004A47F5 /* list.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = list.n; sourceTree = "<group>"; };
- F96D3E6708F272A6004A47F5 /* ListObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ListObj.3; sourceTree = "<group>"; };
- F96D3E6808F272A6004A47F5 /* llength.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = llength.n; sourceTree = "<group>"; };
- F96D3E6908F272A6004A47F5 /* load.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = load.n; sourceTree = "<group>"; };
- F96D3E6A08F272A6004A47F5 /* lrange.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lrange.n; sourceTree = "<group>"; };
- F96D3E6B08F272A6004A47F5 /* lrepeat.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lrepeat.n; sourceTree = "<group>"; };
- F96D3E6C08F272A6004A47F5 /* lreplace.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lreplace.n; sourceTree = "<group>"; };
- F96D3E6D08F272A6004A47F5 /* lsearch.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lsearch.n; sourceTree = "<group>"; };
- F96D3E6E08F272A6004A47F5 /* lset.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lset.n; sourceTree = "<group>"; };
- F96D3E6F08F272A6004A47F5 /* lsort.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = lsort.n; sourceTree = "<group>"; };
- F96D3E7008F272A6004A47F5 /* man.macros */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = man.macros; sourceTree = "<group>"; };
- F96D3E7108F272A6004A47F5 /* mathfunc.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = mathfunc.n; sourceTree = "<group>"; };
- F96D3E7208F272A6004A47F5 /* memory.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = memory.n; sourceTree = "<group>"; };
- F96D3E7308F272A6004A47F5 /* msgcat.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = msgcat.n; sourceTree = "<group>"; };
- F96D3E7408F272A6004A47F5 /* Namespace.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Namespace.3; sourceTree = "<group>"; };
- F96D3E7508F272A6004A47F5 /* namespace.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = namespace.n; sourceTree = "<group>"; };
- F96D3E7608F272A6004A47F5 /* Notifier.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Notifier.3; sourceTree = "<group>"; };
- F96D3E7708F272A6004A47F5 /* Object.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Object.3; sourceTree = "<group>"; };
- F96D3E7808F272A6004A47F5 /* ObjectType.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ObjectType.3; sourceTree = "<group>"; };
- F96D3E7908F272A6004A47F5 /* open.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = open.n; sourceTree = "<group>"; };
- F96D3E7A08F272A6004A47F5 /* OpenFileChnl.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = OpenFileChnl.3; sourceTree = "<group>"; };
- F96D3E7B08F272A6004A47F5 /* OpenTcp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = OpenTcp.3; sourceTree = "<group>"; };
- F96D3E7C08F272A6004A47F5 /* package.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = package.n; sourceTree = "<group>"; };
- F96D3E7D08F272A6004A47F5 /* packagens.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = packagens.n; sourceTree = "<group>"; };
- F96D3E7E08F272A6004A47F5 /* Panic.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Panic.3; sourceTree = "<group>"; };
- F96D3E7F08F272A6004A47F5 /* ParseCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ParseCmd.3; sourceTree = "<group>"; };
- F96D3E8008F272A6004A47F5 /* pid.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = pid.n; sourceTree = "<group>"; };
- F96D3E8108F272A6004A47F5 /* pkgMkIndex.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = pkgMkIndex.n; sourceTree = "<group>"; };
- F96D3E8208F272A6004A47F5 /* PkgRequire.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = PkgRequire.3; sourceTree = "<group>"; };
- F96D3E8308F272A6004A47F5 /* Preserve.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Preserve.3; sourceTree = "<group>"; };
- F96D3E8408F272A6004A47F5 /* PrintDbl.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = PrintDbl.3; sourceTree = "<group>"; };
- F96D3E8508F272A6004A47F5 /* proc.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = proc.n; sourceTree = "<group>"; };
- F96D3E8608F272A6004A47F5 /* puts.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = puts.n; sourceTree = "<group>"; };
- F96D3E8708F272A6004A47F5 /* pwd.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = pwd.n; sourceTree = "<group>"; };
- F96D3E8808F272A6004A47F5 /* re_syntax.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = re_syntax.n; sourceTree = "<group>"; };
- F96D3E8908F272A6004A47F5 /* read.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = read.n; sourceTree = "<group>"; };
- F96D3E8A08F272A6004A47F5 /* RecEvalObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = RecEvalObj.3; sourceTree = "<group>"; };
- F96D3E8B08F272A6004A47F5 /* RecordEval.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = RecordEval.3; sourceTree = "<group>"; };
- F96D3E8C08F272A6004A47F5 /* RegConfig.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = RegConfig.3; sourceTree = "<group>"; };
- F96D3E8D08F272A6004A47F5 /* RegExp.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = RegExp.3; sourceTree = "<group>"; };
- F96D3E8E08F272A6004A47F5 /* regexp.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = regexp.n; sourceTree = "<group>"; };
- F96D3E8F08F272A6004A47F5 /* registry.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = registry.n; sourceTree = "<group>"; };
- F96D3E9008F272A6004A47F5 /* regsub.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = regsub.n; sourceTree = "<group>"; };
- F96D3E9108F272A6004A47F5 /* rename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = rename.n; sourceTree = "<group>"; };
- F96D3E9208F272A6004A47F5 /* return.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = return.n; sourceTree = "<group>"; };
- F96D3E9308F272A6004A47F5 /* safe.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = safe.n; sourceTree = "<group>"; };
- F96D3E9408F272A6004A47F5 /* SaveResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveResult.3; sourceTree = "<group>"; };
- F96D3E9508F272A6004A47F5 /* scan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = scan.n; sourceTree = "<group>"; };
- F96D3E9608F272A6004A47F5 /* seek.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = seek.n; sourceTree = "<group>"; };
- F96D3E9708F272A6004A47F5 /* set.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = set.n; sourceTree = "<group>"; };
- F96D3E9808F272A6004A47F5 /* SetChanErr.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SetChanErr.3; sourceTree = "<group>"; };
- F96D3E9908F272A6004A47F5 /* SetErrno.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SetErrno.3; sourceTree = "<group>"; };
- F96D3E9A08F272A6004A47F5 /* SetRecLmt.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SetRecLmt.3; sourceTree = "<group>"; };
- F96D3E9B08F272A7004A47F5 /* SetResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SetResult.3; sourceTree = "<group>"; };
- F96D3E9C08F272A7004A47F5 /* SetVar.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SetVar.3; sourceTree = "<group>"; };
- F96D3E9D08F272A7004A47F5 /* Signal.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Signal.3; sourceTree = "<group>"; };
- F96D3E9E08F272A7004A47F5 /* Sleep.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Sleep.3; sourceTree = "<group>"; };
- F96D3E9F08F272A7004A47F5 /* socket.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = socket.n; sourceTree = "<group>"; };
- F96D3EA008F272A7004A47F5 /* source.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = source.n; sourceTree = "<group>"; };
- F96D3EA108F272A7004A47F5 /* SourceRCFile.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SourceRCFile.3; sourceTree = "<group>"; };
- F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = "<group>"; };
- F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = "<group>"; };
- F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = "<group>"; };
- F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = "<group>"; };
- F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = "<group>"; };
- F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = "<group>"; };
- F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = "<group>"; };
- F96D3EA908F272A7004A47F5 /* StrMatch.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StrMatch.3; sourceTree = "<group>"; };
- F96D3EAA08F272A7004A47F5 /* subst.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = subst.n; sourceTree = "<group>"; };
- F96D3EAB08F272A7004A47F5 /* SubstObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SubstObj.3; sourceTree = "<group>"; };
- F96D3EAC08F272A7004A47F5 /* switch.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = switch.n; sourceTree = "<group>"; };
- F96D3EAD08F272A7004A47F5 /* Tcl.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Tcl.n; sourceTree = "<group>"; };
- F96D3EAE08F272A7004A47F5 /* Tcl_Main.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Tcl_Main.3; sourceTree = "<group>"; };
- F96D3EAF08F272A7004A47F5 /* TCL_MEM_DEBUG.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = TCL_MEM_DEBUG.3; sourceTree = "<group>"; };
- F96D3EB008F272A7004A47F5 /* tclsh.1 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tclsh.1; sourceTree = "<group>"; };
- F96D3EB108F272A7004A47F5 /* tcltest.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tcltest.n; sourceTree = "<group>"; };
- F96D3EB208F272A7004A47F5 /* tclvars.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tclvars.n; sourceTree = "<group>"; };
- F96D3EB308F272A7004A47F5 /* tell.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tell.n; sourceTree = "<group>"; };
- F96D3EB408F272A7004A47F5 /* Thread.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Thread.3; sourceTree = "<group>"; };
- F96D3EB508F272A7004A47F5 /* time.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = time.n; sourceTree = "<group>"; };
- F96D3EB608F272A7004A47F5 /* tm.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tm.n; sourceTree = "<group>"; };
- F96D3EB708F272A7004A47F5 /* ToUpper.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = ToUpper.3; sourceTree = "<group>"; };
- F96D3EB808F272A7004A47F5 /* trace.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = trace.n; sourceTree = "<group>"; };
- F96D3EB908F272A7004A47F5 /* TraceCmd.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = TraceCmd.3; sourceTree = "<group>"; };
- F96D3EBA08F272A7004A47F5 /* TraceVar.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = TraceVar.3; sourceTree = "<group>"; };
- F96D3EBB08F272A7004A47F5 /* Translate.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Translate.3; sourceTree = "<group>"; };
- F96D3EBC08F272A7004A47F5 /* UniCharIsAlpha.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = UniCharIsAlpha.3; sourceTree = "<group>"; };
- F96D3EBD08F272A7004A47F5 /* unknown.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = unknown.n; sourceTree = "<group>"; };
- F96D3EBE08F272A7004A47F5 /* unload.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = unload.n; sourceTree = "<group>"; };
- F96D3EBF08F272A7004A47F5 /* unset.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = unset.n; sourceTree = "<group>"; };
- F96D3EC008F272A7004A47F5 /* update.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = update.n; sourceTree = "<group>"; };
- F96D3EC108F272A7004A47F5 /* uplevel.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = uplevel.n; sourceTree = "<group>"; };
- F96D3EC208F272A7004A47F5 /* UpVar.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = UpVar.3; sourceTree = "<group>"; };
- F96D3EC308F272A7004A47F5 /* upvar.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = upvar.n; sourceTree = "<group>"; };
- F96D3EC408F272A7004A47F5 /* Utf.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Utf.3; sourceTree = "<group>"; };
- F96D3EC508F272A7004A47F5 /* variable.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = variable.n; sourceTree = "<group>"; };
- F96D3EC608F272A7004A47F5 /* vwait.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = vwait.n; sourceTree = "<group>"; };
- F96D3EC708F272A7004A47F5 /* while.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = while.n; sourceTree = "<group>"; };
- F96D3EC808F272A7004A47F5 /* WrongNumArgs.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = WrongNumArgs.3; sourceTree = "<group>"; };
- F96D3ECA08F272A7004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D3ECB08F272A7004A47F5 /* regc_color.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regc_color.c; sourceTree = "<group>"; };
- F96D3ECC08F272A7004A47F5 /* regc_cvec.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regc_cvec.c; sourceTree = "<group>"; };
- F96D3ECD08F272A7004A47F5 /* regc_lex.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regc_lex.c; sourceTree = "<group>"; };
- F96D3ECE08F272A7004A47F5 /* regc_locale.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regc_locale.c; sourceTree = "<group>"; };
- F96D3ECF08F272A7004A47F5 /* regc_nfa.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regc_nfa.c; sourceTree = "<group>"; };
- F96D3ED008F272A7004A47F5 /* regcomp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regcomp.c; sourceTree = "<group>"; };
- F96D3ED108F272A7004A47F5 /* regcustom.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = regcustom.h; sourceTree = "<group>"; };
- F96D3ED208F272A7004A47F5 /* rege_dfa.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = rege_dfa.c; sourceTree = "<group>"; };
- F96D3ED308F272A7004A47F5 /* regerror.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regerror.c; sourceTree = "<group>"; };
- F96D3ED408F272A7004A47F5 /* regerrs.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = regerrs.h; sourceTree = "<group>"; };
- F96D3ED508F272A7004A47F5 /* regex.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = regex.h; sourceTree = "<group>"; };
- F96D3ED608F272A7004A47F5 /* regexec.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regexec.c; sourceTree = "<group>"; };
- F96D3ED708F272A7004A47F5 /* regfree.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regfree.c; sourceTree = "<group>"; };
- F96D3ED808F272A7004A47F5 /* regfronts.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = regfronts.c; sourceTree = "<group>"; };
- F96D3ED908F272A7004A47F5 /* regguts.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = regguts.h; sourceTree = "<group>"; };
- F96D3EDA08F272A7004A47F5 /* tcl.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tcl.decls; sourceTree = "<group>"; };
- F96D3EDB08F272A7004A47F5 /* tcl.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tcl.h; sourceTree = "<group>"; };
- F96D3EDC08F272A7004A47F5 /* tclAlloc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAlloc.c; sourceTree = "<group>"; };
- F96D3EDD08F272A7004A47F5 /* tclAsync.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAsync.c; sourceTree = "<group>"; };
- F96D3EDE08F272A7004A47F5 /* tclBasic.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclBasic.c; sourceTree = "<group>"; };
- F96D3EDF08F272A7004A47F5 /* tclBinary.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclBinary.c; sourceTree = "<group>"; };
- F96D3EE008F272A7004A47F5 /* tclCkalloc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCkalloc.c; sourceTree = "<group>"; };
- F96D3EE108F272A7004A47F5 /* tclClock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclClock.c; sourceTree = "<group>"; };
- F96D3EE208F272A7004A47F5 /* tclCmdAH.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCmdAH.c; sourceTree = "<group>"; };
- F96D3EE308F272A7004A47F5 /* tclCmdIL.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCmdIL.c; sourceTree = "<group>"; };
- F96D3EE408F272A7004A47F5 /* tclCmdMZ.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCmdMZ.c; sourceTree = "<group>"; };
- F96D3EE508F272A7004A47F5 /* tclCompCmds.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCompCmds.c; sourceTree = "<group>"; };
- F96D3EE608F272A7004A47F5 /* tclCompExpr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCompExpr.c; sourceTree = "<group>"; };
- F96D3EE708F272A7004A47F5 /* tclCompile.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclCompile.c; sourceTree = "<group>"; };
- F96D3EE808F272A7004A47F5 /* tclCompile.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclCompile.h; sourceTree = "<group>"; };
- F96D3EE908F272A7004A47F5 /* tclConfig.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclConfig.c; sourceTree = "<group>"; };
- F96D3EEA08F272A7004A47F5 /* tclDate.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclDate.c; sourceTree = "<group>"; };
- F96D3EEB08F272A7004A47F5 /* tclDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclDecls.h; sourceTree = "<group>"; };
- F96D3EEC08F272A7004A47F5 /* tclDictObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclDictObj.c; sourceTree = "<group>"; };
- F96D3EED08F272A7004A47F5 /* tclEncoding.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclEncoding.c; sourceTree = "<group>"; };
- F96D3EEE08F272A7004A47F5 /* tclEnv.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclEnv.c; sourceTree = "<group>"; };
- F96D3EEF08F272A7004A47F5 /* tclEvent.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclEvent.c; sourceTree = "<group>"; };
- F96D3EF008F272A7004A47F5 /* tclExecute.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclExecute.c; sourceTree = "<group>"; };
- F96D3EF108F272A7004A47F5 /* tclFCmd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclFCmd.c; sourceTree = "<group>"; };
- F96D3EF208F272A7004A47F5 /* tclFileName.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclFileName.c; sourceTree = "<group>"; };
- F96D3EF308F272A7004A47F5 /* tclFileSystem.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclFileSystem.h; sourceTree = "<group>"; };
- F96D3EF408F272A7004A47F5 /* tclGet.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclGet.c; sourceTree = "<group>"; };
- F96D3EF508F272A7004A47F5 /* tclGetDate.y */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.yacc; path = tclGetDate.y; sourceTree = "<group>"; };
- F96D3EF608F272A7004A47F5 /* tclHash.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclHash.c; sourceTree = "<group>"; };
- F96D3EF708F272A7004A47F5 /* tclHistory.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclHistory.c; sourceTree = "<group>"; };
- F96D3EF808F272A7004A47F5 /* tclIndexObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIndexObj.c; sourceTree = "<group>"; };
- F96D3EF908F272A7004A47F5 /* tclInt.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclInt.decls; sourceTree = "<group>"; };
- F96D3EFA08F272A7004A47F5 /* tclInt.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclInt.h; sourceTree = "<group>"; };
- F96D3EFB08F272A7004A47F5 /* tclIntDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclIntDecls.h; sourceTree = "<group>"; };
- F96D3EFC08F272A7004A47F5 /* tclInterp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclInterp.c; sourceTree = "<group>"; };
- F96D3EFD08F272A7004A47F5 /* tclIntPlatDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclIntPlatDecls.h; sourceTree = "<group>"; };
- F96D3EFE08F272A7004A47F5 /* tclIO.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIO.c; sourceTree = "<group>"; };
- F96D3EFF08F272A7004A47F5 /* tclIO.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclIO.h; sourceTree = "<group>"; };
- F96D3F0008F272A7004A47F5 /* tclIOCmd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIOCmd.c; sourceTree = "<group>"; };
- F96D3F0108F272A7004A47F5 /* tclIOGT.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIOGT.c; sourceTree = "<group>"; };
- F96D3F0208F272A7004A47F5 /* tclIORChan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIORChan.c; sourceTree = "<group>"; };
- F96D3F0308F272A7004A47F5 /* tclIOSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIOSock.c; sourceTree = "<group>"; };
- F96D3F0408F272A7004A47F5 /* tclIOUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclIOUtil.c; sourceTree = "<group>"; };
- F96D3F0508F272A7004A47F5 /* tclLink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLink.c; sourceTree = "<group>"; };
- F96D3F0608F272A7004A47F5 /* tclListObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclListObj.c; sourceTree = "<group>"; };
- F96D3F0708F272A7004A47F5 /* tclLiteral.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLiteral.c; sourceTree = "<group>"; };
- F96D3F0808F272A7004A47F5 /* tclLoad.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoad.c; sourceTree = "<group>"; };
- F96D3F0908F272A7004A47F5 /* tclLoadNone.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadNone.c; sourceTree = "<group>"; };
- F96D3F0A08F272A7004A47F5 /* tclMain.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMain.c; sourceTree = "<group>"; };
- F96D3F0B08F272A7004A47F5 /* tclNamesp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclNamesp.c; sourceTree = "<group>"; };
- F96D3F0C08F272A7004A47F5 /* tclNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclNotify.c; sourceTree = "<group>"; };
- F96D3F0D08F272A7004A47F5 /* tclObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclObj.c; sourceTree = "<group>"; };
- F96D3F0E08F272A7004A47F5 /* tclPanic.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPanic.c; sourceTree = "<group>"; };
- F96D3F0F08F272A7004A47F5 /* tclParse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclParse.c; sourceTree = "<group>"; };
- F96D3F1108F272A7004A47F5 /* tclPathObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPathObj.c; sourceTree = "<group>"; };
- F96D3F1208F272A7004A47F5 /* tclPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPipe.c; sourceTree = "<group>"; };
- F96D3F1308F272A7004A47F5 /* tclPkg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPkg.c; sourceTree = "<group>"; };
- F96D3F1408F272A7004A47F5 /* tclPkgConfig.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPkgConfig.c; sourceTree = "<group>"; };
- F96D3F1508F272A7004A47F5 /* tclPlatDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclPlatDecls.h; sourceTree = "<group>"; };
- F96D3F1608F272A7004A47F5 /* tclPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclPort.h; sourceTree = "<group>"; };
- F96D3F1708F272A7004A47F5 /* tclPosixStr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPosixStr.c; sourceTree = "<group>"; };
- F96D3F1808F272A7004A47F5 /* tclPreserve.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclPreserve.c; sourceTree = "<group>"; };
- F96D3F1908F272A7004A47F5 /* tclProc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclProc.c; sourceTree = "<group>"; };
- F96D3F1A08F272A7004A47F5 /* tclRegexp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclRegexp.c; sourceTree = "<group>"; };
- F96D3F1B08F272A7004A47F5 /* tclRegexp.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclRegexp.h; sourceTree = "<group>"; };
- F96D3F1C08F272A7004A47F5 /* tclResolve.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclResolve.c; sourceTree = "<group>"; };
- F96D3F1D08F272A7004A47F5 /* tclResult.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclResult.c; sourceTree = "<group>"; };
- F96D3F1E08F272A7004A47F5 /* tclScan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclScan.c; sourceTree = "<group>"; };
- F96D3F1F08F272A7004A47F5 /* tclStringObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclStringObj.c; sourceTree = "<group>"; };
- F96D3F2408F272A7004A47F5 /* tclStrToD.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclStrToD.c; sourceTree = "<group>"; };
- F96D3F2508F272A7004A47F5 /* tclStubInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclStubInit.c; sourceTree = "<group>"; };
- F96D3F2608F272A7004A47F5 /* tclStubLib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclStubLib.c; sourceTree = "<group>"; };
- F96D3F2708F272A7004A47F5 /* tclTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTest.c; sourceTree = "<group>"; };
- F96D3F2808F272A7004A47F5 /* tclTestObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTestObj.c; sourceTree = "<group>"; };
- F96D3F2908F272A7004A47F5 /* tclTestProcBodyObj.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTestProcBodyObj.c; sourceTree = "<group>"; };
- F96D3F2A08F272A7004A47F5 /* tclThread.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclThread.c; sourceTree = "<group>"; };
- F96D3F2B08F272A7004A47F5 /* tclThreadAlloc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclThreadAlloc.c; sourceTree = "<group>"; };
- F96D3F2C08F272A7004A47F5 /* tclThreadJoin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclThreadJoin.c; sourceTree = "<group>"; };
- F96D3F2D08F272A7004A47F5 /* tclThreadStorage.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclThreadStorage.c; sourceTree = "<group>"; };
- F96D3F2E08F272A7004A47F5 /* tclThreadTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclThreadTest.c; sourceTree = "<group>"; };
- F96D3F2F08F272A7004A47F5 /* tclTimer.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTimer.c; sourceTree = "<group>"; };
- F96D3F3008F272A7004A47F5 /* tclTomMath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMath.h; sourceTree = "<group>"; };
- F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTomMathInterface.c; sourceTree = "<group>"; };
- F96D3F3208F272A7004A47F5 /* tclTrace.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTrace.c; sourceTree = "<group>"; };
- F96D3F3308F272A7004A47F5 /* tclUniData.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUniData.c; sourceTree = "<group>"; };
- F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
- F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
- F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
- F96D3F3708F272A7004A47F5 /* tommath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath.h; sourceTree = "<group>"; };
- F96D3F3908F272A8004A47F5 /* auto.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = auto.tcl; sourceTree = "<group>"; };
- F96D3F3A08F272A8004A47F5 /* clock.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = clock.tcl; sourceTree = "<group>"; };
- F96D3F3C08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D3F8C08F272A8004A47F5 /* history.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = history.tcl; sourceTree = "<group>"; };
- F96D3F8E08F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
- F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D3F9108F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
- F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D3F9308F272A8004A47F5 /* init.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = init.tcl; sourceTree = "<group>"; };
- F96D3F9508F272A8004A47F5 /* msgcat.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = msgcat.tcl; sourceTree = "<group>"; };
- F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D401808F272AA004A47F5 /* optparse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = optparse.tcl; sourceTree = "<group>"; };
- F96D401908F272AA004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D401A08F272AA004A47F5 /* package.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = package.tcl; sourceTree = "<group>"; };
- F96D401B08F272AA004A47F5 /* parray.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = parray.tcl; sourceTree = "<group>"; };
- F96D401D08F272AA004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D401E08F272AA004A47F5 /* safe.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = safe.tcl; sourceTree = "<group>"; };
- F96D401F08F272AA004A47F5 /* tclIndex */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclIndex; sourceTree = "<group>"; };
- F96D402108F272AA004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F96D402208F272AA004A47F5 /* tcltest.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tcltest.tcl; sourceTree = "<group>"; };
- F96D402308F272AA004A47F5 /* tm.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tm.tcl; sourceTree = "<group>"; };
- F96D425B08F272B2004A47F5 /* word.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = word.tcl; sourceTree = "<group>"; };
- F96D426408F272B3004A47F5 /* bn_fast_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_fast_s_mp_mul_digs.c; sourceTree = "<group>"; };
- F96D426608F272B3004A47F5 /* bn_fast_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_fast_s_mp_sqr.c; sourceTree = "<group>"; };
- F96D426908F272B3004A47F5 /* bn_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_add.c; sourceTree = "<group>"; };
- F96D426A08F272B3004A47F5 /* bn_mp_add_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_add_d.c; sourceTree = "<group>"; };
- F96D426C08F272B3004A47F5 /* bn_mp_and.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_and.c; sourceTree = "<group>"; };
- F96D426D08F272B3004A47F5 /* bn_mp_clamp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_clamp.c; sourceTree = "<group>"; };
- F96D426E08F272B3004A47F5 /* bn_mp_clear.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_clear.c; sourceTree = "<group>"; };
- F96D426F08F272B3004A47F5 /* bn_mp_clear_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_clear_multi.c; sourceTree = "<group>"; };
- F96D427008F272B3004A47F5 /* bn_mp_cmp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_cmp.c; sourceTree = "<group>"; };
- F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_cmp_d.c; sourceTree = "<group>"; };
- F96D427208F272B3004A47F5 /* bn_mp_cmp_mag.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_cmp_mag.c; sourceTree = "<group>"; };
- F96D427408F272B3004A47F5 /* bn_mp_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_copy.c; sourceTree = "<group>"; };
- F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_count_bits.c; sourceTree = "<group>"; };
- F96D427608F272B3004A47F5 /* bn_mp_div.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div.c; sourceTree = "<group>"; };
- F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = "<group>"; };
- F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = "<group>"; };
- F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = "<group>"; };
- F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
- F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
- F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = "<group>"; };
- F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = "<group>"; };
- F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = "<group>"; };
- F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = "<group>"; };
- F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_multi.c; sourceTree = "<group>"; };
- F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_set.c; sourceTree = "<group>"; };
- F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_size.c; sourceTree = "<group>"; };
- F96D429208F272B3004A47F5 /* bn_mp_karatsuba_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_karatsuba_mul.c; sourceTree = "<group>"; };
- F96D429308F272B3004A47F5 /* bn_mp_karatsuba_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_karatsuba_sqr.c; sourceTree = "<group>"; };
- F96D429508F272B3004A47F5 /* bn_mp_lshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_lshd.c; sourceTree = "<group>"; };
- F96D429608F272B3004A47F5 /* bn_mp_mod.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mod.c; sourceTree = "<group>"; };
- F96D429708F272B3004A47F5 /* bn_mp_mod_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mod_2d.c; sourceTree = "<group>"; };
- F96D429C08F272B3004A47F5 /* bn_mp_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mul.c; sourceTree = "<group>"; };
- F96D429D08F272B3004A47F5 /* bn_mp_mul_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mul_2.c; sourceTree = "<group>"; };
- F96D429E08F272B3004A47F5 /* bn_mp_mul_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mul_2d.c; sourceTree = "<group>"; };
- F96D429F08F272B3004A47F5 /* bn_mp_mul_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_mul_d.c; sourceTree = "<group>"; };
- F96D42A208F272B3004A47F5 /* bn_mp_neg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_neg.c; sourceTree = "<group>"; };
- F96D42A308F272B3004A47F5 /* bn_mp_or.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_or.c; sourceTree = "<group>"; };
- F96D42AB08F272B3004A47F5 /* bn_mp_radix_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_radix_size.c; sourceTree = "<group>"; };
- F96D42AC08F272B3004A47F5 /* bn_mp_radix_smap.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_radix_smap.c; sourceTree = "<group>"; };
- F96D42AE08F272B3004A47F5 /* bn_mp_read_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_read_radix.c; sourceTree = "<group>"; };
- F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_rshd.c; sourceTree = "<group>"; };
- F96D42BA08F272B3004A47F5 /* bn_mp_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_set.c; sourceTree = "<group>"; };
- F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = "<group>"; };
- F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = "<group>"; };
- F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = "<group>"; };
- F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = "<group>"; };
- F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = "<group>"; };
- F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_ubin.c; sourceTree = "<group>"; };
- F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_mul.c; sourceTree = "<group>"; };
- F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_sqr.c; sourceTree = "<group>"; };
- F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_radix.c; sourceTree = "<group>"; };
- F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = "<group>"; };
- F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
- F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
- F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
- F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
- F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
- F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
- F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
- F96D432908F272B4004A47F5 /* tommath_class.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_class.h; sourceTree = "<group>"; };
- F96D432A08F272B4004A47F5 /* tommath_superclass.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_superclass.h; sourceTree = "<group>"; };
- F96D432B08F272B4004A47F5 /* license.terms */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = license.terms; sourceTree = "<group>"; };
- F96D432E08F272B5004A47F5 /* configure.ac */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure.ac; sourceTree = "<group>"; };
- F96D432F08F272B5004A47F5 /* GNUmakefile */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = GNUmakefile; sourceTree = "<group>"; };
- F96D433108F272B5004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D433208F272B5004A47F5 /* Tcl-Info.plist.in */ = {isa = PBXFileReference; explicitFileType = text.plist; fileEncoding = 4; path = "Tcl-Info.plist.in"; sourceTree = "<group>"; };
- F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMacOSXBundle.c; sourceTree = "<group>"; };
- F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMacOSXFCmd.c; sourceTree = "<group>"; };
- F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclMacOSXNotify.c; sourceTree = "<group>"; };
- F96D434308F272B5004A47F5 /* README */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = README; sourceTree = "<group>"; };
- F96D434508F272B5004A47F5 /* all.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = all.tcl; sourceTree = "<group>"; };
- F96D434608F272B5004A47F5 /* append.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = append.test; sourceTree = "<group>"; };
- F96D434708F272B5004A47F5 /* appendComp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = appendComp.test; sourceTree = "<group>"; };
- F96D434808F272B5004A47F5 /* assocd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = assocd.test; sourceTree = "<group>"; };
- F96D434908F272B5004A47F5 /* async.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = async.test; sourceTree = "<group>"; };
- F96D434A08F272B5004A47F5 /* autoMkindex.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = autoMkindex.test; sourceTree = "<group>"; };
- F96D434B08F272B5004A47F5 /* basic.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = basic.test; sourceTree = "<group>"; };
- F96D434C08F272B5004A47F5 /* binary.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = binary.test; sourceTree = "<group>"; };
- F96D434D08F272B5004A47F5 /* case.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = case.test; sourceTree = "<group>"; };
- F96D434E08F272B5004A47F5 /* chan.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chan.test; sourceTree = "<group>"; };
- F96D434F08F272B5004A47F5 /* clock.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = clock.test; sourceTree = "<group>"; };
- F96D435008F272B5004A47F5 /* cmdAH.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = cmdAH.test; sourceTree = "<group>"; };
- F96D435108F272B5004A47F5 /* cmdIL.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = cmdIL.test; sourceTree = "<group>"; };
- F96D435208F272B5004A47F5 /* cmdInfo.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = cmdInfo.test; sourceTree = "<group>"; };
- F96D435308F272B5004A47F5 /* cmdMZ.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = cmdMZ.test; sourceTree = "<group>"; };
- F96D435408F272B5004A47F5 /* compExpr-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "compExpr-old.test"; sourceTree = "<group>"; };
- F96D435508F272B5004A47F5 /* compExpr.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = compExpr.test; sourceTree = "<group>"; };
- F96D435608F272B5004A47F5 /* compile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = compile.test; sourceTree = "<group>"; };
- F96D435708F272B5004A47F5 /* concat.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = concat.test; sourceTree = "<group>"; };
- F96D435808F272B5004A47F5 /* config.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = config.test; sourceTree = "<group>"; };
- F96D435908F272B5004A47F5 /* dcall.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = dcall.test; sourceTree = "<group>"; };
- F96D435A08F272B5004A47F5 /* dict.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = dict.test; sourceTree = "<group>"; };
- F96D435C08F272B5004A47F5 /* dstring.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = dstring.test; sourceTree = "<group>"; };
- F96D435E08F272B5004A47F5 /* encoding.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = encoding.test; sourceTree = "<group>"; };
- F96D435F08F272B5004A47F5 /* env.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = env.test; sourceTree = "<group>"; };
- F96D436008F272B5004A47F5 /* error.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = error.test; sourceTree = "<group>"; };
- F96D436108F272B5004A47F5 /* eval.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = eval.test; sourceTree = "<group>"; };
- F96D436208F272B5004A47F5 /* event.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = event.test; sourceTree = "<group>"; };
- F96D436308F272B5004A47F5 /* exec.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = exec.test; sourceTree = "<group>"; };
- F96D436408F272B5004A47F5 /* execute.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = execute.test; sourceTree = "<group>"; };
- F96D436508F272B5004A47F5 /* expr-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "expr-old.test"; sourceTree = "<group>"; };
- F96D436608F272B5004A47F5 /* expr.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = expr.test; sourceTree = "<group>"; };
- F96D436708F272B6004A47F5 /* fCmd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fCmd.test; sourceTree = "<group>"; };
- F96D436808F272B6004A47F5 /* fileName.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fileName.test; sourceTree = "<group>"; };
- F96D436908F272B6004A47F5 /* fileSystem.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fileSystem.test; sourceTree = "<group>"; };
- F96D436A08F272B6004A47F5 /* for-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "for-old.test"; sourceTree = "<group>"; };
- F96D436B08F272B6004A47F5 /* for.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = for.test; sourceTree = "<group>"; };
- F96D436C08F272B6004A47F5 /* foreach.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = foreach.test; sourceTree = "<group>"; };
- F96D436D08F272B6004A47F5 /* format.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = format.test; sourceTree = "<group>"; };
- F96D436E08F272B6004A47F5 /* get.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = get.test; sourceTree = "<group>"; };
- F96D436F08F272B6004A47F5 /* history.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = history.test; sourceTree = "<group>"; };
- F96D437008F272B6004A47F5 /* http.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.test; sourceTree = "<group>"; };
- F96D437108F272B6004A47F5 /* httpd */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = httpd; sourceTree = "<group>"; };
- F96D437208F272B6004A47F5 /* httpold.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = httpold.test; sourceTree = "<group>"; };
- F96D437308F272B6004A47F5 /* if-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "if-old.test"; sourceTree = "<group>"; };
- F96D437408F272B6004A47F5 /* if.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = if.test; sourceTree = "<group>"; };
- F96D437508F272B6004A47F5 /* incr-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "incr-old.test"; sourceTree = "<group>"; };
- F96D437608F272B6004A47F5 /* incr.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = incr.test; sourceTree = "<group>"; };
- F96D437708F272B6004A47F5 /* indexObj.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = indexObj.test; sourceTree = "<group>"; };
- F96D437808F272B6004A47F5 /* info.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = info.test; sourceTree = "<group>"; };
- F96D437908F272B6004A47F5 /* init.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = init.test; sourceTree = "<group>"; };
- F96D437A08F272B6004A47F5 /* interp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = interp.test; sourceTree = "<group>"; };
- F96D437B08F272B6004A47F5 /* io.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = io.test; sourceTree = "<group>"; };
- F96D437C08F272B6004A47F5 /* ioCmd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = ioCmd.test; sourceTree = "<group>"; };
- F96D437D08F272B6004A47F5 /* iogt.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = iogt.test; sourceTree = "<group>"; };
- F96D437F08F272B6004A47F5 /* join.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = join.test; sourceTree = "<group>"; };
- F96D438008F272B6004A47F5 /* lindex.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lindex.test; sourceTree = "<group>"; };
- F96D438108F272B6004A47F5 /* link.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = link.test; sourceTree = "<group>"; };
- F96D438208F272B6004A47F5 /* linsert.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = linsert.test; sourceTree = "<group>"; };
- F96D438308F272B6004A47F5 /* list.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = list.test; sourceTree = "<group>"; };
- F96D438408F272B6004A47F5 /* listObj.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = listObj.test; sourceTree = "<group>"; };
- F96D438508F272B6004A47F5 /* llength.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = llength.test; sourceTree = "<group>"; };
- F96D438608F272B6004A47F5 /* load.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = load.test; sourceTree = "<group>"; };
- F96D438708F272B6004A47F5 /* lrange.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lrange.test; sourceTree = "<group>"; };
- F96D438808F272B6004A47F5 /* lrepeat.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lrepeat.test; sourceTree = "<group>"; };
- F96D438908F272B6004A47F5 /* lreplace.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lreplace.test; sourceTree = "<group>"; };
- F96D438A08F272B6004A47F5 /* lsearch.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lsearch.test; sourceTree = "<group>"; };
- F96D438B08F272B6004A47F5 /* lset.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lset.test; sourceTree = "<group>"; };
- F96D438C08F272B6004A47F5 /* lsetComp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = lsetComp.test; sourceTree = "<group>"; };
- F96D438D08F272B6004A47F5 /* macOSXFCmd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = macOSXFCmd.test; sourceTree = "<group>"; };
- F96D438E08F272B6004A47F5 /* main.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = main.test; sourceTree = "<group>"; };
- F96D438F08F272B6004A47F5 /* misc.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = misc.test; sourceTree = "<group>"; };
- F96D439008F272B6004A47F5 /* msgcat.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = msgcat.test; sourceTree = "<group>"; };
- F96D439108F272B6004A47F5 /* namespace-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "namespace-old.test"; sourceTree = "<group>"; };
- F96D439208F272B7004A47F5 /* namespace.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = namespace.test; sourceTree = "<group>"; };
- F96D439308F272B7004A47F5 /* notify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = notify.test; sourceTree = "<group>"; };
- F96D439408F272B7004A47F5 /* obj.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = obj.test; sourceTree = "<group>"; };
- F96D439508F272B7004A47F5 /* opt.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = opt.test; sourceTree = "<group>"; };
- F96D439608F272B7004A47F5 /* package.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = package.test; sourceTree = "<group>"; };
- F96D439708F272B7004A47F5 /* parse.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = parse.test; sourceTree = "<group>"; };
- F96D439808F272B7004A47F5 /* parseExpr.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = parseExpr.test; sourceTree = "<group>"; };
- F96D439908F272B7004A47F5 /* parseOld.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = parseOld.test; sourceTree = "<group>"; };
- F96D439A08F272B7004A47F5 /* pid.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pid.test; sourceTree = "<group>"; };
- F96D439B08F272B7004A47F5 /* pkg.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkg.test; sourceTree = "<group>"; };
- F96D439C08F272B7004A47F5 /* pkgMkIndex.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgMkIndex.test; sourceTree = "<group>"; };
- F96D439D08F272B7004A47F5 /* platform.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.test; sourceTree = "<group>"; };
- F96D439E08F272B7004A47F5 /* proc-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "proc-old.test"; sourceTree = "<group>"; };
- F96D439F08F272B7004A47F5 /* proc.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = proc.test; sourceTree = "<group>"; };
- F96D43A008F272B7004A47F5 /* pwd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pwd.test; sourceTree = "<group>"; };
- F96D43A108F272B7004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D43A208F272B7004A47F5 /* reg.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = reg.test; sourceTree = "<group>"; };
- F96D43A308F272B7004A47F5 /* regexp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexp.test; sourceTree = "<group>"; };
- F96D43A408F272B7004A47F5 /* regexpComp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpComp.test; sourceTree = "<group>"; };
- F96D43A508F272B7004A47F5 /* registry.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = registry.test; sourceTree = "<group>"; };
- F96D43A608F272B7004A47F5 /* remote.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = remote.tcl; sourceTree = "<group>"; };
- F96D43A708F272B7004A47F5 /* rename.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = rename.test; sourceTree = "<group>"; };
- F96D43A808F272B7004A47F5 /* result.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = result.test; sourceTree = "<group>"; };
- F96D43A908F272B7004A47F5 /* safe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = safe.test; sourceTree = "<group>"; };
- F96D43AA08F272B7004A47F5 /* scan.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = scan.test; sourceTree = "<group>"; };
- F96D43AB08F272B7004A47F5 /* security.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = security.test; sourceTree = "<group>"; };
- F96D43AC08F272B7004A47F5 /* set-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "set-old.test"; sourceTree = "<group>"; };
- F96D43AD08F272B7004A47F5 /* set.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = set.test; sourceTree = "<group>"; };
- F96D43AE08F272B7004A47F5 /* socket.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = socket.test; sourceTree = "<group>"; };
- F96D43AF08F272B7004A47F5 /* source.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = source.test; sourceTree = "<group>"; };
- F96D43B008F272B7004A47F5 /* split.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = split.test; sourceTree = "<group>"; };
- F96D43B108F272B7004A47F5 /* stack.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = stack.test; sourceTree = "<group>"; };
- F96D43B208F272B7004A47F5 /* string.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = string.test; sourceTree = "<group>"; };
- F96D43B308F272B7004A47F5 /* stringComp.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = stringComp.test; sourceTree = "<group>"; };
- F96D43B408F272B7004A47F5 /* stringObj.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = stringObj.test; sourceTree = "<group>"; };
- F96D43B508F272B7004A47F5 /* subst.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = subst.test; sourceTree = "<group>"; };
- F96D43B608F272B7004A47F5 /* switch.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = switch.test; sourceTree = "<group>"; };
- F96D43B708F272B7004A47F5 /* tcltest.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tcltest.test; sourceTree = "<group>"; };
- F96D43B808F272B7004A47F5 /* thread.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = thread.test; sourceTree = "<group>"; };
- F96D43B908F272B7004A47F5 /* timer.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = timer.test; sourceTree = "<group>"; };
- F96D43BA08F272B7004A47F5 /* tm.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tm.test; sourceTree = "<group>"; };
- F96D43BB08F272B7004A47F5 /* trace.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = trace.test; sourceTree = "<group>"; };
- F96D43BC08F272B7004A47F5 /* unixFCmd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unixFCmd.test; sourceTree = "<group>"; };
- F96D43BD08F272B7004A47F5 /* unixFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unixFile.test; sourceTree = "<group>"; };
- F96D43BE08F272B7004A47F5 /* unixInit.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unixInit.test; sourceTree = "<group>"; };
- F96D43BF08F272B7004A47F5 /* unixNotfy.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unixNotfy.test; sourceTree = "<group>"; };
- F96D43C008F272B7004A47F5 /* unknown.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unknown.test; sourceTree = "<group>"; };
- F96D43C108F272B7004A47F5 /* unload.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = unload.test; sourceTree = "<group>"; };
- F96D43C208F272B7004A47F5 /* uplevel.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uplevel.test; sourceTree = "<group>"; };
- F96D43C308F272B7004A47F5 /* upvar.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = upvar.test; sourceTree = "<group>"; };
- F96D43C408F272B7004A47F5 /* utf.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = utf.test; sourceTree = "<group>"; };
- F96D43C508F272B7004A47F5 /* util.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = util.test; sourceTree = "<group>"; };
- F96D43C608F272B7004A47F5 /* var.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = var.test; sourceTree = "<group>"; };
- F96D43C708F272B7004A47F5 /* while-old.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "while-old.test"; sourceTree = "<group>"; };
- F96D43C808F272B7004A47F5 /* while.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = while.test; sourceTree = "<group>"; };
- F96D43C908F272B7004A47F5 /* winConsole.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winConsole.test; sourceTree = "<group>"; };
- F96D43CA08F272B7004A47F5 /* winDde.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winDde.test; sourceTree = "<group>"; };
- F96D43CB08F272B7004A47F5 /* winFCmd.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFCmd.test; sourceTree = "<group>"; };
- F96D43CC08F272B7004A47F5 /* winFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFile.test; sourceTree = "<group>"; };
- F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = "<group>"; };
- F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = "<group>"; };
- F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
- F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
- F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D43D308F272B8004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fix_tommath_h.tcl; sourceTree = "<group>"; };
- F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
- F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
- F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
- F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
- F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
- F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
- F96D442C08F272B8004A47F5 /* man2help.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help.tcl; sourceTree = "<group>"; };
- F96D442D08F272B8004A47F5 /* man2help2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help2.tcl; sourceTree = "<group>"; };
- F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
- F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
- F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
- F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
- F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
- F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
- F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
- F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
- F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
- F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
- F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
- F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
- F96D444408F272B9004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
- F96D444508F272B9004A47F5 /* pkga.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkga.c; sourceTree = "<group>"; };
- F96D444608F272B9004A47F5 /* pkgb.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgb.c; sourceTree = "<group>"; };
- F96D444708F272B9004A47F5 /* pkgc.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgc.c; sourceTree = "<group>"; };
- F96D444808F272B9004A47F5 /* pkgd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgd.c; sourceTree = "<group>"; };
- F96D444908F272B9004A47F5 /* pkge.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkge.c; sourceTree = "<group>"; };
- F96D444B08F272B9004A47F5 /* pkgua.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgua.c; sourceTree = "<group>"; };
- F96D444C08F272B9004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D444D08F272B9004A47F5 /* install-sh */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = "install-sh"; sourceTree = "<group>"; };
- F96D444E08F272B9004A47F5 /* installManPage */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = installManPage; sourceTree = "<group>"; };
- F96D444F08F272B9004A47F5 /* ldAix */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = ldAix; sourceTree = "<group>"; };
- F96D445008F272B9004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
- F96D445208F272B9004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D445308F272B9004A47F5 /* tcl.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tcl.m4; sourceTree = "<group>"; };
- F96D445408F272B9004A47F5 /* tcl.spec */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.spec; sourceTree = "<group>"; };
- F96D445508F272B9004A47F5 /* tclAppInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAppInit.c; sourceTree = "<group>"; };
- F96D445608F272B9004A47F5 /* tclConfig.h.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.c.h; fileEncoding = 4; path = tclConfig.h.in; sourceTree = "<group>"; };
- F96D445708F272B9004A47F5 /* tclConfig.sh.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tclConfig.sh.in; sourceTree = "<group>"; };
- F96D445808F272B9004A47F5 /* tclLoadAix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadAix.c; sourceTree = "<group>"; };
- F96D445908F272B9004A47F5 /* tclLoadDl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadDl.c; sourceTree = "<group>"; };
- F96D445B08F272B9004A47F5 /* tclLoadDyld.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadDyld.c; sourceTree = "<group>"; };
- F96D445C08F272B9004A47F5 /* tclLoadNext.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadNext.c; sourceTree = "<group>"; };
- F96D445D08F272B9004A47F5 /* tclLoadOSF.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadOSF.c; sourceTree = "<group>"; };
- F96D445E08F272B9004A47F5 /* tclLoadShl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclLoadShl.c; sourceTree = "<group>"; };
- F96D445F08F272B9004A47F5 /* tclUnixChan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixChan.c; sourceTree = "<group>"; };
- F96D446008F272B9004A47F5 /* tclUnixEvent.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixEvent.c; sourceTree = "<group>"; };
- F96D446108F272B9004A47F5 /* tclUnixFCmd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixFCmd.c; sourceTree = "<group>"; };
- F96D446208F272B9004A47F5 /* tclUnixFile.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixFile.c; sourceTree = "<group>"; };
- F96D446308F272B9004A47F5 /* tclUnixInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixInit.c; sourceTree = "<group>"; };
- F96D446408F272B9004A47F5 /* tclUnixNotfy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixNotfy.c; sourceTree = "<group>"; };
- F96D446508F272B9004A47F5 /* tclUnixPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixPipe.c; sourceTree = "<group>"; };
- F96D446608F272B9004A47F5 /* tclUnixPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixPort.h; sourceTree = "<group>"; };
- F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = "<group>"; };
- F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = "<group>"; };
- F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = "<group>"; };
- F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = "<group>"; };
- F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = "<group>"; };
- F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = "<group>"; };
- F96D447008F272BA004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
- F96D447108F272BA004A47F5 /* buildall.vc.bat */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = buildall.vc.bat; sourceTree = "<group>"; };
- F96D447208F272BA004A47F5 /* cat.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = cat.c; sourceTree = "<group>"; };
- F96D447308F272BA004A47F5 /* coffbase.txt */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = coffbase.txt; sourceTree = "<group>"; };
- F96D447408F272BA004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D447508F272BA004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
- F96D447708F272BA004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
- F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
- F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
- F96D447A08F272BA004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
- F96D447C08F272BA004A47F5 /* rules.vc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = rules.vc; sourceTree = "<group>"; };
- F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
- F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
- F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
- F96D448008F272BA004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
- F96D448108F272BA004A47F5 /* tcl.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tcl.m4; sourceTree = "<group>"; };
- F96D448208F272BA004A47F5 /* tcl.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.rc; sourceTree = "<group>"; };
- F96D448308F272BA004A47F5 /* tclAppInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAppInit.c; sourceTree = "<group>"; };
- F96D448408F272BA004A47F5 /* tclConfig.sh.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tclConfig.sh.in; sourceTree = "<group>"; };
- F96D448608F272BA004A47F5 /* tclsh.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tclsh.rc; sourceTree = "<group>"; };
- F96D448708F272BA004A47F5 /* tclWin32Dll.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWin32Dll.c; sourceTree = "<group>"; };
- F96D448808F272BA004A47F5 /* tclWinChan.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinChan.c; sourceTree = "<group>"; };
- F96D448908F272BA004A47F5 /* tclWinConsole.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinConsole.c; sourceTree = "<group>"; };
- F96D448A08F272BA004A47F5 /* tclWinDde.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinDde.c; sourceTree = "<group>"; };
- F96D448B08F272BA004A47F5 /* tclWinError.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinError.c; sourceTree = "<group>"; };
- F96D448C08F272BA004A47F5 /* tclWinFCmd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinFCmd.c; sourceTree = "<group>"; };
- F96D448D08F272BA004A47F5 /* tclWinFile.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinFile.c; sourceTree = "<group>"; };
- F96D448E08F272BA004A47F5 /* tclWinInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinInit.c; sourceTree = "<group>"; };
- F96D448F08F272BA004A47F5 /* tclWinInt.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinInt.h; sourceTree = "<group>"; };
- F96D449008F272BA004A47F5 /* tclWinLoad.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinLoad.c; sourceTree = "<group>"; };
- F96D449108F272BA004A47F5 /* tclWinNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinNotify.c; sourceTree = "<group>"; };
- F96D449208F272BA004A47F5 /* tclWinPipe.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinPipe.c; sourceTree = "<group>"; };
- F96D449308F272BA004A47F5 /* tclWinPort.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclWinPort.h; sourceTree = "<group>"; };
- F96D449408F272BA004A47F5 /* tclWinReg.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinReg.c; sourceTree = "<group>"; };
- F96D449508F272BA004A47F5 /* tclWinSerial.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSerial.c; sourceTree = "<group>"; };
- F96D449608F272BA004A47F5 /* tclWinSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinSock.c; sourceTree = "<group>"; };
- F96D449708F272BA004A47F5 /* tclWinTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTest.c; sourceTree = "<group>"; };
- F96D449808F272BA004A47F5 /* tclWinThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinThrd.c; sourceTree = "<group>"; };
- F96D449A08F272BA004A47F5 /* tclWinTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclWinTime.c; sourceTree = "<group>"; };
- F974D56C0FBE7D6300BF728B /* http11.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http11.test; sourceTree = "<group>"; };
- F974D56D0FBE7D6300BF728B /* httpd11.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = httpd11.tcl; sourceTree = "<group>"; };
- F974D5720FBE7DC600BF728B /* coroutine.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = coroutine.n; sourceTree = "<group>"; };
- F974D5760FBE7E1900BF728B /* tailcall.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = tailcall.n; sourceTree = "<group>"; };
- F974D5770FBE7E6100BF728B /* coroutine.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = coroutine.test; sourceTree = "<group>"; };
- F974D5780FBE7E6100BF728B /* tailcall.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tailcall.test; sourceTree = "<group>"; };
- F974D5790FBE7E9C00BF728B /* tcl.pc.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.pc.in; sourceTree = "<group>"; };
- F97AE7F10B65C1E900310EA2 /* Tcl-Common.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Tcl-Common.xcconfig"; sourceTree = "<group>"; };
- F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Tcl-Release.xcconfig"; sourceTree = "<group>"; };
- F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xcconfig; path = "Tcl-Debug.xcconfig"; sourceTree = "<group>"; };
- F9903CAF094FAADA004613E9 /* tclTomMath.decls */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclTomMath.decls; sourceTree = "<group>"; };
- F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = "<group>"; };
- F99D61180EF5573A00BBFE01 /* TclZlib.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = TclZlib.3; sourceTree = "<group>"; };
- F9A3084B08F2D4CE00BAE1AB /* tclsh */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tclsh; sourceTree = BUILT_PRODUCTS_DIR; };
- F9A3084E08F2D4F400BAE1AB /* Tcl.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tcl.framework; sourceTree = BUILT_PRODUCTS_DIR; };
- F9A493240CEBF38300B78AE2 /* chanio.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chanio.test; sourceTree = "<group>"; };
- F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
- F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = "<group>"; };
- F9ECB1140B26521500A28025 /* shell.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = shell.tcl; sourceTree = "<group>"; };
- F9ECB1CA0B2652D300A28025 /* apply.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = apply.test; sourceTree = "<group>"; };
- F9ECB1CB0B26534C00A28025 /* mathop.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = mathop.test; sourceTree = "<group>"; };
- F9ECB1E10B26543C00A28025 /* platform_shell.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = platform_shell.n; sourceTree = "<group>"; };
- F9ECB1E20B26543C00A28025 /* platform.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = platform.n; sourceTree = "<group>"; };
- F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.dtrace; path = tclDTrace.d; sourceTree = "<group>"; };
- F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixCompat.c; sourceTree = "<group>"; };
-/* End PBXFileReference section */
-
-/* Begin PBXFrameworksBuildPhase section */
- 8DD76FAD0486AB0100D96B5E /* Frameworks */ = {
- isa = PBXFrameworksBuildPhase;
- buildActionMask = 2147483647;
- files = (
- F966C07508F2820D005CB29B /* CoreFoundation.framework in Frameworks */,
- F96437E70EF0D652003F468E /* libz.dylib in Frameworks */,
- );
- runOnlyForDeploymentPostprocessing = 0;
- };
-/* End PBXFrameworksBuildPhase section */
-
-/* Begin PBXGroup section */
- 08FB7794FE84155DC02AAC07 /* Tcl */ = {
- isa = PBXGroup;
- children = (
- F96D3DF608F27169004A47F5 /* Tcl Sources */,
- F966C06F08F281DC005CB29B /* Frameworks */,
- 1AB674ADFE9D54B511CA2CBB /* Products */,
- );
- comments = "Copyright (c) 2004-2009 Daniel A. Steffen <das@users.sourceforge.net>\nCopyright 2008-2009, Apple Inc.\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\n";
- name = Tcl;
- path = .;
- sourceTree = SOURCE_ROOT;
- };
- 1AB674ADFE9D54B511CA2CBB /* Products */ = {
- isa = PBXGroup;
- children = (
- F9A3084B08F2D4CE00BAE1AB /* tclsh */,
- 8DD76FB20486AB0100D96B5E /* tcltest */,
- F9A3084E08F2D4F400BAE1AB /* Tcl.framework */,
- );
- includeInIndex = 0;
- name = Products;
- sourceTree = "<group>";
- };
- F9183E690EFC81560030B814 /* pkgs */ = {
- isa = PBXGroup;
- children = (
- F9183E6A0EFC81560030B814 /* README */,
- F946FB8B0FBE3AED00CD6495 /* itcl */,
- F9183E8F0EFC817B0030B814 /* tdbc */,
- );
- path = pkgs;
- sourceTree = "<group>";
- };
- F966C06F08F281DC005CB29B /* Frameworks */ = {
- isa = PBXGroup;
- children = (
- F966C07408F2820D005CB29B /* CoreFoundation.framework */,
- F96437E60EF0D652003F468E /* libz.dylib */,
- );
- name = Frameworks;
- sourceTree = "<group>";
- };
- F96D3DF608F27169004A47F5 /* Tcl Sources */ = {
- isa = PBXGroup;
- children = (
- F96D3EC908F272A7004A47F5 /* generic */,
- F96D432C08F272B4004A47F5 /* macosx */,
- F96D443E08F272B9004A47F5 /* unix */,
- F96D425C08F272B2004A47F5 /* libtommath */,
- F96D446E08F272B9004A47F5 /* win */,
- F96D3F3808F272A7004A47F5 /* library */,
- F96D434408F272B5004A47F5 /* tests */,
- F96D3DFC08F272A4004A47F5 /* doc */,
- F96D43D008F272B8004A47F5 /* tools */,
- F9183E690EFC81560030B814 /* pkgs */,
- F96D3DFA08F272A4004A47F5 /* ChangeLog */,
- F96D3DFB08F272A4004A47F5 /* changes */,
- F96D434308F272B5004A47F5 /* README */,
- F96D432B08F272B4004A47F5 /* license.terms */,
- );
- name = "Tcl Sources";
- sourceTree = TCL_SRCROOT;
- };
- F96D3DFC08F272A4004A47F5 /* doc */ = {
- isa = PBXGroup;
- children = (
- F96D3DFD08F272A4004A47F5 /* Access.3 */,
- F96D3DFE08F272A4004A47F5 /* AddErrInfo.3 */,
- F96D3DFF08F272A4004A47F5 /* after.n */,
- F96D3E0008F272A4004A47F5 /* Alloc.3 */,
- F96D3E0108F272A4004A47F5 /* AllowExc.3 */,
- F96D3E0208F272A4004A47F5 /* append.n */,
- F96D3E0308F272A4004A47F5 /* AppInit.3 */,
- F96D3E0408F272A5004A47F5 /* array.n */,
- F96D3E0508F272A5004A47F5 /* AssocData.3 */,
- F96D3E0608F272A5004A47F5 /* Async.3 */,
- F96D3E0708F272A5004A47F5 /* BackgdErr.3 */,
- F96D3E0808F272A5004A47F5 /* Backslash.3 */,
- F96D3E0908F272A5004A47F5 /* bgerror.n */,
- F96D3E0A08F272A5004A47F5 /* binary.n */,
- F96D3E0B08F272A5004A47F5 /* BoolObj.3 */,
- F96D3E0C08F272A5004A47F5 /* break.n */,
- F96D3E0D08F272A5004A47F5 /* ByteArrObj.3 */,
- F96D3E0E08F272A5004A47F5 /* CallDel.3 */,
- F96D3E0F08F272A5004A47F5 /* case.n */,
- F96D3E1008F272A5004A47F5 /* catch.n */,
- F96D3E1108F272A5004A47F5 /* cd.n */,
- F96D3E1208F272A5004A47F5 /* chan.n */,
- F96D3E1308F272A5004A47F5 /* ChnlStack.3 */,
- F93599CF0DF1F87F00E04F67 /* Class.3 */,
- F93599D00DF1F89E00E04F67 /* class.n */,
- F96D3E1408F272A5004A47F5 /* clock.n */,
- F96D3E1508F272A5004A47F5 /* close.n */,
- F96D3E1608F272A5004A47F5 /* CmdCmplt.3 */,
- F96D3E1708F272A5004A47F5 /* Concat.3 */,
- F96D3E1808F272A5004A47F5 /* concat.n */,
- F96D3E1908F272A5004A47F5 /* continue.n */,
- F93599D20DF1F8DF00E04F67 /* copy.n */,
- F974D5720FBE7DC600BF728B /* coroutine.n */,
- F96D3E1A08F272A5004A47F5 /* CrtChannel.3 */,
- F96D3E1B08F272A5004A47F5 /* CrtChnlHdlr.3 */,
- F96D3E1C08F272A5004A47F5 /* CrtCloseHdlr.3 */,
- F96D3E1D08F272A5004A47F5 /* CrtCommand.3 */,
- F96D3E1E08F272A5004A47F5 /* CrtFileHdlr.3 */,
- F96D3E1F08F272A5004A47F5 /* CrtInterp.3 */,
- F96D3E2008F272A5004A47F5 /* CrtMathFnc.3 */,
- F96D3E2108F272A5004A47F5 /* CrtObjCmd.3 */,
- F96D3E2208F272A5004A47F5 /* CrtAlias.3 */,
- F96D3E2308F272A5004A47F5 /* CrtTimerHdlr.3 */,
- F96D3E2408F272A5004A47F5 /* CrtTrace.3 */,
- F96D3E2508F272A5004A47F5 /* dde.n */,
- F93599D30DF1F8F500E04F67 /* define.n */,
- F96D3E2608F272A5004A47F5 /* DetachPids.3 */,
- F96D3E2708F272A5004A47F5 /* dict.n */,
- F96D3E2808F272A5004A47F5 /* DictObj.3 */,
- F96D3E2908F272A5004A47F5 /* DoOneEvent.3 */,
- F96D3E2A08F272A5004A47F5 /* DoubleObj.3 */,
- F96D3E2B08F272A5004A47F5 /* DoWhenIdle.3 */,
- F96D3E2C08F272A5004A47F5 /* DString.3 */,
- F96D3E2D08F272A5004A47F5 /* DumpActiveMemory.3 */,
- F96D3E2E08F272A5004A47F5 /* Encoding.3 */,
- F96D3E2F08F272A5004A47F5 /* encoding.n */,
- F96D3E3008F272A5004A47F5 /* Ensemble.3 */,
- F96D3E3108F272A5004A47F5 /* Environment.3 */,
- F96D3E3208F272A5004A47F5 /* eof.n */,
- F96D3E3308F272A5004A47F5 /* error.n */,
- F96D3E3408F272A5004A47F5 /* Eval.3 */,
- F96D3E3508F272A5004A47F5 /* eval.n */,
- F96D3E3608F272A5004A47F5 /* exec.n */,
- F96D3E3708F272A5004A47F5 /* Exit.3 */,
- F96D3E3808F272A5004A47F5 /* exit.n */,
- F96D3E3908F272A5004A47F5 /* expr.n */,
- F96D3E3A08F272A5004A47F5 /* ExprLong.3 */,
- F96D3E3B08F272A5004A47F5 /* ExprLongObj.3 */,
- F96D3E3C08F272A5004A47F5 /* fblocked.n */,
- F96D3E3D08F272A5004A47F5 /* fconfigure.n */,
- F96D3E3E08F272A5004A47F5 /* fcopy.n */,
- F96D3E3F08F272A5004A47F5 /* file.n */,
- F96D3E4008F272A5004A47F5 /* fileevent.n */,
- F96D3E4108F272A5004A47F5 /* filename.n */,
- F96D3E4208F272A5004A47F5 /* FileSystem.3 */,
- F96D3E4308F272A5004A47F5 /* FindExec.3 */,
- F96D3E4408F272A5004A47F5 /* flush.n */,
- F96D3E4508F272A5004A47F5 /* for.n */,
- F96D3E4608F272A5004A47F5 /* foreach.n */,
- F96D3E4708F272A5004A47F5 /* format.n */,
- F96D3E4808F272A5004A47F5 /* GetCwd.3 */,
- F96D3E4908F272A5004A47F5 /* GetHostName.3 */,
- F96D3E4A08F272A5004A47F5 /* GetIndex.3 */,
- F96D3E4B08F272A5004A47F5 /* GetInt.3 */,
- F96D3E4C08F272A5004A47F5 /* GetOpnFl.3 */,
- F96D3E4D08F272A5004A47F5 /* gets.n */,
- F96D3E4E08F272A5004A47F5 /* GetStdChan.3 */,
- F96D3E4F08F272A5004A47F5 /* GetTime.3 */,
- F96D3E5008F272A5004A47F5 /* GetVersion.3 */,
- F96D3E5108F272A5004A47F5 /* glob.n */,
- F96D3E5208F272A6004A47F5 /* global.n */,
- F96D3E5308F272A6004A47F5 /* Hash.3 */,
- F96D3E5408F272A6004A47F5 /* history.n */,
- F96D3E5508F272A6004A47F5 /* http.n */,
- F96D3E5608F272A6004A47F5 /* if.n */,
- F96D3E5708F272A6004A47F5 /* incr.n */,
- F96D3E5808F272A6004A47F5 /* info.n */,
- F96D3E5908F272A6004A47F5 /* Init.3 */,
- F96D3E5A08F272A6004A47F5 /* InitStubs.3 */,
- F96D3E5B08F272A6004A47F5 /* Interp.3 */,
- F96D3E5C08F272A6004A47F5 /* interp.n */,
- F96D3E5D08F272A6004A47F5 /* IntObj.3 */,
- F96D3E5E08F272A6004A47F5 /* join.n */,
- F96D3E5F08F272A6004A47F5 /* lappend.n */,
- F96D3E6008F272A6004A47F5 /* lassign.n */,
- F96D3E6108F272A6004A47F5 /* library.n */,
- F96D3E6208F272A6004A47F5 /* Limit.3 */,
- F96D3E6308F272A6004A47F5 /* lindex.n */,
- F96D3E6408F272A6004A47F5 /* LinkVar.3 */,
- F96D3E6508F272A6004A47F5 /* linsert.n */,
- F96D3E6608F272A6004A47F5 /* list.n */,
- F96D3E6708F272A6004A47F5 /* ListObj.3 */,
- F96D3E6808F272A6004A47F5 /* llength.n */,
- F96D3E6908F272A6004A47F5 /* load.n */,
- F96D3E6A08F272A6004A47F5 /* lrange.n */,
- F96D3E6B08F272A6004A47F5 /* lrepeat.n */,
- F96D3E6C08F272A6004A47F5 /* lreplace.n */,
- F96D3E6D08F272A6004A47F5 /* lsearch.n */,
- F96D3E6E08F272A6004A47F5 /* lset.n */,
- F96D3E6F08F272A6004A47F5 /* lsort.n */,
- F96D3E7008F272A6004A47F5 /* man.macros */,
- F96D3E7108F272A6004A47F5 /* mathfunc.n */,
- F96D3E7208F272A6004A47F5 /* memory.n */,
- F93599D40DF1F91900E04F67 /* Method.3 */,
- F96D3E7308F272A6004A47F5 /* msgcat.n */,
- F93599D50DF1F93700E04F67 /* my.n */,
- F96D3E7408F272A6004A47F5 /* Namespace.3 */,
- F96D3E7508F272A6004A47F5 /* namespace.n */,
- F93599D60DF1F95000E04F67 /* next.n */,
- F96D3E7608F272A6004A47F5 /* Notifier.3 */,
- F96D3E7708F272A6004A47F5 /* Object.3 */,
- F93599D70DF1F96800E04F67 /* object.n */,
- F96D3E7808F272A6004A47F5 /* ObjectType.3 */,
- F96D3E7908F272A6004A47F5 /* open.n */,
- F96D3E7A08F272A6004A47F5 /* OpenFileChnl.3 */,
- F96D3E7B08F272A6004A47F5 /* OpenTcp.3 */,
- F96D3E7C08F272A6004A47F5 /* package.n */,
- F96D3E7D08F272A6004A47F5 /* packagens.n */,
- F96D3E7E08F272A6004A47F5 /* Panic.3 */,
- F96D3E7F08F272A6004A47F5 /* ParseCmd.3 */,
- F96D3E8008F272A6004A47F5 /* pid.n */,
- F96D3E8108F272A6004A47F5 /* pkgMkIndex.n */,
- F96D3E8208F272A6004A47F5 /* PkgRequire.3 */,
- F9ECB1E10B26543C00A28025 /* platform_shell.n */,
- F9ECB1E20B26543C00A28025 /* platform.n */,
- F96D3E8308F272A6004A47F5 /* Preserve.3 */,
- F96D3E8408F272A6004A47F5 /* PrintDbl.3 */,
- F96D3E8508F272A6004A47F5 /* proc.n */,
- F96D3E8608F272A6004A47F5 /* puts.n */,
- F96D3E8708F272A6004A47F5 /* pwd.n */,
- F96D3E8808F272A6004A47F5 /* re_syntax.n */,
- F96D3E8908F272A6004A47F5 /* read.n */,
- F96D3E8A08F272A6004A47F5 /* RecEvalObj.3 */,
- F96D3E8B08F272A6004A47F5 /* RecordEval.3 */,
- F96D3E8C08F272A6004A47F5 /* RegConfig.3 */,
- F96D3E8D08F272A6004A47F5 /* RegExp.3 */,
- F96D3E8E08F272A6004A47F5 /* regexp.n */,
- F96D3E8F08F272A6004A47F5 /* registry.n */,
- F96D3E9008F272A6004A47F5 /* regsub.n */,
- F96D3E9108F272A6004A47F5 /* rename.n */,
- F96D3E9208F272A6004A47F5 /* return.n */,
- F96D3E9308F272A6004A47F5 /* safe.n */,
- F96D3E9408F272A6004A47F5 /* SaveResult.3 */,
- F96D3E9508F272A6004A47F5 /* scan.n */,
- F96D3E9608F272A6004A47F5 /* seek.n */,
- F93599D80DF1F98300E04F67 /* self.n */,
- F96D3E9708F272A6004A47F5 /* set.n */,
- F96D3E9808F272A6004A47F5 /* SetChanErr.3 */,
- F96D3E9908F272A6004A47F5 /* SetErrno.3 */,
- F96D3E9A08F272A6004A47F5 /* SetRecLmt.3 */,
- F96D3E9B08F272A7004A47F5 /* SetResult.3 */,
- F96D3E9C08F272A7004A47F5 /* SetVar.3 */,
- F96D3E9D08F272A7004A47F5 /* Signal.3 */,
- F96D3E9E08F272A7004A47F5 /* Sleep.3 */,
- F96D3E9F08F272A7004A47F5 /* socket.n */,
- F96D3EA008F272A7004A47F5 /* source.n */,
- F96D3EA108F272A7004A47F5 /* SourceRCFile.3 */,
- F96D3EA208F272A7004A47F5 /* split.n */,
- F96D3EA308F272A7004A47F5 /* SplitList.3 */,
- F96D3EA408F272A7004A47F5 /* SplitPath.3 */,
- F96D3EA508F272A7004A47F5 /* StaticPkg.3 */,
- F96D3EA608F272A7004A47F5 /* StdChannels.3 */,
- F96D3EA708F272A7004A47F5 /* string.n */,
- F96D3EA808F272A7004A47F5 /* StringObj.3 */,
- F96D3EA908F272A7004A47F5 /* StrMatch.3 */,
- F96D3EAA08F272A7004A47F5 /* subst.n */,
- F96D3EAB08F272A7004A47F5 /* SubstObj.3 */,
- F96D3EAC08F272A7004A47F5 /* switch.n */,
- F974D5760FBE7E1900BF728B /* tailcall.n */,
- F96D3EAD08F272A7004A47F5 /* Tcl.n */,
- F99D61180EF5573A00BBFE01 /* TclZlib.3 */,
- F96D3EAE08F272A7004A47F5 /* Tcl_Main.3 */,
- F96D3EAF08F272A7004A47F5 /* TCL_MEM_DEBUG.3 */,
- F96D3EB008F272A7004A47F5 /* tclsh.1 */,
- F96D3EB108F272A7004A47F5 /* tcltest.n */,
- F96D3EB208F272A7004A47F5 /* tclvars.n */,
- F96D3EB308F272A7004A47F5 /* tell.n */,
- F96D3EB408F272A7004A47F5 /* Thread.3 */,
- F9183E640EFC80CD0030B814 /* throw.n */,
- F96D3EB508F272A7004A47F5 /* time.n */,
- F96D3EB608F272A7004A47F5 /* tm.n */,
- F96D3EB708F272A7004A47F5 /* ToUpper.3 */,
- F96D3EB808F272A7004A47F5 /* trace.n */,
- F96D3EB908F272A7004A47F5 /* TraceCmd.3 */,
- F96D3EBA08F272A7004A47F5 /* TraceVar.3 */,
- F96D3EBB08F272A7004A47F5 /* Translate.3 */,
- F9183E650EFC80D70030B814 /* try.n */,
- F96D3EBC08F272A7004A47F5 /* UniCharIsAlpha.3 */,
- F96D3EBD08F272A7004A47F5 /* unknown.n */,
- F96D3EBE08F272A7004A47F5 /* unload.n */,
- F96D3EBF08F272A7004A47F5 /* unset.n */,
- F96D3EC008F272A7004A47F5 /* update.n */,
- F96D3EC108F272A7004A47F5 /* uplevel.n */,
- F96D3EC208F272A7004A47F5 /* UpVar.3 */,
- F96D3EC308F272A7004A47F5 /* upvar.n */,
- F96D3EC408F272A7004A47F5 /* Utf.3 */,
- F96D3EC508F272A7004A47F5 /* variable.n */,
- F96D3EC608F272A7004A47F5 /* vwait.n */,
- F96D3EC708F272A7004A47F5 /* while.n */,
- F96D3EC808F272A7004A47F5 /* WrongNumArgs.3 */,
- F915432D0EF201EE0032D1E8 /* zlib.n */,
- );
- path = doc;
- sourceTree = "<group>";
- };
- F96D3EC908F272A7004A47F5 /* generic */ = {
- isa = PBXGroup;
- children = (
- F96D3ECA08F272A7004A47F5 /* README */,
- F96D3ECB08F272A7004A47F5 /* regc_color.c */,
- F96D3ECC08F272A7004A47F5 /* regc_cvec.c */,
- F96D3ECD08F272A7004A47F5 /* regc_lex.c */,
- F96D3ECE08F272A7004A47F5 /* regc_locale.c */,
- F96D3ECF08F272A7004A47F5 /* regc_nfa.c */,
- F96D3ED008F272A7004A47F5 /* regcomp.c */,
- F96D3ED108F272A7004A47F5 /* regcustom.h */,
- F96D3ED208F272A7004A47F5 /* rege_dfa.c */,
- F96D3ED308F272A7004A47F5 /* regerror.c */,
- F96D3ED408F272A7004A47F5 /* regerrs.h */,
- F96D3ED508F272A7004A47F5 /* regex.h */,
- F96D3ED608F272A7004A47F5 /* regexec.c */,
- F96D3ED708F272A7004A47F5 /* regfree.c */,
- F96D3ED808F272A7004A47F5 /* regfronts.c */,
- F96D3ED908F272A7004A47F5 /* regguts.h */,
- F96D3EDA08F272A7004A47F5 /* tcl.decls */,
- F96D3EDB08F272A7004A47F5 /* tcl.h */,
- F96D3EDC08F272A7004A47F5 /* tclAlloc.c */,
- F96D3EDD08F272A7004A47F5 /* tclAsync.c */,
- F96D3EDE08F272A7004A47F5 /* tclBasic.c */,
- F96D3EDF08F272A7004A47F5 /* tclBinary.c */,
- F96D3EE008F272A7004A47F5 /* tclCkalloc.c */,
- F96D3EE108F272A7004A47F5 /* tclClock.c */,
- F96D3EE208F272A7004A47F5 /* tclCmdAH.c */,
- F96D3EE308F272A7004A47F5 /* tclCmdIL.c */,
- F96D3EE408F272A7004A47F5 /* tclCmdMZ.c */,
- F96D3EE508F272A7004A47F5 /* tclCompCmds.c */,
- F96D3EE608F272A7004A47F5 /* tclCompExpr.c */,
- F96D3EE708F272A7004A47F5 /* tclCompile.c */,
- F96D3EE808F272A7004A47F5 /* tclCompile.h */,
- F96D3EE908F272A7004A47F5 /* tclConfig.c */,
- F96D3EEA08F272A7004A47F5 /* tclDate.c */,
- F96D3EEB08F272A7004A47F5 /* tclDecls.h */,
- F96D3EEC08F272A7004A47F5 /* tclDictObj.c */,
- F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */,
- F96D3EED08F272A7004A47F5 /* tclEncoding.c */,
- F96D3EEE08F272A7004A47F5 /* tclEnv.c */,
- F96D3EEF08F272A7004A47F5 /* tclEvent.c */,
- F96D3EF008F272A7004A47F5 /* tclExecute.c */,
- F96D3EF108F272A7004A47F5 /* tclFCmd.c */,
- F96D3EF208F272A7004A47F5 /* tclFileName.c */,
- F96D3EF308F272A7004A47F5 /* tclFileSystem.h */,
- F96D3EF408F272A7004A47F5 /* tclGet.c */,
- F96D3EF508F272A7004A47F5 /* tclGetDate.y */,
- F96D3EF608F272A7004A47F5 /* tclHash.c */,
- F96D3EF708F272A7004A47F5 /* tclHistory.c */,
- F96D3EF808F272A7004A47F5 /* tclIndexObj.c */,
- F96D3EF908F272A7004A47F5 /* tclInt.decls */,
- F96D3EFA08F272A7004A47F5 /* tclInt.h */,
- F96D3EFB08F272A7004A47F5 /* tclIntDecls.h */,
- F96D3EFC08F272A7004A47F5 /* tclInterp.c */,
- F96D3EFD08F272A7004A47F5 /* tclIntPlatDecls.h */,
- F96D3EFE08F272A7004A47F5 /* tclIO.c */,
- F96D3EFF08F272A7004A47F5 /* tclIO.h */,
- F96D3F0008F272A7004A47F5 /* tclIOCmd.c */,
- F96D3F0108F272A7004A47F5 /* tclIOGT.c */,
- F96D3F0208F272A7004A47F5 /* tclIORChan.c */,
- F95D77E90DFD820D00A8BF6F /* tclIORTrans.c */,
- F96D3F0308F272A7004A47F5 /* tclIOSock.c */,
- F96D3F0408F272A7004A47F5 /* tclIOUtil.c */,
- F96D3F0508F272A7004A47F5 /* tclLink.c */,
- F96D3F0608F272A7004A47F5 /* tclListObj.c */,
- F96D3F0708F272A7004A47F5 /* tclLiteral.c */,
- F96D3F0808F272A7004A47F5 /* tclLoad.c */,
- F96D3F0908F272A7004A47F5 /* tclLoadNone.c */,
- F96D3F0A08F272A7004A47F5 /* tclMain.c */,
- F96D3F0B08F272A7004A47F5 /* tclNamesp.c */,
- F96D3F0C08F272A7004A47F5 /* tclNotify.c */,
- F96D3F0D08F272A7004A47F5 /* tclObj.c */,
- F93599B20DF1F75400E04F67 /* tclOO.c */,
- F93599B40DF1F75900E04F67 /* tclOO.decls */,
- F93599B50DF1F75D00E04F67 /* tclOO.h */,
- F93599B60DF1F76100E04F67 /* tclOOBasic.c */,
- F93599B80DF1F76600E04F67 /* tclOOCall.c */,
- F93599BA0DF1F76A00E04F67 /* tclOODecls.h */,
- F93599BB0DF1F77000E04F67 /* tclOODefineCmds.c */,
- F93599BD0DF1F77400E04F67 /* tclOOInfo.c */,
- F93599BF0DF1F77900E04F67 /* tclOOInt.h */,
- F93599C00DF1F77D00E04F67 /* tclOOIntDecls.h */,
- F93599C10DF1F78300E04F67 /* tclOOMethod.c */,
- F93599C30DF1F78800E04F67 /* tclOOStubInit.c */,
- F93599C50DF1F78D00E04F67 /* tclOOStubLib.c */,
- F96D3F0E08F272A7004A47F5 /* tclPanic.c */,
- F96D3F0F08F272A7004A47F5 /* tclParse.c */,
- F96D3F1108F272A7004A47F5 /* tclPathObj.c */,
- F96D3F1208F272A7004A47F5 /* tclPipe.c */,
- F96D3F1308F272A7004A47F5 /* tclPkg.c */,
- F96D3F1408F272A7004A47F5 /* tclPkgConfig.c */,
- F96D3F1508F272A7004A47F5 /* tclPlatDecls.h */,
- F96D3F1608F272A7004A47F5 /* tclPort.h */,
- F96D3F1708F272A7004A47F5 /* tclPosixStr.c */,
- F96D3F1808F272A7004A47F5 /* tclPreserve.c */,
- F96D3F1908F272A7004A47F5 /* tclProc.c */,
- F96D3F1A08F272A7004A47F5 /* tclRegexp.c */,
- F96D3F1B08F272A7004A47F5 /* tclRegexp.h */,
- F96D3F1C08F272A7004A47F5 /* tclResolve.c */,
- F96D3F1D08F272A7004A47F5 /* tclResult.c */,
- F96D3F1E08F272A7004A47F5 /* tclScan.c */,
- F96D3F1F08F272A7004A47F5 /* tclStringObj.c */,
- F96D3F2408F272A7004A47F5 /* tclStrToD.c */,
- F96D3F2508F272A7004A47F5 /* tclStubInit.c */,
- F96D3F2608F272A7004A47F5 /* tclStubLib.c */,
- F96D3F2708F272A7004A47F5 /* tclTest.c */,
- F96D3F2808F272A7004A47F5 /* tclTestObj.c */,
- F96D3F2908F272A7004A47F5 /* tclTestProcBodyObj.c */,
- F96D3F2A08F272A7004A47F5 /* tclThread.c */,
- F96D3F2B08F272A7004A47F5 /* tclThreadAlloc.c */,
- F96D3F2C08F272A7004A47F5 /* tclThreadJoin.c */,
- F96D3F2D08F272A7004A47F5 /* tclThreadStorage.c */,
- F96D3F2E08F272A7004A47F5 /* tclThreadTest.c */,
- F96D3F2F08F272A7004A47F5 /* tclTimer.c */,
- F9903CAF094FAADA004613E9 /* tclTomMath.decls */,
- F96D3F3008F272A7004A47F5 /* tclTomMath.h */,
- F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */,
- F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */,
- F96D3F3208F272A7004A47F5 /* tclTrace.c */,
- F96D3F3308F272A7004A47F5 /* tclUniData.c */,
- F96D3F3408F272A7004A47F5 /* tclUtf.c */,
- F96D3F3508F272A7004A47F5 /* tclUtil.c */,
- F96D3F3608F272A7004A47F5 /* tclVar.c */,
- F96437C90EF0D4B2003F468E /* tclZlib.c */,
- F96D3F3708F272A7004A47F5 /* tommath.h */,
- );
- path = generic;
- sourceTree = "<group>";
- };
- F96D3F3808F272A7004A47F5 /* library */ = {
- isa = PBXGroup;
- children = (
- F96D3F3908F272A8004A47F5 /* auto.tcl */,
- F96D3F3A08F272A8004A47F5 /* clock.tcl */,
- F96D3F3B08F272A8004A47F5 /* dde */,
- F96D3F8C08F272A8004A47F5 /* history.tcl */,
- F96D3F8D08F272A8004A47F5 /* http */,
- F96D3F9008F272A8004A47F5 /* http1.0 */,
- F96D3F9308F272A8004A47F5 /* init.tcl */,
- F96D3F9408F272A8004A47F5 /* msgcat */,
- F96D401708F272AA004A47F5 /* opt */,
- F96D401A08F272AA004A47F5 /* package.tcl */,
- F96D401B08F272AA004A47F5 /* parray.tcl */,
- F9ECB1110B26521500A28025 /* platform */,
- F96D401C08F272AA004A47F5 /* reg */,
- F96D401E08F272AA004A47F5 /* safe.tcl */,
- F96D401F08F272AA004A47F5 /* tclIndex */,
- F96D402008F272AA004A47F5 /* tcltest */,
- F96D402308F272AA004A47F5 /* tm.tcl */,
- F96D425B08F272B2004A47F5 /* word.tcl */,
- );
- path = library;
- sourceTree = "<group>";
- };
- F96D3F3B08F272A8004A47F5 /* dde */ = {
- isa = PBXGroup;
- children = (
- F96D3F3C08F272A8004A47F5 /* pkgIndex.tcl */,
- );
- path = dde;
- sourceTree = "<group>";
- };
- F96D3F8D08F272A8004A47F5 /* http */ = {
- isa = PBXGroup;
- children = (
- F96D3F8E08F272A8004A47F5 /* http.tcl */,
- F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
- );
- path = http;
- sourceTree = "<group>";
- };
- F96D3F9008F272A8004A47F5 /* http1.0 */ = {
- isa = PBXGroup;
- children = (
- F96D3F9108F272A8004A47F5 /* http.tcl */,
- F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */,
- );
- path = http1.0;
- sourceTree = "<group>";
- };
- F96D3F9408F272A8004A47F5 /* msgcat */ = {
- isa = PBXGroup;
- children = (
- F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
- F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
- );
- path = msgcat;
- sourceTree = "<group>";
- };
- F96D401708F272AA004A47F5 /* opt */ = {
- isa = PBXGroup;
- children = (
- F96D401808F272AA004A47F5 /* optparse.tcl */,
- F96D401908F272AA004A47F5 /* pkgIndex.tcl */,
- );
- path = opt;
- sourceTree = "<group>";
- };
- F96D401C08F272AA004A47F5 /* reg */ = {
- isa = PBXGroup;
- children = (
- F96D401D08F272AA004A47F5 /* pkgIndex.tcl */,
- );
- path = reg;
- sourceTree = "<group>";
- };
- F96D402008F272AA004A47F5 /* tcltest */ = {
- isa = PBXGroup;
- children = (
- F96D402108F272AA004A47F5 /* pkgIndex.tcl */,
- F96D402208F272AA004A47F5 /* tcltest.tcl */,
- );
- path = tcltest;
- sourceTree = "<group>";
- };
- F96D425C08F272B2004A47F5 /* libtommath */ = {
- isa = PBXGroup;
- children = (
- F96D426408F272B3004A47F5 /* bn_fast_s_mp_mul_digs.c */,
- F96D426608F272B3004A47F5 /* bn_fast_s_mp_sqr.c */,
- F96D426908F272B3004A47F5 /* bn_mp_add.c */,
- F96D426A08F272B3004A47F5 /* bn_mp_add_d.c */,
- F96D426C08F272B3004A47F5 /* bn_mp_and.c */,
- F96D426D08F272B3004A47F5 /* bn_mp_clamp.c */,
- F96D426E08F272B3004A47F5 /* bn_mp_clear.c */,
- F96D426F08F272B3004A47F5 /* bn_mp_clear_multi.c */,
- F96D427008F272B3004A47F5 /* bn_mp_cmp.c */,
- F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */,
- F96D427208F272B3004A47F5 /* bn_mp_cmp_mag.c */,
- F96D427408F272B3004A47F5 /* bn_mp_copy.c */,
- F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */,
- F96D427608F272B3004A47F5 /* bn_mp_div.c */,
- F96D427708F272B3004A47F5 /* bn_mp_div_2.c */,
- F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */,
- F96D427908F272B3004A47F5 /* bn_mp_div_3.c */,
- F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */,
- F96D427E08F272B3004A47F5 /* bn_mp_exch.c */,
- F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */,
- F96D428708F272B3004A47F5 /* bn_mp_grow.c */,
- F96D428808F272B3004A47F5 /* bn_mp_init.c */,
- F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */,
- F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */,
- F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */,
- F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */,
- F96D429208F272B3004A47F5 /* bn_mp_karatsuba_mul.c */,
- F96D429308F272B3004A47F5 /* bn_mp_karatsuba_sqr.c */,
- F96D429508F272B3004A47F5 /* bn_mp_lshd.c */,
- F96D429608F272B3004A47F5 /* bn_mp_mod.c */,
- F96D429708F272B3004A47F5 /* bn_mp_mod_2d.c */,
- F96D429C08F272B3004A47F5 /* bn_mp_mul.c */,
- F96D429D08F272B3004A47F5 /* bn_mp_mul_2.c */,
- F96D429E08F272B3004A47F5 /* bn_mp_mul_2d.c */,
- F96D429F08F272B3004A47F5 /* bn_mp_mul_d.c */,
- F96D42A208F272B3004A47F5 /* bn_mp_neg.c */,
- F96D42A308F272B3004A47F5 /* bn_mp_or.c */,
- F96D42AB08F272B3004A47F5 /* bn_mp_radix_size.c */,
- F96D42AC08F272B3004A47F5 /* bn_mp_radix_smap.c */,
- F96D42AE08F272B3004A47F5 /* bn_mp_read_radix.c */,
- F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */,
- F96D42BA08F272B3004A47F5 /* bn_mp_set.c */,
- F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */,
- F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */,
- F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */,
- F96D42C108F272B3004A47F5 /* bn_mp_sub.c */,
- F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */,
- F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */,
- F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */,
- F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */,
- F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */,
- F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */,
- F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */,
- F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */,
- F96D42D008F272B3004A47F5 /* bn_reverse.c */,
- F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */,
- F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */,
- F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */,
- F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */,
- F96D432908F272B4004A47F5 /* tommath_class.h */,
- F96D432A08F272B4004A47F5 /* tommath_superclass.h */,
- );
- path = libtommath;
- sourceTree = "<group>";
- };
- F96D432C08F272B4004A47F5 /* macosx */ = {
- isa = PBXGroup;
- children = (
- F96D432E08F272B5004A47F5 /* configure.ac */,
- F96D432F08F272B5004A47F5 /* GNUmakefile */,
- F96D433108F272B5004A47F5 /* README */,
- F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */,
- F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */,
- F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */,
- F96D433208F272B5004A47F5 /* Tcl-Info.plist.in */,
- F91E62260C1AE686006C9D96 /* Tclsh-Info.plist.in */,
- F97AE7F10B65C1E900310EA2 /* Tcl-Common.xcconfig */,
- F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */,
- F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */,
- );
- path = macosx;
- sourceTree = "<group>";
- };
- F96D434408F272B5004A47F5 /* tests */ = {
- isa = PBXGroup;
- children = (
- F96D434508F272B5004A47F5 /* all.tcl */,
- F96D434608F272B5004A47F5 /* append.test */,
- F96D434708F272B5004A47F5 /* appendComp.test */,
- F9ECB1CA0B2652D300A28025 /* apply.test */,
- F96D434808F272B5004A47F5 /* assocd.test */,
- F96D434908F272B5004A47F5 /* async.test */,
- F96D434A08F272B5004A47F5 /* autoMkindex.test */,
- F96D434B08F272B5004A47F5 /* basic.test */,
- F96D434C08F272B5004A47F5 /* binary.test */,
- F96D434D08F272B5004A47F5 /* case.test */,
- F96D434E08F272B5004A47F5 /* chan.test */,
- F9A493240CEBF38300B78AE2 /* chanio.test */,
- F96D434F08F272B5004A47F5 /* clock.test */,
- F96D435008F272B5004A47F5 /* cmdAH.test */,
- F96D435108F272B5004A47F5 /* cmdIL.test */,
- F96D435208F272B5004A47F5 /* cmdInfo.test */,
- F96D435308F272B5004A47F5 /* cmdMZ.test */,
- F96D435408F272B5004A47F5 /* compExpr-old.test */,
- F96D435508F272B5004A47F5 /* compExpr.test */,
- F96D435608F272B5004A47F5 /* compile.test */,
- F96D435708F272B5004A47F5 /* concat.test */,
- F96D435808F272B5004A47F5 /* config.test */,
- F974D5770FBE7E6100BF728B /* coroutine.test */,
- F96D435908F272B5004A47F5 /* dcall.test */,
- F96D435A08F272B5004A47F5 /* dict.test */,
- F96D435C08F272B5004A47F5 /* dstring.test */,
- F96D435E08F272B5004A47F5 /* encoding.test */,
- F96D435F08F272B5004A47F5 /* env.test */,
- F96D436008F272B5004A47F5 /* error.test */,
- F96D436108F272B5004A47F5 /* eval.test */,
- F96D436208F272B5004A47F5 /* event.test */,
- F96D436308F272B5004A47F5 /* exec.test */,
- F96D436408F272B5004A47F5 /* execute.test */,
- F96D436508F272B5004A47F5 /* expr-old.test */,
- F96D436608F272B5004A47F5 /* expr.test */,
- F96D436708F272B6004A47F5 /* fCmd.test */,
- F96D436808F272B6004A47F5 /* fileName.test */,
- F96D436908F272B6004A47F5 /* fileSystem.test */,
- F96D436A08F272B6004A47F5 /* for-old.test */,
- F96D436B08F272B6004A47F5 /* for.test */,
- F96D436C08F272B6004A47F5 /* foreach.test */,
- F96D436D08F272B6004A47F5 /* format.test */,
- F96D436E08F272B6004A47F5 /* get.test */,
- F96D436F08F272B6004A47F5 /* history.test */,
- F96D437008F272B6004A47F5 /* http.test */,
- F974D56C0FBE7D6300BF728B /* http11.test */,
- F96D437108F272B6004A47F5 /* httpd */,
- F974D56D0FBE7D6300BF728B /* httpd11.tcl */,
- F96D437208F272B6004A47F5 /* httpold.test */,
- F96D437308F272B6004A47F5 /* if-old.test */,
- F96D437408F272B6004A47F5 /* if.test */,
- F96D437508F272B6004A47F5 /* incr-old.test */,
- F96D437608F272B6004A47F5 /* incr.test */,
- F96D437708F272B6004A47F5 /* indexObj.test */,
- F96D437808F272B6004A47F5 /* info.test */,
- F96D437908F272B6004A47F5 /* init.test */,
- F96D437A08F272B6004A47F5 /* interp.test */,
- F96D437B08F272B6004A47F5 /* io.test */,
- F96D437C08F272B6004A47F5 /* ioCmd.test */,
- F96D437D08F272B6004A47F5 /* iogt.test */,
- F96D437F08F272B6004A47F5 /* join.test */,
- F96D438008F272B6004A47F5 /* lindex.test */,
- F96D438108F272B6004A47F5 /* link.test */,
- F96D438208F272B6004A47F5 /* linsert.test */,
- F96D438308F272B6004A47F5 /* list.test */,
- F96D438408F272B6004A47F5 /* listObj.test */,
- F96D438508F272B6004A47F5 /* llength.test */,
- F96D438608F272B6004A47F5 /* load.test */,
- F96D438708F272B6004A47F5 /* lrange.test */,
- F96D438808F272B6004A47F5 /* lrepeat.test */,
- F96D438908F272B6004A47F5 /* lreplace.test */,
- F96D438A08F272B6004A47F5 /* lsearch.test */,
- F96D438B08F272B6004A47F5 /* lset.test */,
- F96D438C08F272B6004A47F5 /* lsetComp.test */,
- F96D438D08F272B6004A47F5 /* macOSXFCmd.test */,
- F95FAFF90B34F1130072E431 /* macOSXLoad.test */,
- F96D438E08F272B6004A47F5 /* main.test */,
- F9ECB1CB0B26534C00A28025 /* mathop.test */,
- F96D438F08F272B6004A47F5 /* misc.test */,
- F96D439008F272B6004A47F5 /* msgcat.test */,
- F96D439108F272B6004A47F5 /* namespace-old.test */,
- F96D439208F272B7004A47F5 /* namespace.test */,
- F96D439308F272B7004A47F5 /* notify.test */,
- F91DC23C0E44C51B002CB8D1 /* nre.test */,
- F96D439408F272B7004A47F5 /* obj.test */,
- F93599C80DF1F81900E04F67 /* oo.test */,
- F96D439508F272B7004A47F5 /* opt.test */,
- F96D439608F272B7004A47F5 /* package.test */,
- F96D439708F272B7004A47F5 /* parse.test */,
- F96D439808F272B7004A47F5 /* parseExpr.test */,
- F96D439908F272B7004A47F5 /* parseOld.test */,
- F96D439A08F272B7004A47F5 /* pid.test */,
- F96D439B08F272B7004A47F5 /* pkg.test */,
- F96D439C08F272B7004A47F5 /* pkgMkIndex.test */,
- F96D439D08F272B7004A47F5 /* platform.test */,
- F96D439E08F272B7004A47F5 /* proc-old.test */,
- F96D439F08F272B7004A47F5 /* proc.test */,
- F96D43A008F272B7004A47F5 /* pwd.test */,
- F96D43A108F272B7004A47F5 /* README */,
- F96D43A208F272B7004A47F5 /* reg.test */,
- F96D43A308F272B7004A47F5 /* regexp.test */,
- F96D43A408F272B7004A47F5 /* regexpComp.test */,
- F96D43A508F272B7004A47F5 /* registry.test */,
- F96D43A608F272B7004A47F5 /* remote.tcl */,
- F96D43A708F272B7004A47F5 /* rename.test */,
- F96D43A808F272B7004A47F5 /* result.test */,
- F96D43A908F272B7004A47F5 /* safe.test */,
- F96D43AA08F272B7004A47F5 /* scan.test */,
- F96D43AB08F272B7004A47F5 /* security.test */,
- F96D43AC08F272B7004A47F5 /* set-old.test */,
- F96D43AD08F272B7004A47F5 /* set.test */,
- F96D43AE08F272B7004A47F5 /* socket.test */,
- F96D43AF08F272B7004A47F5 /* source.test */,
- F96D43B008F272B7004A47F5 /* split.test */,
- F96D43B108F272B7004A47F5 /* stack.test */,
- F96D43B208F272B7004A47F5 /* string.test */,
- F96D43B308F272B7004A47F5 /* stringComp.test */,
- F96D43B408F272B7004A47F5 /* stringObj.test */,
- F96D43B508F272B7004A47F5 /* subst.test */,
- F96D43B608F272B7004A47F5 /* switch.test */,
- F974D5780FBE7E6100BF728B /* tailcall.test */,
- F96D43B708F272B7004A47F5 /* tcltest.test */,
- F96D43B808F272B7004A47F5 /* thread.test */,
- F96D43B908F272B7004A47F5 /* timer.test */,
- F96D43BA08F272B7004A47F5 /* tm.test */,
- F96D43BB08F272B7004A47F5 /* trace.test */,
- F96D43BC08F272B7004A47F5 /* unixFCmd.test */,
- F96D43BD08F272B7004A47F5 /* unixFile.test */,
- F96D43BE08F272B7004A47F5 /* unixInit.test */,
- F96D43BF08F272B7004A47F5 /* unixNotfy.test */,
- F96D43C008F272B7004A47F5 /* unknown.test */,
- F96D43C108F272B7004A47F5 /* unload.test */,
- F96D43C208F272B7004A47F5 /* uplevel.test */,
- F96D43C308F272B7004A47F5 /* upvar.test */,
- F96D43C408F272B7004A47F5 /* utf.test */,
- F96D43C508F272B7004A47F5 /* util.test */,
- F96D43C608F272B7004A47F5 /* var.test */,
- F96D43C708F272B7004A47F5 /* while-old.test */,
- F96D43C808F272B7004A47F5 /* while.test */,
- F96D43C908F272B7004A47F5 /* winConsole.test */,
- F96D43CA08F272B7004A47F5 /* winDde.test */,
- F96D43CB08F272B7004A47F5 /* winFCmd.test */,
- F96D43CC08F272B7004A47F5 /* winFile.test */,
- F96D43CD08F272B7004A47F5 /* winNotify.test */,
- F96D43CE08F272B7004A47F5 /* winPipe.test */,
- F96D43CF08F272B7004A47F5 /* winTime.test */,
- F915432A0EF201CF0032D1E8 /* zlib.test */,
- );
- path = tests;
- sourceTree = "<group>";
- };
- F96D43D008F272B8004A47F5 /* tools */ = {
- isa = PBXGroup;
- children = (
- F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
- F96D43D208F272B8004A47F5 /* configure */,
- F96D43D308F272B8004A47F5 /* configure.in */,
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */,
- F96D442508F272B8004A47F5 /* genStubs.tcl */,
- F96D442708F272B8004A47F5 /* index.tcl */,
- F96D442808F272B8004A47F5 /* installData.tcl */,
- F96D442908F272B8004A47F5 /* loadICU.tcl */,
- F96D442A08F272B8004A47F5 /* Makefile.in */,
- F96D442B08F272B8004A47F5 /* makeTestCases.tcl */,
- F96D442C08F272B8004A47F5 /* man2help.tcl */,
- F96D442D08F272B8004A47F5 /* man2help2.tcl */,
- F96D442E08F272B8004A47F5 /* man2html.tcl */,
- F96D442F08F272B8004A47F5 /* man2html1.tcl */,
- F96D443008F272B8004A47F5 /* man2html2.tcl */,
- F96D443108F272B8004A47F5 /* man2tcl.c */,
- F96D443208F272B8004A47F5 /* README */,
- F96D443308F272B8004A47F5 /* regexpTestLib.tcl */,
- F96D443508F272B8004A47F5 /* tcl.hpj.in */,
- F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */,
- F96D443A08F272B9004A47F5 /* tclZIC.tcl */,
- F92D7F100DE777240033A13A /* tsdPerf.tcl */,
- F96D443B08F272B9004A47F5 /* uniClass.tcl */,
- F96D443C08F272B9004A47F5 /* uniParse.tcl */,
- );
- path = tools;
- sourceTree = "<group>";
- };
- F96D443E08F272B9004A47F5 /* unix */ = {
- isa = PBXGroup;
- children = (
- F96D444008F272B9004A47F5 /* aclocal.m4 */,
- F96D444108F272B9004A47F5 /* configure */,
- F96D444208F272B9004A47F5 /* configure.in */,
- F96D444308F272B9004A47F5 /* dltest */,
- F96D444D08F272B9004A47F5 /* install-sh */,
- F96D444E08F272B9004A47F5 /* installManPage */,
- F96D444F08F272B9004A47F5 /* ldAix */,
- F96D445008F272B9004A47F5 /* Makefile.in */,
- F96D445208F272B9004A47F5 /* README */,
- F96D445308F272B9004A47F5 /* tcl.m4 */,
- F974D5790FBE7E9C00BF728B /* tcl.pc.in */,
- F96D445408F272B9004A47F5 /* tcl.spec */,
- F96D445508F272B9004A47F5 /* tclAppInit.c */,
- F96D445608F272B9004A47F5 /* tclConfig.h.in */,
- F96D445708F272B9004A47F5 /* tclConfig.sh.in */,
- F96D445808F272B9004A47F5 /* tclLoadAix.c */,
- F96D445908F272B9004A47F5 /* tclLoadDl.c */,
- F96D445B08F272B9004A47F5 /* tclLoadDyld.c */,
- F96D445C08F272B9004A47F5 /* tclLoadNext.c */,
- F96D445D08F272B9004A47F5 /* tclLoadOSF.c */,
- F96D445E08F272B9004A47F5 /* tclLoadShl.c */,
- F96D445F08F272B9004A47F5 /* tclUnixChan.c */,
- F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */,
- F96D446008F272B9004A47F5 /* tclUnixEvent.c */,
- F96D446108F272B9004A47F5 /* tclUnixFCmd.c */,
- F96D446208F272B9004A47F5 /* tclUnixFile.c */,
- F96D446308F272B9004A47F5 /* tclUnixInit.c */,
- F96D446408F272B9004A47F5 /* tclUnixNotfy.c */,
- F96D446508F272B9004A47F5 /* tclUnixPipe.c */,
- F96D446608F272B9004A47F5 /* tclUnixPort.h */,
- F96D446708F272B9004A47F5 /* tclUnixSock.c */,
- F96D446808F272B9004A47F5 /* tclUnixTest.c */,
- F96D446908F272B9004A47F5 /* tclUnixThrd.c */,
- F96D446B08F272B9004A47F5 /* tclUnixTime.c */,
- F96D446C08F272B9004A47F5 /* tclXtNotify.c */,
- F96D446D08F272B9004A47F5 /* tclXtTest.c */,
- );
- path = unix;
- sourceTree = "<group>";
- };
- F96D444308F272B9004A47F5 /* dltest */ = {
- isa = PBXGroup;
- children = (
- F96D444408F272B9004A47F5 /* Makefile.in */,
- F96D444508F272B9004A47F5 /* pkga.c */,
- F96D444608F272B9004A47F5 /* pkgb.c */,
- F96D444708F272B9004A47F5 /* pkgc.c */,
- F96D444808F272B9004A47F5 /* pkgd.c */,
- F96D444908F272B9004A47F5 /* pkge.c */,
- F96D444B08F272B9004A47F5 /* pkgua.c */,
- F96D444C08F272B9004A47F5 /* README */,
- );
- path = dltest;
- sourceTree = "<group>";
- };
- F96D446E08F272B9004A47F5 /* win */ = {
- isa = PBXGroup;
- children = (
- F96D447008F272BA004A47F5 /* aclocal.m4 */,
- F96D447108F272BA004A47F5 /* buildall.vc.bat */,
- F96D447208F272BA004A47F5 /* cat.c */,
- F96D447308F272BA004A47F5 /* coffbase.txt */,
- F96D447408F272BA004A47F5 /* configure */,
- F96D447508F272BA004A47F5 /* configure.in */,
- F96D447708F272BA004A47F5 /* Makefile.in */,
- F96D447808F272BA004A47F5 /* makefile.vc */,
- F96D447908F272BA004A47F5 /* nmakehlp.c */,
- F96D447A08F272BA004A47F5 /* README */,
- F96D447C08F272BA004A47F5 /* rules.vc */,
- F96D447D08F272BA004A47F5 /* stub16.c */,
- F96D447E08F272BA004A47F5 /* tcl.dsp */,
- F96D447F08F272BA004A47F5 /* tcl.dsw */,
- F96D448008F272BA004A47F5 /* tcl.hpj.in */,
- F96D448108F272BA004A47F5 /* tcl.m4 */,
- F96D448208F272BA004A47F5 /* tcl.rc */,
- F96D448308F272BA004A47F5 /* tclAppInit.c */,
- F96D448408F272BA004A47F5 /* tclConfig.sh.in */,
- F96D448608F272BA004A47F5 /* tclsh.rc */,
- F96D448708F272BA004A47F5 /* tclWin32Dll.c */,
- F96D448808F272BA004A47F5 /* tclWinChan.c */,
- F96D448908F272BA004A47F5 /* tclWinConsole.c */,
- F96D448A08F272BA004A47F5 /* tclWinDde.c */,
- F96D448B08F272BA004A47F5 /* tclWinError.c */,
- F96D448C08F272BA004A47F5 /* tclWinFCmd.c */,
- F96D448D08F272BA004A47F5 /* tclWinFile.c */,
- F96D448E08F272BA004A47F5 /* tclWinInit.c */,
- F96D448F08F272BA004A47F5 /* tclWinInt.h */,
- F96D449008F272BA004A47F5 /* tclWinLoad.c */,
- F96D449108F272BA004A47F5 /* tclWinNotify.c */,
- F96D449208F272BA004A47F5 /* tclWinPipe.c */,
- F96D449308F272BA004A47F5 /* tclWinPort.h */,
- F96D449408F272BA004A47F5 /* tclWinReg.c */,
- F96D449508F272BA004A47F5 /* tclWinSerial.c */,
- F96D449608F272BA004A47F5 /* tclWinSock.c */,
- F96D449708F272BA004A47F5 /* tclWinTest.c */,
- F96D449808F272BA004A47F5 /* tclWinThrd.c */,
- F96D449A08F272BA004A47F5 /* tclWinTime.c */,
- );
- path = win;
- sourceTree = "<group>";
- };
- F9ECB1110B26521500A28025 /* platform */ = {
- isa = PBXGroup;
- children = (
- F9ECB1120B26521500A28025 /* pkgIndex.tcl */,
- F9ECB1130B26521500A28025 /* platform.tcl */,
- F9ECB1140B26521500A28025 /* shell.tcl */,
- );
- path = platform;
- sourceTree = "<group>";
- };
-/* End PBXGroup section */
-
-/* Begin PBXNativeTarget section */
- 8DD76FA90486AB0100D96B5E /* tcltest */ = {
- isa = PBXNativeTarget;
- buildConfigurationList = F95CC8B009158F3100EA5ACE /* Build configuration list for PBXNativeTarget "tcltest" */;
- buildPhases = (
- F9A5C5F508F651A2008AE941 /* Configure Tcl */,
- 8DD76FAB0486AB0100D96B5E /* Sources */,
- 8DD76FAD0486AB0100D96B5E /* Frameworks */,
- F95FA74C0B32CE190072E431 /* Build dltest */,
- );
- buildRules = (
- );
- dependencies = (
- );
- name = tcltest;
- productInstallPath = "$(BINDIR)";
- productName = tcltest;
- productReference = 8DD76FB20486AB0100D96B5E /* tcltest */;
- productType = "com.apple.product-type.tool";
- };
- F97258A50A86873C00096C78 /* tests */ = {
- isa = PBXNativeTarget;
- buildConfigurationList = F97258A80A86873D00096C78 /* Build configuration list for PBXNativeTarget "tests" */;
- buildPhases = (
- F97258A40A86873C00096C78 /* Run Testsuite */,
- );
- buildRules = (
- );
- dependencies = (
- F97258D30A868C6F00096C78 /* PBXTargetDependency */,
- );
- name = tests;
- productName = tests;
- productType = "com.apple.product-type.bundle";
- };
- F9E61D16090A3E94002B3151 /* Tcl */ = {
- isa = PBXNativeTarget;
- buildConfigurationList = F95CC8AB09158F3100EA5ACE /* Build configuration list for PBXNativeTarget "Tcl" */;
- buildPhases = (
- F97AF02F0B665DA900310EA2 /* Build Tcl */,
- );
- buildRules = (
- );
- dependencies = (
- );
- name = Tcl;
- productName = tclsh;
- productReference = F9A3084B08F2D4CE00BAE1AB /* tclsh */;
- productType = "com.apple.product-type.tool";
- };
-/* End PBXNativeTarget section */
-
-/* Begin PBXProject section */
- 08FB7793FE84155DC02AAC07 /* Project object */ = {
- isa = PBXProject;
- attributes = {
- BuildIndependentTargetsInParallel = YES;
- };
- buildConfigurationList = F95CC8B509158F3100EA5ACE /* Build configuration list for PBXProject "Tcl" */;
- compatibilityVersion = "Xcode 3.1";
- hasScannedForEncodings = 1;
- mainGroup = 08FB7794FE84155DC02AAC07 /* Tcl */;
- projectDirPath = "";
- projectRoot = ..;
- targets = (
- F9E61D16090A3E94002B3151 /* Tcl */,
- 8DD76FA90486AB0100D96B5E /* tcltest */,
- F97258A50A86873C00096C78 /* tests */,
- );
- };
-/* End PBXProject section */
-
-/* Begin PBXShellScriptBuildPhase section */
- F95FA74C0B32CE190072E431 /* Build dltest */ = {
- isa = PBXShellScriptBuildPhase;
- buildActionMask = 2147483647;
- files = (
- );
- inputPaths = (
- "$(DERIVED_FILE_DIR)/tcl/tclConfig.sh",
- "$(TCL_SRCROOT)/generic/tclStubLib.c",
- "$(TCL_SRCROOT)/unix/dltest/pkga.c",
- "$(TCL_SRCROOT)/unix/dltest/pkgb.c",
- "$(TCL_SRCROOT)/unix/dltest/pkgc.c",
- "$(TCL_SRCROOT)/unix/dltest/pkgd.c",
- "$(TCL_SRCROOT)/unix/dltest/pkge.c",
- "$(TCL_SRCROOT)/unix/dltest/pkgua.c",
- );
- name = "Build dltest";
- outputPaths = (
- "$(DERIVED_FILE_DIR)/tcl/dltest.marker",
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/bash;
- shellScript = "## dltest build script phase\n\nrm -f \"${DERIVED_FILE_DIR}/tcl/dltest.marker\"\nmake -C \"${DERIVED_FILE_DIR}/tcl\" dltest.marker\nln -fsh \"${DERIVED_FILE_DIR}/tcl/dltest\" \"${CONFIGURATION_BUILD_DIR}\"\n";
- showEnvVarsInLog = 0;
- };
- F97258A40A86873C00096C78 /* Run Testsuite */ = {
- isa = PBXShellScriptBuildPhase;
- buildActionMask = 2147483647;
- files = (
- );
- inputPaths = (
- );
- name = "Run Testsuite";
- outputPaths = (
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/bash;
- shellScript = "if [ \"${ACTION:-build}\" == \"build\" ]; then\nif [ -z \"${HOME}\" ]; then export HOME=\"$(echo ~)\"; fi\ncd \"${TARGET_TEMP_DIR}\"; rm -rf \"${DERIVED_FILE_DIR}\"; mkdir -p \"${DERIVED_FILE_DIR}\"\nprintf '%s%s%s%s%s' '\npackage require tcltest 2.5\nnamespace import tcltest::*\nconfigure -testdir [file normalize {' \"${TCL_SRCROOT}\" '/tests}]\nconfigure -tmpdir [file normalize {' \"${DERIVED_FILE_DIR}\" '}]\nconfigure -verbose [concat [configure -verbose] line]\nrunAllTests\n' | \"${TEST_RIG}\"; TEST_RIG_RESULT=$?\n[ ${TEST_RIG_RESULT} -ne 0 ] && echo \"tcltest:0: error: tcltest exited abnormally with code ${TEST_RIG_RESULT}.\"\nexit ${TEST_RIG_RESULT}\nfi";
- showEnvVarsInLog = 0;
- };
- F97AF02F0B665DA900310EA2 /* Build Tcl */ = {
- isa = PBXShellScriptBuildPhase;
- buildActionMask = 2147483647;
- files = (
- );
- inputPaths = (
- "${TARGET_TEMP_DIR}/.none",
- );
- name = "Build Tcl";
- outputPaths = (
- "${TARGET_BUILD_DIR}/${EXECUTABLE_NAME}",
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/bash;
- shellScript = "if [ -e \"${TARGET_BUILD_DIR}/tclsh\" ]; then\n mv -f \"${TARGET_BUILD_DIR}/tclsh\" \"${TARGET_BUILD_DIR}/tclsh${VERSION}\"\nfi\nexport CC=$(xcrun -find ${GCC} || echo ${GCC}); export LD=${CC}\ngnumake -C \"${TCL_SRCROOT}/macosx\" -j \"$(sysctl -n hw.activecpu)\" \"$(echo \"${ACTION}\" | sed -e s/build// -e s/clean/distclean/ -e s/..\\*/\\&-/)${MAKE_TARGET}\" CFLAGS_WARNING=\"${WARNING_CFLAGS}\" CFLAGS_OPTIMIZE=\"-O${GCC_OPTIMIZATION_LEVEL}\" SYMROOT=\"${BUILT_PRODUCTS_DIR}\" OBJ_DIR=\"${OBJECT_FILE_DIR}\" INSTALL_ROOT=\"${DSTROOT}\" PREFIX=\"${PREFIX}\" BINDIR=\"${BINDIR}\" LIBDIR=\"${FRAMEWORK_INSTALL_PATH}\" MANDIR=\"${MANDIR}\" EXTRA_CONFIGURE_ARGS=\"${CONFIGURE_ARGS}\" ${EXTRA_MAKE_FLAGS}\nresult=$?\nif [ -e \"${TARGET_BUILD_DIR}/tclsh${VERSION}\" ]; then\n mv -f \"${TARGET_BUILD_DIR}/tclsh${VERSION}\" \"${TARGET_BUILD_DIR}/tclsh\"\nfi\nif [ -e \"${BUILT_PRODUCTS_DIR}/tcltest\" ]; then\n\trm -f \"${BUILT_PRODUCTS_DIR}/tcltest\"\nfi\necho \"Done\"\nrm -f \"${SCRIPT_INPUT_FILE_0}\"\nexit ${result}\n";
- showEnvVarsInLog = 0;
- };
- F9A5C5F508F651A2008AE941 /* Configure Tcl */ = {
- isa = PBXShellScriptBuildPhase;
- buildActionMask = 2147483647;
- files = (
- );
- inputPaths = (
- "$(TCL_SRCROOT)/macosx/configure.ac",
- "$(TCL_SRCROOT)/unix/configure.in",
- "$(TCL_SRCROOT)/unix/tcl.m4",
- "$(TCL_SRCROOT)/unix/aclocal.m4",
- "$(TCL_SRCROOT)/unix/tclConfig.sh.in",
- "$(TCL_SRCROOT)/unix/Makefile.in",
- "$(TCL_SRCROOT)/unix/dltest/Makefile.in",
- );
- name = "Configure Tcl";
- outputPaths = (
- "$(DERIVED_FILE_DIR)/tcl/tclConfig.sh",
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/bash;
- shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.in -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n";
- showEnvVarsInLog = 0;
- };
-/* End PBXShellScriptBuildPhase section */
-
-/* Begin PBXSourcesBuildPhase section */
- 8DD76FAB0486AB0100D96B5E /* Sources */ = {
- isa = PBXSourcesBuildPhase;
- buildActionMask = 2147483647;
- files = (
- F96D456F08F272BB004A47F5 /* regcomp.c in Sources */,
- F96D457208F272BB004A47F5 /* regerror.c in Sources */,
- F96D457508F272BB004A47F5 /* regexec.c in Sources */,
- F96D457608F272BB004A47F5 /* regfree.c in Sources */,
- F96D457B08F272BB004A47F5 /* tclAlloc.c in Sources */,
- F96D457C08F272BB004A47F5 /* tclAsync.c in Sources */,
- F96D457D08F272BB004A47F5 /* tclBasic.c in Sources */,
- F96D457E08F272BC004A47F5 /* tclBinary.c in Sources */,
- F96D457F08F272BC004A47F5 /* tclCkalloc.c in Sources */,
- F96D458008F272BC004A47F5 /* tclClock.c in Sources */,
- F96D458108F272BC004A47F5 /* tclCmdAH.c in Sources */,
- F96D458208F272BC004A47F5 /* tclCmdIL.c in Sources */,
- F96D458308F272BC004A47F5 /* tclCmdMZ.c in Sources */,
- F96D458408F272BC004A47F5 /* tclCompCmds.c in Sources */,
- F96D458508F272BC004A47F5 /* tclCompExpr.c in Sources */,
- F96D458608F272BC004A47F5 /* tclCompile.c in Sources */,
- F96D458808F272BC004A47F5 /* tclConfig.c in Sources */,
- F96D458908F272BC004A47F5 /* tclDate.c in Sources */,
- F96D458B08F272BC004A47F5 /* tclDictObj.c in Sources */,
- F96D458C08F272BC004A47F5 /* tclEncoding.c in Sources */,
- F96D458D08F272BC004A47F5 /* tclEnv.c in Sources */,
- F96D458E08F272BC004A47F5 /* tclEvent.c in Sources */,
- F96D458F08F272BC004A47F5 /* tclExecute.c in Sources */,
- F96D459008F272BC004A47F5 /* tclFCmd.c in Sources */,
- F96D459108F272BC004A47F5 /* tclFileName.c in Sources */,
- F96D459308F272BC004A47F5 /* tclGet.c in Sources */,
- F96D459508F272BC004A47F5 /* tclHash.c in Sources */,
- F96D459608F272BC004A47F5 /* tclHistory.c in Sources */,
- F96D459708F272BC004A47F5 /* tclIndexObj.c in Sources */,
- F96D459B08F272BC004A47F5 /* tclInterp.c in Sources */,
- F96D459D08F272BC004A47F5 /* tclIO.c in Sources */,
- F96D459F08F272BC004A47F5 /* tclIOCmd.c in Sources */,
- F96D45A008F272BC004A47F5 /* tclIOGT.c in Sources */,
- F96D45A108F272BC004A47F5 /* tclIORChan.c in Sources */,
- F95D77EA0DFD820D00A8BF6F /* tclIORTrans.c in Sources */,
- F96D45A208F272BC004A47F5 /* tclIOSock.c in Sources */,
- F96D45A308F272BC004A47F5 /* tclIOUtil.c in Sources */,
- F96D45A408F272BC004A47F5 /* tclLink.c in Sources */,
- F96D45A508F272BC004A47F5 /* tclListObj.c in Sources */,
- F96D45A608F272BC004A47F5 /* tclLiteral.c in Sources */,
- F96D45A708F272BC004A47F5 /* tclLoad.c in Sources */,
- F96D45A908F272BC004A47F5 /* tclMain.c in Sources */,
- F96D45AA08F272BC004A47F5 /* tclNamesp.c in Sources */,
- F96D45AB08F272BC004A47F5 /* tclNotify.c in Sources */,
- F96D45AC08F272BC004A47F5 /* tclObj.c in Sources */,
- F93599B30DF1F75400E04F67 /* tclOO.c in Sources */,
- F93599B70DF1F76100E04F67 /* tclOOBasic.c in Sources */,
- F93599B90DF1F76600E04F67 /* tclOOCall.c in Sources */,
- F93599BC0DF1F77000E04F67 /* tclOODefineCmds.c in Sources */,
- F93599BE0DF1F77400E04F67 /* tclOOInfo.c in Sources */,
- F93599C20DF1F78300E04F67 /* tclOOMethod.c in Sources */,
- F93599C40DF1F78800E04F67 /* tclOOStubInit.c in Sources */,
- F93599C60DF1F78D00E04F67 /* tclOOStubLib.c in Sources */,
- F96D45AD08F272BC004A47F5 /* tclPanic.c in Sources */,
- F96D45AE08F272BC004A47F5 /* tclParse.c in Sources */,
- F96D45B008F272BC004A47F5 /* tclPathObj.c in Sources */,
- F96D45B108F272BC004A47F5 /* tclPipe.c in Sources */,
- F96D45B208F272BC004A47F5 /* tclPkg.c in Sources */,
- F96D45B308F272BC004A47F5 /* tclPkgConfig.c in Sources */,
- F96D45B608F272BC004A47F5 /* tclPosixStr.c in Sources */,
- F96D45B708F272BC004A47F5 /* tclPreserve.c in Sources */,
- F96D45B808F272BC004A47F5 /* tclProc.c in Sources */,
- F96D45B908F272BC004A47F5 /* tclRegexp.c in Sources */,
- F96D45BB08F272BC004A47F5 /* tclResolve.c in Sources */,
- F96D45BC08F272BC004A47F5 /* tclResult.c in Sources */,
- F96D45BD08F272BC004A47F5 /* tclScan.c in Sources */,
- F96D45BE08F272BC004A47F5 /* tclStringObj.c in Sources */,
- F96D45C308F272BC004A47F5 /* tclStrToD.c in Sources */,
- F96D45C408F272BC004A47F5 /* tclStubInit.c in Sources */,
- F96D45C508F272BC004A47F5 /* tclStubLib.c in Sources */,
- F96D45C608F272BC004A47F5 /* tclTest.c in Sources */,
- F96D45C708F272BC004A47F5 /* tclTestObj.c in Sources */,
- F96D45C808F272BC004A47F5 /* tclTestProcBodyObj.c in Sources */,
- F96D45C908F272BC004A47F5 /* tclThread.c in Sources */,
- F96D45CA08F272BC004A47F5 /* tclThreadAlloc.c in Sources */,
- F96D45CB08F272BC004A47F5 /* tclThreadJoin.c in Sources */,
- F96D45CC08F272BC004A47F5 /* tclThreadStorage.c in Sources */,
- F96D45CD08F272BC004A47F5 /* tclThreadTest.c in Sources */,
- F96D45CE08F272BC004A47F5 /* tclTimer.c in Sources */,
- F96D45D008F272BC004A47F5 /* tclTomMathInterface.c in Sources */,
- F96D45D108F272BC004A47F5 /* tclTrace.c in Sources */,
- F96D45D308F272BC004A47F5 /* tclUtf.c in Sources */,
- F96D45D408F272BC004A47F5 /* tclUtil.c in Sources */,
- F96D45D508F272BC004A47F5 /* tclVar.c in Sources */,
- F96437CA0EF0D4B2003F468E /* tclZlib.c in Sources */,
- F96D48E208F272C3004A47F5 /* bn_fast_s_mp_mul_digs.c in Sources */,
- F96D48E408F272C3004A47F5 /* bn_fast_s_mp_sqr.c in Sources */,
- F96D48E708F272C3004A47F5 /* bn_mp_add.c in Sources */,
- F96D48E808F272C3004A47F5 /* bn_mp_add_d.c in Sources */,
- F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */,
- F96D48EB08F272C3004A47F5 /* bn_mp_clamp.c in Sources */,
- F96D48EC08F272C3004A47F5 /* bn_mp_clear.c in Sources */,
- F96D48ED08F272C3004A47F5 /* bn_mp_clear_multi.c in Sources */,
- F96D48EE08F272C3004A47F5 /* bn_mp_cmp.c in Sources */,
- F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */,
- F96D48F008F272C3004A47F5 /* bn_mp_cmp_mag.c in Sources */,
- F96D48F208F272C3004A47F5 /* bn_mp_cnt_lsb.c in Sources */,
- F96D48F208F272C3004A47F5 /* bn_mp_copy.c in Sources */,
- F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */,
- F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */,
- F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */,
- F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */,
- F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */,
- F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */,
- F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */,
- F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */,
- F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */,
- F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */,
- F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */,
- F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */,
- F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */,
- F96D490B08F272C3004A47F5 /* bn_mp_init_size.c in Sources */,
- F96D491008F272C3004A47F5 /* bn_mp_karatsuba_mul.c in Sources */,
- F96D491108F272C3004A47F5 /* bn_mp_karatsuba_sqr.c in Sources */,
- F96D491308F272C3004A47F5 /* bn_mp_lshd.c in Sources */,
- F96D491408F272C3004A47F5 /* bn_mp_mod.c in Sources */,
- F96D491508F272C3004A47F5 /* bn_mp_mod_2d.c in Sources */,
- F96D491A08F272C3004A47F5 /* bn_mp_mul.c in Sources */,
- F96D491B08F272C3004A47F5 /* bn_mp_mul_2.c in Sources */,
- F96D491C08F272C3004A47F5 /* bn_mp_mul_2d.c in Sources */,
- F96D491D08F272C3004A47F5 /* bn_mp_mul_d.c in Sources */,
- F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */,
- F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */,
- F96D492908F272C3004A47F5 /* bn_mp_radix_size.c in Sources */,
- F96D492A08F272C3004A47F5 /* bn_mp_radix_smap.c in Sources */,
- F96D492C08F272C3004A47F5 /* bn_mp_read_radix.c in Sources */,
- F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */,
- F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */,
- F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */,
- F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */,
- F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */,
- F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */,
- F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */,
- F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */,
- F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */,
- F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */,
- F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */,
- F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */,
- F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */,
- F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */,
- F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */,
- F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */,
- F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */,
- F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */,
- F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */,
- F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */,
- F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */,
- F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */,
- F90509300913A72400327603 /* tclAppInit.c in Sources */,
- F96D4AC608F272C9004A47F5 /* tclLoadDyld.c in Sources */,
- F96D4ACA08F272C9004A47F5 /* tclUnixChan.c in Sources */,
- F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */,
- F96D4ACB08F272C9004A47F5 /* tclUnixEvent.c in Sources */,
- F96D4ACC08F272C9004A47F5 /* tclUnixFCmd.c in Sources */,
- F96D4ACD08F272C9004A47F5 /* tclUnixFile.c in Sources */,
- F96D4ACE08F272C9004A47F5 /* tclUnixInit.c in Sources */,
- F96D4ACF08F272C9004A47F5 /* tclUnixNotfy.c in Sources */,
- F96D4AD008F272C9004A47F5 /* tclUnixPipe.c in Sources */,
- F96D4AD208F272CA004A47F5 /* tclUnixSock.c in Sources */,
- F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */,
- F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */,
- F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */,
- F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */,
- );
- runOnlyForDeploymentPostprocessing = 0;
- };
-/* End PBXSourcesBuildPhase section */
-
-/* Begin PBXTargetDependency section */
- F97258D30A868C6F00096C78 /* PBXTargetDependency */ = {
- isa = PBXTargetDependency;
- target = 8DD76FA90486AB0100D96B5E /* tcltest */;
- targetProxy = F97258D20A868C6F00096C78 /* PBXContainerItemProxy */;
- };
-/* End PBXTargetDependency section */
-
-/* Begin XCBuildConfiguration section */
- F91BCC4F093152310042A6BF /* ReleaseUniversal */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = ReleaseUniversal;
- };
- F91BCC50093152310042A6BF /* ReleaseUniversal */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = ReleaseUniversal;
- };
- F91BCC51093152310042A6BF /* ReleaseUniversal */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
- buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- PREBINDING = NO;
- };
- name = ReleaseUniversal;
- };
- F93084370BB93D2800CD0B9E /* DebugMemCompile */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugMemCompile;
- };
- F93084380BB93D2800CD0B9E /* DebugMemCompile */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugMemCompile;
- };
- F93084390BB93D2800CD0B9E /* DebugMemCompile */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugMemCompile;
- };
- F930843A0BB93D2800CD0B9E /* DebugMemCompile */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --enable-symbols=all";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugMemCompile;
- };
- F9359B250DF212DA00E04F67 /* DebugGCov */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- GCC_GENERATE_TEST_COVERAGE_FILES = YES;
- GCC_INSTRUMENT_PROGRAM_FLOW_ARCS = YES;
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- OTHER_LDFLAGS = (
- "$(OTHER_LDFLAGS)",
- "-lgcov",
- );
- PREBINDING = NO;
- };
- name = DebugGCov;
- };
- F9359B260DF212DA00E04F67 /* DebugGCov */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugGCov;
- };
- F9359B270DF212DA00E04F67 /* DebugGCov */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugGCov;
- };
- F9359B280DF212DA00E04F67 /* DebugGCov */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugGCov;
- };
- F95CC8AC09158F3100EA5ACE /* Debug */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = Debug;
- };
- F95CC8AD09158F3100EA5ACE /* Release */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = Release;
- };
- F95CC8AE09158F3100EA5ACE /* DebugNoFixAndContinue */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugNoFixAndContinue;
- };
- F95CC8B109158F3100EA5ACE /* Debug */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CONFIGURE_ARGS = "tcl_cv_cc_visibility_hidden=no $(CONFIGURE_ARGS)";
- GCC_DYNAMIC_NO_PIC = NO;
- GCC_ENABLE_FIX_AND_CONTINUE = YES;
- GCC_PREPROCESSOR_DEFINITIONS = (
- "__private_extern__=extern",
- "$(GCC_PREPROCESSOR_DEFINITIONS)",
- );
- GCC_SYMBOLS_PRIVATE_EXTERN = NO;
- PRODUCT_NAME = tcltest;
- };
- name = Debug;
- };
- F95CC8B209158F3100EA5ACE /* Release */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = Release;
- };
- F95CC8B309158F3100EA5ACE /* DebugNoFixAndContinue */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugNoFixAndContinue;
- };
- F95CC8B609158F3100EA5ACE /* Debug */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = Debug;
- };
- F95CC8B709158F3100EA5ACE /* Release */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = Release;
- };
- F95CC8B809158F3100EA5ACE /* DebugNoFixAndContinue */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugNoFixAndContinue;
- };
- F97258A90A86873D00096C78 /* Debug */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = Debug;
- };
- F97258AA0A86873D00096C78 /* Release */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = Release;
- };
- F97258AB0A86873D00096C78 /* DebugNoFixAndContinue */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugNoFixAndContinue;
- };
- F97258AC0A86873D00096C78 /* ReleaseUniversal */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = ReleaseUniversal;
- };
- F97AED1B0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = Debug64bit;
- };
- F97AED1C0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = Debug64bit;
- };
- F97AED1D0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = Debug64bit;
- };
- F97AED1E0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = "$(NATIVE_ARCH_64_BIT)";
- CONFIGURE_ARGS = "--enable-64bit $(CONFIGURE_ARGS)";
- CPPFLAGS = "-arch $(NATIVE_ARCH_64_BIT) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- PREBINDING = NO;
- };
- name = Debug64bit;
- };
- F987512F0DE7B57E00B1C9EC /* DebugNoCF */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --disable-corefoundation";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugNoCF;
- };
- F98751300DE7B57E00B1C9EC /* DebugNoCF */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugNoCF;
- };
- F98751310DE7B57E00B1C9EC /* DebugNoCF */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugNoCF;
- };
- F98751320DE7B57E00B1C9EC /* DebugNoCF */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugNoCF;
- };
- F98751330DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --disable-threads --disable-corefoundation";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751340DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751350DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751360DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugNoCFUnthreaded;
- };
- F9988AB10D814C6500B6B03B /* Debug gcc40 */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- GCC_VERSION = 4.0;
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = "Debug gcc40";
- };
- F9988AB20D814C6500B6B03B /* Debug gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = "Debug gcc40";
- };
- F9988AB30D814C6500B6B03B /* Debug gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CONFIGURE_ARGS = "tcl_cv_cc_visibility_hidden=no $(CONFIGURE_ARGS)";
- GCC_DYNAMIC_NO_PIC = NO;
- GCC_ENABLE_FIX_AND_CONTINUE = YES;
- GCC_PREPROCESSOR_DEFINITIONS = (
- "__private_extern__=extern",
- "$(GCC_PREPROCESSOR_DEFINITIONS)",
- );
- GCC_SYMBOLS_PRIVATE_EXTERN = NO;
- PRODUCT_NAME = tcltest;
- };
- name = "Debug gcc40";
- };
- F9988AB40D814C6500B6B03B /* Debug gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = "Debug gcc40";
- };
- F9988AB50D814C7500B6B03B /* Debug llvm-gcc */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- GCC = "llvm-gcc";
- GCC_VERSION = com.apple.compilers.llvmgcc42;
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = "Debug llvm-gcc";
- };
- F9988AB60D814C7500B6B03B /* Debug llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = "Debug llvm-gcc";
- };
- F9988AB70D814C7500B6B03B /* Debug llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CONFIGURE_ARGS = "tcl_cv_cc_visibility_hidden=no $(CONFIGURE_ARGS)";
- GCC_DYNAMIC_NO_PIC = NO;
- GCC_ENABLE_FIX_AND_CONTINUE = YES;
- GCC_PREPROCESSOR_DEFINITIONS = (
- "__private_extern__=extern",
- "$(GCC_PREPROCESSOR_DEFINITIONS)",
- );
- GCC_SYMBOLS_PRIVATE_EXTERN = NO;
- PRODUCT_NAME = tcltest;
- };
- name = "Debug llvm-gcc";
- };
- F9988AB80D814C7500B6B03B /* Debug llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = "Debug llvm-gcc";
- };
- F9988BB10D81586D00B6B03B /* ReleaseUniversal gcc40 */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
- buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
- GCC_VERSION = 4.0;
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- PREBINDING = NO;
- };
- name = "ReleaseUniversal gcc40";
- };
- F9988BB20D81586D00B6B03B /* ReleaseUniversal gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = "ReleaseUniversal gcc40";
- };
- F9988BB30D81586D00B6B03B /* ReleaseUniversal gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = "ReleaseUniversal gcc40";
- };
- F9988BB40D81586D00B6B03B /* ReleaseUniversal gcc40 */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = "ReleaseUniversal gcc40";
- };
- F9988BB50D81587400B6B03B /* ReleaseUniversal llvm-gcc */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
- buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
- DEBUG_INFORMATION_FORMAT = dwarf;
- GCC = "llvm-gcc";
- GCC_OPTIMIZATION_LEVEL = 4;
- GCC_VERSION = com.apple.compilers.llvmgcc42;
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- PREBINDING = NO;
- };
- name = "ReleaseUniversal llvm-gcc";
- };
- F9988BB60D81587400B6B03B /* ReleaseUniversal llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = "ReleaseUniversal llvm-gcc";
- };
- F9988BB70D81587400B6B03B /* ReleaseUniversal llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = "ReleaseUniversal llvm-gcc";
- };
- F9988BB80D81587400B6B03B /* ReleaseUniversal llvm-gcc */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = "ReleaseUniversal llvm-gcc";
- };
- F99EE73B0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugUnthreaded;
- };
- F99EE73C0BE835310060D4AF /* DebugLeaks */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugLeaks;
- };
- F99EE73D0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugUnthreaded;
- };
- F99EE73E0BE835310060D4AF /* DebugLeaks */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugLeaks;
- };
- F99EE73F0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugUnthreaded;
- };
- F99EE7400BE835310060D4AF /* DebugLeaks */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugLeaks;
- };
- F99EE7410BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --disable-threads";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugUnthreaded;
- };
- F99EE7420BE835310060D4AF /* DebugLeaks */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- GCC_PREPROCESSOR_DEFINITIONS = (
- PURIFY,
- "$(GCC_PREPROCESSOR_DEFINITIONS)",
- );
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugLeaks;
- };
- F9EEED960C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = ReleaseUniversal10.5SDK;
- };
- F9EEED970C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = ReleaseUniversal10.5SDK;
- };
- F9EEED980C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = ReleaseUniversal10.5SDK;
- };
- F9EEED990C2FEFD300396116 /* ReleaseUniversal10.5SDK */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
- buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
- CPPFLAGS = "-isysroot $(SDKROOT) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.5;
- PREBINDING = NO;
- SDKROOT = macosx10.5;
- };
- name = ReleaseUniversal10.5SDK;
- };
-/* End XCBuildConfiguration section */
-
-/* Begin XCConfigurationList section */
- F95CC8AB09158F3100EA5ACE /* Build configuration list for PBXNativeTarget "Tcl" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- F95CC8AC09158F3100EA5ACE /* Debug */,
- F9988AB60D814C7500B6B03B /* Debug llvm-gcc */,
- F9988AB20D814C6500B6B03B /* Debug gcc40 */,
- F95CC8AE09158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE73B0BE835310060D4AF /* DebugUnthreaded */,
- F98751300DE7B57E00B1C9EC /* DebugNoCF */,
- F98751340DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
- F93084370BB93D2800CD0B9E /* DebugMemCompile */,
- F99EE73C0BE835310060D4AF /* DebugLeaks */,
- F9359B260DF212DA00E04F67 /* DebugGCov */,
- F97AED1B0B660B2100310EA2 /* Debug64bit */,
- F95CC8AD09158F3100EA5ACE /* Release */,
- F91BCC4F093152310042A6BF /* ReleaseUniversal */,
- F9988BB60D81587400B6B03B /* ReleaseUniversal llvm-gcc */,
- F9988BB20D81586D00B6B03B /* ReleaseUniversal gcc40 */,
- F9EEED960C2FEFD300396116 /* ReleaseUniversal10.5SDK */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Debug;
- };
- F95CC8B009158F3100EA5ACE /* Build configuration list for PBXNativeTarget "tcltest" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- F95CC8B109158F3100EA5ACE /* Debug */,
- F9988AB70D814C7500B6B03B /* Debug llvm-gcc */,
- F9988AB30D814C6500B6B03B /* Debug gcc40 */,
- F95CC8B309158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE73D0BE835310060D4AF /* DebugUnthreaded */,
- F98751310DE7B57E00B1C9EC /* DebugNoCF */,
- F98751350DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
- F93084380BB93D2800CD0B9E /* DebugMemCompile */,
- F99EE73E0BE835310060D4AF /* DebugLeaks */,
- F9359B270DF212DA00E04F67 /* DebugGCov */,
- F97AED1C0B660B2100310EA2 /* Debug64bit */,
- F95CC8B209158F3100EA5ACE /* Release */,
- F91BCC50093152310042A6BF /* ReleaseUniversal */,
- F9988BB70D81587400B6B03B /* ReleaseUniversal llvm-gcc */,
- F9988BB30D81586D00B6B03B /* ReleaseUniversal gcc40 */,
- F9EEED970C2FEFD300396116 /* ReleaseUniversal10.5SDK */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Debug;
- };
- F95CC8B509158F3100EA5ACE /* Build configuration list for PBXProject "Tcl" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- F95CC8B609158F3100EA5ACE /* Debug */,
- F9988AB50D814C7500B6B03B /* Debug llvm-gcc */,
- F9988AB10D814C6500B6B03B /* Debug gcc40 */,
- F95CC8B809158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE7410BE835310060D4AF /* DebugUnthreaded */,
- F987512F0DE7B57E00B1C9EC /* DebugNoCF */,
- F98751330DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
- F930843A0BB93D2800CD0B9E /* DebugMemCompile */,
- F99EE7420BE835310060D4AF /* DebugLeaks */,
- F9359B250DF212DA00E04F67 /* DebugGCov */,
- F97AED1E0B660B2100310EA2 /* Debug64bit */,
- F95CC8B709158F3100EA5ACE /* Release */,
- F91BCC51093152310042A6BF /* ReleaseUniversal */,
- F9988BB50D81587400B6B03B /* ReleaseUniversal llvm-gcc */,
- F9988BB10D81586D00B6B03B /* ReleaseUniversal gcc40 */,
- F9EEED990C2FEFD300396116 /* ReleaseUniversal10.5SDK */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Debug;
- };
- F97258A80A86873D00096C78 /* Build configuration list for PBXNativeTarget "tests" */ = {
- isa = XCConfigurationList;
- buildConfigurations = (
- F97258A90A86873D00096C78 /* Debug */,
- F9988AB80D814C7500B6B03B /* Debug llvm-gcc */,
- F9988AB40D814C6500B6B03B /* Debug gcc40 */,
- F97258AB0A86873D00096C78 /* DebugNoFixAndContinue */,
- F99EE73F0BE835310060D4AF /* DebugUnthreaded */,
- F98751320DE7B57E00B1C9EC /* DebugNoCF */,
- F98751360DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
- F93084390BB93D2800CD0B9E /* DebugMemCompile */,
- F99EE7400BE835310060D4AF /* DebugLeaks */,
- F9359B280DF212DA00E04F67 /* DebugGCov */,
- F97AED1D0B660B2100310EA2 /* Debug64bit */,
- F97258AA0A86873D00096C78 /* Release */,
- F97258AC0A86873D00096C78 /* ReleaseUniversal */,
- F9988BB80D81587400B6B03B /* ReleaseUniversal llvm-gcc */,
- F9988BB40D81586D00B6B03B /* ReleaseUniversal gcc40 */,
- F9EEED980C2FEFD300396116 /* ReleaseUniversal10.5SDK */,
- );
- defaultConfigurationIsVisible = 0;
- defaultConfigurationName = Debug;
- };
-/* End XCConfigurationList section */
- };
- rootObject = 08FB7793FE84155DC02AAC07 /* Project object */;
-}
diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj
index da16424..cdc97c6 100644
--- a/macosx/Tcl.xcodeproj/project.pbxproj
+++ b/macosx/Tcl.xcodeproj/project.pbxproj
@@ -140,7 +140,6 @@
F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
- F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D008F272B3004A47F5 /* bn_reverse.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
@@ -224,7 +223,6 @@
F96437C90EF0D4B2003F468E /* tclZlib.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclZlib.c; sourceTree = "<group>"; };
F96437E60EF0D652003F468E /* libz.dylib */ = {isa = PBXFileReference; lastKnownFileType = "compiled.mach-o.dylib"; name = libz.dylib; path = /usr/lib/libz.dylib; sourceTree = "<absolute>"; };
F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; };
- F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; };
F96D3DFB08F272A4004A47F5 /* changes */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = changes; sourceTree = "<group>"; };
F96D3DFD08F272A4004A47F5 /* Access.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = Access.3; sourceTree = "<group>"; };
F96D3DFE08F272A4004A47F5 /* AddErrInfo.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = AddErrInfo.3; sourceTree = "<group>"; };
@@ -377,7 +375,7 @@
F96D3E9108F272A6004A47F5 /* rename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = rename.n; sourceTree = "<group>"; };
F96D3E9208F272A6004A47F5 /* return.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = return.n; sourceTree = "<group>"; };
F96D3E9308F272A6004A47F5 /* safe.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = safe.n; sourceTree = "<group>"; };
- F96D3E9408F272A6004A47F5 /* SaveResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveResult.3; sourceTree = "<group>"; };
+ F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveInterpState.3; sourceTree = "<group>"; };
F96D3E9508F272A6004A47F5 /* scan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = scan.n; sourceTree = "<group>"; };
F96D3E9608F272A6004A47F5 /* seek.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = seek.n; sourceTree = "<group>"; };
F96D3E9708F272A6004A47F5 /* set.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = set.n; sourceTree = "<group>"; };
@@ -394,7 +392,7 @@
F96D3EA208F272A7004A47F5 /* split.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = split.n; sourceTree = "<group>"; };
F96D3EA308F272A7004A47F5 /* SplitList.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitList.3; sourceTree = "<group>"; };
F96D3EA408F272A7004A47F5 /* SplitPath.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SplitPath.3; sourceTree = "<group>"; };
- F96D3EA508F272A7004A47F5 /* StaticPkg.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticPkg.3; sourceTree = "<group>"; };
+ F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StaticLibrary.3; sourceTree = "<group>"; };
F96D3EA608F272A7004A47F5 /* StdChannels.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StdChannels.3; sourceTree = "<group>"; };
F96D3EA708F272A7004A47F5 /* string.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = string.n; sourceTree = "<group>"; };
F96D3EA808F272A7004A47F5 /* StringObj.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = StringObj.3; sourceTree = "<group>"; };
@@ -534,7 +532,6 @@
F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
- F96D3F3708F272A7004A47F5 /* tommath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath.h; sourceTree = "<group>"; };
F96D3F3908F272A8004A47F5 /* auto.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = auto.tcl; sourceTree = "<group>"; };
F96D3F3A08F272A8004A47F5 /* clock.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = clock.tcl; sourceTree = "<group>"; };
F96D3F3C08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
@@ -577,6 +574,7 @@
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = "<group>"; };
+ F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_d_ex.c; sourceTree = "<group>"; };
F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = "<group>"; };
F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = "<group>"; };
F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = "<group>"; };
@@ -611,7 +609,6 @@
F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = "<group>"; };
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
- F96D42D008F272B3004A47F5 /* bn_reverse.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_reverse.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
@@ -765,30 +762,22 @@
F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D43D308F272B8004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = fix_tommath_h.tcl; sourceTree = "<group>"; };
+ F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D442508F272B8004A47F5 /* genStubs.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = genStubs.tcl; sourceTree = "<group>"; };
F96D442708F272B8004A47F5 /* index.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = index.tcl; sourceTree = "<group>"; };
F96D442808F272B8004A47F5 /* installData.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = installData.tcl; sourceTree = "<group>"; };
F96D442908F272B8004A47F5 /* loadICU.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = loadICU.tcl; sourceTree = "<group>"; };
F96D442A08F272B8004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = makeTestCases.tcl; sourceTree = "<group>"; };
- F96D442C08F272B8004A47F5 /* man2help.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help.tcl; sourceTree = "<group>"; };
- F96D442D08F272B8004A47F5 /* man2help2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help2.tcl; sourceTree = "<group>"; };
- F96D442E08F272B8004A47F5 /* man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html.tcl; sourceTree = "<group>"; };
- F96D442F08F272B8004A47F5 /* man2html1.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html1.tcl; sourceTree = "<group>"; };
- F96D443008F272B8004A47F5 /* man2html2.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2html2.tcl; sourceTree = "<group>"; };
- F96D443108F272B8004A47F5 /* man2tcl.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = man2tcl.c; sourceTree = "<group>"; };
F96D443208F272B8004A47F5 /* README */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = regexpTestLib.tcl; sourceTree = "<group>"; };
- F96D443508F272B8004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = "tcltk-man2html.tcl"; sourceTree = "<group>"; };
F96D443A08F272B9004A47F5 /* tclZIC.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = tclZIC.tcl; sourceTree = "<group>"; };
F96D443B08F272B9004A47F5 /* uniClass.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniClass.tcl; sourceTree = "<group>"; };
F96D443C08F272B9004A47F5 /* uniParse.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = uniParse.tcl; sourceTree = "<group>"; };
F96D444008F272B9004A47F5 /* aclocal.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = aclocal.m4; sourceTree = "<group>"; };
F96D444108F272B9004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D444208F272B9004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
+ F96D444208F272B9004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D444408F272B9004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D444508F272B9004A47F5 /* pkga.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkga.c; sourceTree = "<group>"; };
F96D444608F272B9004A47F5 /* pkgb.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = pkgb.c; sourceTree = "<group>"; };
@@ -832,7 +821,7 @@
F96D447208F272BA004A47F5 /* cat.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = cat.c; sourceTree = "<group>"; };
F96D447308F272BA004A47F5 /* coffbase.txt */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = coffbase.txt; sourceTree = "<group>"; };
F96D447408F272BA004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
- F96D447508F272BA004A47F5 /* configure.in */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.in; sourceTree = "<group>"; };
+ F96D447508F272BA004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
F96D447708F272BA004A47F5 /* Makefile.in */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = Makefile.in; sourceTree = "<group>"; };
F96D447808F272BA004A47F5 /* makefile.vc */ = {isa = PBXFileReference; explicitFileType = sourcecode.make; fileEncoding = 4; path = makefile.vc; sourceTree = "<group>"; };
F96D447908F272BA004A47F5 /* nmakehlp.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = nmakehlp.c; sourceTree = "<group>"; };
@@ -841,7 +830,6 @@
F96D447D08F272BA004A47F5 /* stub16.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = stub16.c; sourceTree = "<group>"; };
F96D447E08F272BA004A47F5 /* tcl.dsp */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsp; sourceTree = "<group>"; };
F96D447F08F272BA004A47F5 /* tcl.dsw */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.dsw; sourceTree = "<group>"; };
- F96D448008F272BA004A47F5 /* tcl.hpj.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.hpj.in; sourceTree = "<group>"; };
F96D448108F272BA004A47F5 /* tcl.m4 */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = tcl.m4; sourceTree = "<group>"; };
F96D448208F272BA004A47F5 /* tcl.rc */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = tcl.rc; sourceTree = "<group>"; };
F96D448308F272BA004A47F5 /* tclAppInit.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclAppInit.c; sourceTree = "<group>"; };
@@ -961,7 +949,6 @@
F96D3DFC08F272A4004A47F5 /* doc */,
F96D43D008F272B8004A47F5 /* tools */,
F9183E690EFC81560030B814 /* pkgs */,
- F96D3DFA08F272A4004A47F5 /* ChangeLog */,
F96D3DFB08F272A4004A47F5 /* changes */,
F96D434308F272B5004A47F5 /* README */,
F96D432B08F272B4004A47F5 /* license.terms */,
@@ -1134,7 +1121,7 @@
F96D3E9108F272A6004A47F5 /* rename.n */,
F96D3E9208F272A6004A47F5 /* return.n */,
F96D3E9308F272A6004A47F5 /* safe.n */,
- F96D3E9408F272A6004A47F5 /* SaveResult.3 */,
+ F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */,
F96D3E9508F272A6004A47F5 /* scan.n */,
F96D3E9608F272A6004A47F5 /* seek.n */,
F93599D80DF1F98300E04F67 /* self.n */,
@@ -1152,7 +1139,7 @@
F96D3EA208F272A7004A47F5 /* split.n */,
F96D3EA308F272A7004A47F5 /* SplitList.3 */,
F96D3EA408F272A7004A47F5 /* SplitPath.3 */,
- F96D3EA508F272A7004A47F5 /* StaticPkg.3 */,
+ F96D3EA508F272A7004A47F5 /* StaticLibrary.3 */,
F96D3EA608F272A7004A47F5 /* StdChannels.3 */,
F96D3EA708F272A7004A47F5 /* string.n */,
F96D3EA808F272A7004A47F5 /* StringObj.3 */,
@@ -1322,7 +1309,6 @@
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
- F96D3F3708F272A7004A47F5 /* tommath.h */,
);
path = generic;
sourceTree = "<group>";
@@ -1436,6 +1422,7 @@
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */,
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */,
F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */,
+ F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */,
F96D428708F272B3004A47F5 /* bn_mp_grow.c */,
F96D428808F272B3004A47F5 /* bn_mp_init.c */,
F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */,
@@ -1470,7 +1457,6 @@
F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */,
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */,
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */,
- F96D42D008F272B3004A47F5 /* bn_reverse.c */,
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */,
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */,
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */,
@@ -1657,24 +1643,13 @@
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
- F96D43D208F272B8004A47F5 /* configure */,
- F96D43D308F272B8004A47F5 /* configure.in */,
- F96D442408F272B8004A47F5 /* fix_tommath_h.tcl */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
F96D442908F272B8004A47F5 /* loadICU.tcl */,
- F96D442A08F272B8004A47F5 /* Makefile.in */,
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */,
- F96D442C08F272B8004A47F5 /* man2help.tcl */,
- F96D442D08F272B8004A47F5 /* man2help2.tcl */,
- F96D442E08F272B8004A47F5 /* man2html.tcl */,
- F96D442F08F272B8004A47F5 /* man2html1.tcl */,
- F96D443008F272B8004A47F5 /* man2html2.tcl */,
- F96D443108F272B8004A47F5 /* man2tcl.c */,
F96D443208F272B8004A47F5 /* README */,
F96D443308F272B8004A47F5 /* regexpTestLib.tcl */,
- F96D443508F272B8004A47F5 /* tcl.hpj.in */,
F96D443908F272B9004A47F5 /* tcltk-man2html.tcl */,
F96D443A08F272B9004A47F5 /* tclZIC.tcl */,
F92D7F100DE777240033A13A /* tsdPerf.tcl */,
@@ -1689,7 +1664,7 @@
children = (
F96D444008F272B9004A47F5 /* aclocal.m4 */,
F96D444108F272B9004A47F5 /* configure */,
- F96D444208F272B9004A47F5 /* configure.in */,
+ F96D444208F272B9004A47F5 /* configure.ac */,
F96D444308F272B9004A47F5 /* dltest */,
F96D444D08F272B9004A47F5 /* install-sh */,
F96D444E08F272B9004A47F5 /* installManPage */,
@@ -1750,7 +1725,7 @@
F96D447208F272BA004A47F5 /* cat.c */,
F96D447308F272BA004A47F5 /* coffbase.txt */,
F96D447408F272BA004A47F5 /* configure */,
- F96D447508F272BA004A47F5 /* configure.in */,
+ F96D447508F272BA004A47F5 /* configure.ac */,
F96D447708F272BA004A47F5 /* Makefile.in */,
F96D447808F272BA004A47F5 /* makefile.vc */,
F96D447908F272BA004A47F5 /* nmakehlp.c */,
@@ -1759,7 +1734,6 @@
F96D447D08F272BA004A47F5 /* stub16.c */,
F96D447E08F272BA004A47F5 /* tcl.dsp */,
F96D447F08F272BA004A47F5 /* tcl.dsw */,
- F96D448008F272BA004A47F5 /* tcl.hpj.in */,
F96D448108F272BA004A47F5 /* tcl.m4 */,
F96D448208F272BA004A47F5 /* tcl.rc */,
F96D448308F272BA004A47F5 /* tclAppInit.c */,
@@ -1936,7 +1910,7 @@
);
inputPaths = (
"$(TCL_SRCROOT)/macosx/configure.ac",
- "$(TCL_SRCROOT)/unix/configure.in",
+ "$(TCL_SRCROOT)/unix/configure.ac",
"$(TCL_SRCROOT)/unix/tcl.m4",
"$(TCL_SRCROOT)/unix/aclocal.m4",
"$(TCL_SRCROOT)/unix/tclConfig.sh.in",
@@ -1949,7 +1923,7 @@
);
runOnlyForDeploymentPostprocessing = 0;
shellPath = /bin/bash;
- shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.in -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n";
+ shellScript = "## tcl configure shell script phase\n\ncd \"${TCL_SRCROOT}\"/macosx &&\nif [ configure.ac -nt configure -o ../unix/configure.ac -nt configure -o ../unix/tcl.m4 -nt configure -o ../unix/aclocal.m4 -nt configure ]; then\n echo \"Running autoconf & autoheader in tcl/macosx\"\n rm -rf autom4te.cache\n ${AUTOCONF:-${DEVELOPER_DIR}/usr/bin/autoconf} && ${AUTOHEADER:-${DEVELOPER_DIR}/usr/bin/autoheader} || exit $?\n rm -rf autom4te.cache\nfi\n\ncd \"${DERIVED_FILE_DIR}\" && mkdir -p tcl && cd tcl &&\nif [ \"${TCL_SRCROOT}\"/macosx/configure -nt config.status ]; then\n echo \"Configuring Tcl\"\n CC=$(xcrun -find ${GCC} || echo ${GCC})\n \"${TCL_SRCROOT}\"/macosx/configure --cache-file=../config.cache --prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} --mandir=${MANDIR} --includedir=${INCLUDEDIR} --disable-shared CC=${CC} LD=${CC} ${CONFIGURE_ARGS}\nelse\n ./config.status\nfi\n";
showEnvVarsInLog = 0;
};
/* End PBXShellScriptBuildPhase section */
@@ -2065,6 +2039,7 @@
F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */,
F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */,
F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */,
+ F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */,
F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */,
F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */,
F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */,
@@ -2099,7 +2074,6 @@
F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */,
F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */,
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */,
- F96D494E08F272C3004A47F5 /* bn_reverse.c in Sources */,
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */,
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */,
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */,
@@ -2155,8 +2129,8 @@
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
+ ARCHS = "$(ARCHS_STANDARD_64_BIT)";
+ CFLAGS = "-arch x86_64 -arch arm64 $(CFLAGS)";
MACOSX_DEPLOYMENT_TARGET = 10.6;
PREBINDING = NO;
};
@@ -2393,44 +2367,6 @@
};
name = ReleaseUniversal;
};
- F97AED1B0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = Debug64bit;
- };
- F97AED1C0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = Debug64bit;
- };
- F97AED1D0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = Debug64bit;
- };
- F97AED1E0B660B2100310EA2 /* Debug64bit */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = "$(NATIVE_ARCH_64_BIT)";
- CONFIGURE_ARGS = "--enable-64bit $(CONFIGURE_ARGS)";
- CPPFLAGS = "-arch $(NATIVE_ARCH_64_BIT) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
- PREBINDING = NO;
- };
- name = Debug64bit;
- };
F987512F0DE7B57E00B1C9EC /* DebugNoCF */ = {
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
@@ -2473,48 +2409,6 @@
};
name = DebugNoCF;
};
- F98751330DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --disable-threads --disable-corefoundation";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751340DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751350DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugNoCFUnthreaded;
- };
- F98751360DE7B5A200B1C9EC /* DebugNoCFUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugNoCFUnthreaded;
- };
F9988AB10D814C6500B6B03B /* Debug gcc40 */ = {
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
@@ -2620,8 +2514,8 @@
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
+ ARCHS = "$(ARCHS_STANDARD_64_BIT)";
+ CFLAGS = "-arch x86_64 -arch arm64 $(CFLAGS)";
GCC_VERSION = 4.0;
MACOSX_DEPLOYMENT_TARGET = 10.6;
PREBINDING = NO;
@@ -2658,12 +2552,11 @@
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
+ ARCHS = "$(ARCHS_STANDARD_64_BIT)";
+ CFLAGS = "-arch x86_64 -arch arm64 $(CFLAGS)";
DEBUG_INFORMATION_FORMAT = dwarf;
GCC = "llvm-gcc";
GCC_OPTIMIZATION_LEVEL = 4;
- "GCC_OPTIMIZATION_LEVEL[arch=ppc]" = s;
GCC_VERSION = com.apple.compilers.llvmgcc42;
MACOSX_DEPLOYMENT_TARGET = 10.6;
PREBINDING = NO;
@@ -2696,14 +2589,6 @@
};
name = "ReleaseUniversal llvm-gcc";
};
- F99EE73B0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tclsh;
- SKIP_INSTALL = NO;
- };
- name = DebugUnthreaded;
- };
F99EE73C0BE835310060D4AF /* DebugLeaks */ = {
isa = XCBuildConfiguration;
buildSettings = {
@@ -2712,13 +2597,6 @@
};
name = DebugLeaks;
};
- F99EE73D0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- PRODUCT_NAME = tcltest;
- };
- name = DebugUnthreaded;
- };
F99EE73E0BE835310060D4AF /* DebugLeaks */ = {
isa = XCBuildConfiguration;
buildSettings = {
@@ -2726,17 +2604,6 @@
};
name = DebugLeaks;
};
- F99EE73F0BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- buildSettings = {
- CODE_SIGN_IDENTITY = "";
- PRODUCT_NAME = tests;
- TCLTEST_OPTIONS = "";
- TCL_LIBRARY = "$(TCL_SRCROOT)/library";
- TEST_RIG = "$(OBJROOT)/$(CONFIGURATION)/tcltest";
- };
- name = DebugUnthreaded;
- };
F99EE7400BE835310060D4AF /* DebugLeaks */ = {
isa = XCBuildConfiguration;
buildSettings = {
@@ -2748,22 +2615,6 @@
};
name = DebugLeaks;
};
- F99EE7410BE835310060D4AF /* DebugUnthreaded */ = {
- isa = XCBuildConfiguration;
- baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
- buildSettings = {
- ARCHS = (
- "$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
- );
- CONFIGURE_ARGS = "$(CONFIGURE_ARGS) --disable-threads";
- CPPFLAGS = "-arch $(CURRENT_ARCH) $(CPPFLAGS)";
- MACOSX_DEPLOYMENT_TARGET = 10.6;
- ONLY_ACTIVE_ARCH = YES;
- PREBINDING = NO;
- };
- name = DebugUnthreaded;
- };
F99EE7420BE835310060D4AF /* DebugLeaks */ = {
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE8330B65C87F00310EA2 /* Tcl-Debug.xcconfig */;
@@ -2841,9 +2692,8 @@
buildSettings = {
ARCHS = (
"$(NATIVE_ARCH_64_BIT)",
- "$(NATIVE_ARCH_32_BIT)",
);
- CFLAGS = "-arch i386 -arch x86_64 $(CFLAGS)";
+ CFLAGS = "-arch x86_64 -arch arm64 $(CFLAGS)";
DEBUG_INFORMATION_FORMAT = dwarf;
GCC = clang;
GCC_OPTIMIZATION_LEVEL = 4;
@@ -2909,8 +2759,8 @@
isa = XCBuildConfiguration;
baseConfigurationReference = F97AE82B0B65C69B00310EA2 /* Tcl-Release.xcconfig */;
buildSettings = {
- ARCHS = "$(ARCHS_STANDARD_32_64_BIT)";
- CFLAGS = "-arch i386 -arch x86_64 -arch ppc $(CFLAGS)";
+ ARCHS = "$(ARCHS_STANDARD_64_BIT)";
+ CFLAGS = "-arch x86_64 -arch arm64 $(CFLAGS)";
CPPFLAGS = "-isysroot $(SDKROOT) $(CPPFLAGS)";
MACOSX_DEPLOYMENT_TARGET = 10.5;
PREBINDING = NO;
@@ -2929,13 +2779,10 @@
F9988AB60D814C7500B6B03B /* Debug llvm-gcc */,
F9988AB20D814C6500B6B03B /* Debug gcc40 */,
F95CC8AE09158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE73B0BE835310060D4AF /* DebugUnthreaded */,
F98751300DE7B57E00B1C9EC /* DebugNoCF */,
- F98751340DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
F93084370BB93D2800CD0B9E /* DebugMemCompile */,
F99EE73C0BE835310060D4AF /* DebugLeaks */,
F9359B260DF212DA00E04F67 /* DebugGCov */,
- F97AED1B0B660B2100310EA2 /* Debug64bit */,
F95CC8AD09158F3100EA5ACE /* Release */,
F91BCC4F093152310042A6BF /* ReleaseUniversal */,
F9A9D1F40FC77799002A2BE3 /* ReleaseUniversal clang */,
@@ -2954,13 +2801,10 @@
F9988AB70D814C7500B6B03B /* Debug llvm-gcc */,
F9988AB30D814C6500B6B03B /* Debug gcc40 */,
F95CC8B309158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE73D0BE835310060D4AF /* DebugUnthreaded */,
F98751310DE7B57E00B1C9EC /* DebugNoCF */,
- F98751350DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
F93084380BB93D2800CD0B9E /* DebugMemCompile */,
F99EE73E0BE835310060D4AF /* DebugLeaks */,
F9359B270DF212DA00E04F67 /* DebugGCov */,
- F97AED1C0B660B2100310EA2 /* Debug64bit */,
F95CC8B209158F3100EA5ACE /* Release */,
F91BCC50093152310042A6BF /* ReleaseUniversal */,
F9A9D1F50FC77799002A2BE3 /* ReleaseUniversal clang */,
@@ -2979,13 +2823,10 @@
F9988AB50D814C7500B6B03B /* Debug llvm-gcc */,
F9988AB10D814C6500B6B03B /* Debug gcc40 */,
F95CC8B809158F3100EA5ACE /* DebugNoFixAndContinue */,
- F99EE7410BE835310060D4AF /* DebugUnthreaded */,
F987512F0DE7B57E00B1C9EC /* DebugNoCF */,
- F98751330DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
F930843A0BB93D2800CD0B9E /* DebugMemCompile */,
F99EE7420BE835310060D4AF /* DebugLeaks */,
F9359B250DF212DA00E04F67 /* DebugGCov */,
- F97AED1E0B660B2100310EA2 /* Debug64bit */,
F95CC8B709158F3100EA5ACE /* Release */,
F91BCC51093152310042A6BF /* ReleaseUniversal */,
F9A9D1F30FC77799002A2BE3 /* ReleaseUniversal clang */,
@@ -3004,13 +2845,10 @@
F9988AB80D814C7500B6B03B /* Debug llvm-gcc */,
F9988AB40D814C6500B6B03B /* Debug gcc40 */,
F97258AB0A86873D00096C78 /* DebugNoFixAndContinue */,
- F99EE73F0BE835310060D4AF /* DebugUnthreaded */,
F98751320DE7B57E00B1C9EC /* DebugNoCF */,
- F98751360DE7B5A200B1C9EC /* DebugNoCFUnthreaded */,
F93084390BB93D2800CD0B9E /* DebugMemCompile */,
F99EE7400BE835310060D4AF /* DebugLeaks */,
F9359B280DF212DA00E04F67 /* DebugGCov */,
- F97AED1D0B660B2100310EA2 /* Debug64bit */,
F97258AA0A86873D00096C78 /* Release */,
F97258AC0A86873D00096C78 /* ReleaseUniversal */,
F9A9D1F60FC77799002A2BE3 /* ReleaseUniversal clang */,
diff --git a/macosx/configure.ac b/macosx/configure.ac
index f7a8bb3..6b1e3ac 100644
--- a/macosx/configure.ac
+++ b/macosx/configure.ac
@@ -8,4 +8,4 @@ dnl include the configure sources from ../unix:
m4_include(../unix/aclocal.m4)
m4_define(SC_USE_CONFIG_HEADERS)
-m4_include(../unix/configure.in)
+m4_include(../unix/configure.ac)
diff --git a/macosx/tclMacOSXBundle.c b/macosx/tclMacOSXBundle.c
index beef2ed..6707ef0 100644
--- a/macosx/tclMacOSXBundle.c
+++ b/macosx/tclMacOSXBundle.c
@@ -4,14 +4,15 @@
* This file implements functions that inspect CFBundle structures on
* MacOS X.
*
- * Copyright 2001-2009, Apple Inc.
- * Copyright (c) 2003-2009 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2001-2009 Apple Inc.
+ * Copyright © 2003-2009 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclPort.h"
+#include "tclInt.h"
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
@@ -162,6 +163,7 @@ OpenResourceMap(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
#undef Tcl_MacOSXOpenBundleResources
int
Tcl_MacOSXOpenBundleResources(
@@ -174,6 +176,7 @@ Tcl_MacOSXOpenBundleResources(
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL,
hasResourceFile, maxPathLen, libraryPath);
}
+#endif
/*
*----------------------------------------------------------------------
@@ -198,7 +201,7 @@ Tcl_MacOSXOpenBundleResources(
int
Tcl_MacOSXOpenVersionedBundleResources(
- Tcl_Interp *interp,
+ TCL_UNUSED(Tcl_Interp *),
const char *bundleName,
const char *bundleVersion,
int hasResourceFile,
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 064f9e3..eb40b3b 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -4,7 +4,7 @@
* This file implements the MacOSX specific portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright (c) 2003-2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 2003-2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -192,18 +192,18 @@ TclMacOSXGetFileAttribute(
OSSwapBigToHostInt32(finder->type));
break;
case MACOSX_HIDDEN_ATTRIBUTE:
- *attributePtrPtr = Tcl_NewBooleanObj(
+ TclNewIntObj(*attributePtrPtr,
(finder->fdFlags & kFinfoIsInvisible) != 0);
break;
case MACOSX_RSRCLENGTH_ATTRIBUTE:
- *attributePtrPtr = Tcl_NewWideIntObj(*rsrcForkSize);
+ TclNewIntObj(*attributePtrPtr, *rsrcForkSize);
break;
}
return TCL_OK;
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL);
return TCL_ERROR;
#endif /* HAVE_GETATTRLIST */
}
@@ -335,7 +335,7 @@ TclMacOSXSetFileAttribute(
if (newRsrcForkSize != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"setting nonzero rsrclength not supported", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL);
return TCL_ERROR;
}
@@ -344,8 +344,8 @@ TclMacOSXSetFileAttribute(
*/
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, native, -1);
- Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1);
+ Tcl_DStringAppend(&ds, native, TCL_INDEX_NONE);
+ Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE);
result = truncate(Tcl_DStringValue(&ds), 0);
if (result != 0) {
@@ -376,7 +376,7 @@ TclMacOSXSetFileAttribute(
#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Mac OS X file attributes not supported", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", (void *)NULL);
return TCL_ERROR;
#endif
}
@@ -459,11 +459,11 @@ TclMacOSXCopyFileAttributes(
*/
Tcl_DStringInit(&srcBuf);
- Tcl_DStringAppend(&srcBuf, src, -1);
- Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, -1);
+ Tcl_DStringAppend(&srcBuf, src, TCL_INDEX_NONE);
+ Tcl_DStringAppend(&srcBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE);
Tcl_DStringInit(&dstBuf);
- Tcl_DStringAppend(&dstBuf, dst, -1);
- Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, -1);
+ Tcl_DStringAppend(&dstBuf, dst, TCL_INDEX_NONE);
+ Tcl_DStringAppend(&dstBuf, _PATH_RSRCFORKSPEC, TCL_INDEX_NONE);
/*
* Do the copy.
@@ -577,10 +577,10 @@ GetOSTypeFromObj(
{
int result = TCL_OK;
- if (objPtr->typePtr != &tclOSTypeType) {
+ if (!TclHasInternalRep(objPtr, &tclOSTypeType)) {
result = SetOSTypeFromAny(interp, objPtr);
}
- *osTypePtr = (OSType) objPtr->internalRep.longValue;
+ *osTypePtr = (OSType) objPtr->internalRep.wideValue;
return result;
}
@@ -609,7 +609,7 @@ NewOSTypeObj(
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = (long) osType;
+ objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
objPtr->typePtr = &tclOSTypeType;
return objPtr;
}
@@ -636,18 +636,18 @@ SetOSTypeFromAny(
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
const char *string;
- int length, result = TCL_OK;
+ int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_UtfToExternalDString(encoding, string, length, &ds);
+ string = TclGetString(objPtr);
+ Tcl_UtfToExternalDString(encoding, string, objPtr->length, &ds);
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected Macintosh OS type but got \"%s\": ", string));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", (void *)NULL);
}
result = TCL_ERROR;
} else {
@@ -659,8 +659,8 @@ SetOSTypeFromAny(
(OSType) bytes[1] << 16 |
(OSType) bytes[2] << 8 |
(OSType) bytes[3];
- TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = (long) osType;
+ TclFreeInternalRep(objPtr);
+ objPtr->internalRep.wideValue = (Tcl_WideInt) osType;
objPtr->typePtr = &tclOSTypeType;
}
Tcl_DStringFree(&ds);
@@ -692,24 +692,28 @@ UpdateStringOfOSType(
Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
- char string[5];
- OSType osType = (OSType) objPtr->internalRep.longValue;
- Tcl_DString ds;
- Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
- unsigned len;
-
- string[0] = (char) (osType >> 24);
- string[1] = (char) (osType >> 16);
- string[2] = (char) (osType >> 8);
- string[3] = (char) (osType);
- string[4] = '\0';
- Tcl_ExternalToUtfDString(encoding, string, -1, &ds);
- len = (unsigned) Tcl_DStringLength(&ds) + 1;
- objPtr->bytes = ckalloc(len);
- memcpy(objPtr->bytes, Tcl_DStringValue(&ds), len);
- objPtr->length = Tcl_DStringLength(&ds);
- Tcl_DStringFree(&ds);
+ const int size = TCL_UTF_MAX * 4;
+ char *dst = Tcl_InitStringRep(objPtr, NULL, size);
+ OSType osType = (OSType) objPtr->internalRep.wideValue;
+ int written = 0;
+ Tcl_Encoding encoding;
+ char src[5];
+
+ TclOOM(dst, size);
+
+ src[0] = (char) (osType >> 24);
+ src[1] = (char) (osType >> 16);
+ src[2] = (char) (osType >> 8);
+ src[3] = (char) (osType);
+ src[4] = '\0';
+
+ encoding = Tcl_GetEncoding(NULL, "macRoman");
+ Tcl_ExternalToUtf(NULL, encoding, src, TCL_INDEX_NONE, /* flags */ 0,
+ /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL,
+ /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL);
Tcl_FreeEncoding(encoding);
+
+ (void)Tcl_InitStringRep(objPtr, NULL, written);
}
/*
diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c
index 27d4525..169c7b9 100644
--- a/macosx/tclMacOSXNotify.c
+++ b/macosx/tclMacOSXNotify.c
@@ -5,9 +5,9 @@
* based notifier, which is the lowest-level part of the Tcl event loop.
* This file works together with generic/tclNotify.c.
*
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright 2001-2009, Apple Inc.
- * Copyright (c) 2005-2009 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright © 1995-1997 Sun Microsystems, Inc.
+ * Copyright © 2001-2009, Apple Inc.
+ * Copyright © 2005-2009 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -97,13 +97,54 @@ SpinLockLockInit(void)
Tcl_Panic("SpinLockLockInit: no spinlock API available");
}
}
-#define SpinLockLock(p) lockLock(p)
-#define SpinLockUnlock(p) lockUnlock(p)
-#define SpinLockTry(p) lockTry(p)
-#else
-#define SpinLockLock(p) OSSpinLockLock(p)
-#define SpinLockUnlock(p) OSSpinLockUnlock(p)
-#define SpinLockTry(p) OSSpinLockTry(p)
+
+/*
+ * Wrappers so that we get warnings in just one small part of this file.
+ */
+
+static inline void
+SpinLockLock(
+ VOLATILE OSSpinLock *lock)
+{
+ lockLock(lock);
+}
+static inline void
+SpinLockUnlock(
+ VOLATILE OSSpinLock *lock)
+{
+ lockUnlock(lock);
+}
+static inline bool
+SpinLockTry(
+ VOLATILE OSSpinLock *lock)
+{
+ return lockTry(lock);
+}
+
+#else /* !HAVE_WEAK_IMPORT */
+
+/*
+ * Wrappers so that we get warnings in just one small part of this file.
+ */
+
+static inline void
+SpinLockLock(
+ OSSpinLock *lock)
+{
+ OSSpinLockLock(lock);
+}
+static inline void
+SpinLockUnlock(
+ OSSpinLock *lock)
+{
+ OSSpinLockUnlock(lock);
+}
+static inline bool
+SpinLockTry(
+ OSSpinLock *lock)
+{
+ return OSSpinLockTry(lock);
+}
#endif /* HAVE_WEAK_IMPORT */
#define SPINLOCK_INIT OS_SPINLOCK_INIT
@@ -113,12 +154,34 @@ SpinLockLockInit(void)
*/
typedef uint32_t OSSpinLock;
-extern void _spin_lock(OSSpinLock *lock);
-extern void _spin_unlock(OSSpinLock *lock);
-extern int _spin_lock_try(OSSpinLock *lock);
-#define SpinLockLock(p) _spin_lock(p)
-#define SpinLockUnlock(p) _spin_unlock(p)
-#define SpinLockTry(p) _spin_lock_try(p)
+
+static inline void
+SpinLockLock(
+ OSSpinLock *lock)
+{
+ extern void _spin_lock(OSSpinLock *lock);
+
+ _spin_lock(lock);
+}
+
+static inline void
+SpinLockUnlock(
+ OSSpinLock *lock)
+{
+ extern void _spin_unlock(OSSpinLock *lock);
+
+ _spin_unlock(lock);
+}
+
+static inline int
+SpinLockTry(
+ OSSpinLock *lock)
+{
+ extern int _spin_lock_try(OSSpinLock *lock);
+
+ return _spin_lock_try(lock);
+}
+
#define SPINLOCK_INIT 0
#pragma GCC diagnostic pop
@@ -176,7 +239,7 @@ static OSSpinLock notifierLock = SPINLOCK_INIT;
#define SpinLockLockDbg(p) \
if (!SpinLockTry(p)) { \
- Tcl_WideInt s = TclpGetWideClicks(), e; \
+ long long s = TclpGetWideClicks(), e; \
\
SpinLockLock(p); \
e = TclpGetWideClicks(); \
@@ -395,6 +458,20 @@ static int receivePipe = -1; /* Output end of triggerPipe */
static int notifierThreadRunning;
/*
+ * The following static flag indicates that async handlers are pending.
+ */
+
+#if TCL_THREADS
+static int asyncPending = 0;
+#endif
+
+/*
+ * Signal mask information for notifier thread.
+ */
+static sigset_t notifierSigMask;
+static sigset_t allSigMask;
+
+/*
* This is the thread ID of the notifier thread that does select. Only valid
* when notifierThreadRunning is non-zero.
*
@@ -428,8 +505,7 @@ static CFStringRef tclEventsOnlyRunLoopMode = NULL;
*/
static void StartNotifierThread(void);
-static void NotifierThreadProc(ClientData clientData)
- __attribute__ ((__noreturn__));
+static TCL_NORETURN void NotifierThreadProc(ClientData clientData);
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
static void TimerWakeUp(CFRunLoopTimerRef timer, void *info);
static void QueueFileEvents(void *info);
@@ -472,7 +548,58 @@ MODULE_SCOPE long tclMacOSXDarwinRelease;
/*
*----------------------------------------------------------------------
*
- * Tcl_InitNotifier --
+ * LookUpFileHandler --
+ *
+ * Look up the file handler structure (and optionally the previous one in
+ * the chain) associated with a file descriptor.
+ *
+ * Returns:
+ * A pointer to the file handler, or NULL if it can't be found.
+ *
+ * Side effects:
+ * If prevPtrPtr is non-NULL, it will be written to if the file handler
+ * is found.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline FileHandler *
+LookUpFileHandler(
+ ThreadSpecificData *tsdPtr, /* Where to look things up. */
+ int fd, /* What we are looking for. */
+ FileHandler **prevPtrPtr) /* If non-NULL, where to report the previous
+ * pointer. */
+{
+ FileHandler *filePtr, *prevPtr;
+
+ /*
+ * Find the entry for the given file (and return if there isn't one).
+ */
+
+ for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
+ prevPtr = filePtr, filePtr = filePtr->nextPtr) {
+ if (filePtr == NULL) {
+ return NULL;
+ }
+ if (filePtr->fd == fd) {
+ break;
+ }
+ }
+
+ /*
+ * Report what we've found to our caller.
+ */
+
+ if (prevPtrPtr) {
+ *prevPtrPtr = prevPtr;
+ }
+ return filePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitNotifier --
*
* Initializes the platform specific notifier state.
*
@@ -486,22 +613,16 @@ MODULE_SCOPE long tclMacOSXDarwinRelease;
*/
ClientData
-Tcl_InitNotifier(void)
+TclpInitNotifier(void)
{
- ThreadSpecificData *tsdPtr;
-
- if (tclNotifierHooks.initNotifierProc) {
- return tclNotifierHooks.initNotifierProc();
- }
-
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) {
- Tcl_Panic("Tcl_InitNotifier: pthread_once failed");
+ Tcl_Panic("Tcl_InitNotifier: %s", "pthread_once failed");
}
#endif
@@ -528,7 +649,8 @@ Tcl_InitNotifier(void)
runLoopSource = CFRunLoopSourceCreate(NULL, LONG_MIN,
&runLoopSourceContext);
if (!runLoopSource) {
- Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource");
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "could not create CFRunLoopSource");
}
CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes);
CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode);
@@ -540,8 +662,8 @@ Tcl_InitNotifier(void)
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserver) {
- Tcl_Panic("Tcl_InitNotifier: could not create "
- "CFRunLoopObserver");
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "could not create CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserver, kCFRunLoopCommonModes);
@@ -558,8 +680,8 @@ Tcl_InitNotifier(void)
LONG_MIN, UpdateWaitingListAndServiceEvents,
&runLoopObserverContext);
if (!runLoopObserverTcl) {
- Tcl_Panic("Tcl_InitNotifier: could not create "
- "CFRunLoopObserver");
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "could not create CFRunLoopObserver");
}
CFRunLoopAddObserver(runLoop, runLoopObserverTcl,
tclEventsOnlyRunLoopMode);
@@ -588,7 +710,7 @@ Tcl_InitNotifier(void)
int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);
if (result) {
- Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
+ Tcl_Panic("Tcl_InitNotifier: %s", "pthread_atfork failed");
}
atForkInit = 1;
}
@@ -601,20 +723,20 @@ Tcl_InitNotifier(void)
*/
if (pipe(fds) != 0) {
- Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe");
+ Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
}
status = fcntl(fds[0], F_GETFL);
status |= O_NONBLOCK;
if (fcntl(fds[0], F_SETFL, status) < 0) {
- Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non "
- "blocking");
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "could not make receive pipe non-blocking");
}
status = fcntl(fds[1], F_GETFL);
status |= O_NONBLOCK;
if (fcntl(fds[1], F_SETFL, status) < 0) {
- Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non "
- "blocking");
+ Tcl_Panic("Tcl_InitNotifier: %s",
+ "could not make trigger pipe non-blocking");
}
receivePipe = fds[0];
@@ -638,7 +760,7 @@ Tcl_InitNotifier(void)
/*
*----------------------------------------------------------------------
*
- * TclMacOSXNotifierAddRunLoopMode --
+ * Tcl_MacOSXNotifierAddRunLoopMode --
*
* Add the tcl notifier RunLoop source, observer and timer (if any)
* to the given RunLoop mode.
@@ -653,7 +775,7 @@ Tcl_InitNotifier(void)
*/
void
-TclMacOSXNotifierAddRunLoopMode(
+Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -695,17 +817,32 @@ StartNotifierThread(void)
int result;
pthread_attr_t attr;
+ /*
+ * Arrange for the notifier thread to start with all
+ * signals blocked. In its mainloop it unblocks the
+ * signals at safe points.
+ */
+
+ sigfillset(&allSigMask);
+ pthread_sigmask(SIG_BLOCK, &allSigMask, &notifierSigMask);
+
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
pthread_attr_setstacksize(&attr, 60 * 1024);
result = pthread_create(&notifierThread, &attr,
- (void * (*)(void *))NotifierThreadProc, NULL);
+ (void * (*)(void *)) NotifierThreadProc, NULL);
pthread_attr_destroy(&attr);
if (result) {
Tcl_Panic("StartNotifierThread: unable to start notifier thread");
}
notifierThreadRunning = 1;
+
+ /*
+ * Restore original signal mask.
+ */
+
+ pthread_sigmask(SIG_SETMASK, &notifierSigMask, NULL);
}
UNLOCK_NOTIFIER_INIT;
}
@@ -714,7 +851,7 @@ StartNotifierThread(void)
/*
*----------------------------------------------------------------------
*
- * Tcl_FinalizeNotifier --
+ * TclpFinalizeNotifier --
*
* This function is called to cleanup the notifier state before a thread
* is terminated.
@@ -730,17 +867,10 @@ StartNotifierThread(void)
*/
void
-Tcl_FinalizeNotifier(
- ClientData clientData)
+TclpFinalizeNotifier(
+ TCL_UNUSED(ClientData))
{
- ThreadSpecificData *tsdPtr;
-
- if (tclNotifierHooks.finalizeNotifierProc) {
- tclNotifierHooks.finalizeNotifierProc(clientData);
- return;
- }
-
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
LOCK_NOTIFIER_INIT;
notifierCount--;
@@ -775,6 +905,14 @@ Tcl_FinalizeNotifier(
"thread");
}
notifierThreadRunning = 0;
+
+ /*
+ * If async marks are outstanding, perform actions now.
+ */
+ if (asyncPending) {
+ asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
}
close(receivePipe);
@@ -814,7 +952,7 @@ Tcl_FinalizeNotifier(
/*
*----------------------------------------------------------------------
*
- * Tcl_AlertNotifier --
+ * TclpAlertNotifier --
*
* Wake up the specified notifier from any thread. This routine is called
* by the platform independent notifier code whenever the Tcl_ThreadAlert
@@ -831,15 +969,10 @@ Tcl_FinalizeNotifier(
*/
void
-Tcl_AlertNotifier(
+TclpAlertNotifier(
ClientData clientData)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
-
- if (tclNotifierHooks.alertNotifierProc) {
- tclNotifierHooks.alertNotifierProc(clientData);
- return;
- }
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
LOCK_NOTIFIER_TSD;
if (tsdPtr->runLoop) {
@@ -852,7 +985,7 @@ Tcl_AlertNotifier(
/*
*----------------------------------------------------------------------
*
- * Tcl_SetTimer --
+ * TclpSetTimer --
*
* This function sets the current notifier timer value.
*
@@ -866,18 +999,13 @@ Tcl_AlertNotifier(
*/
void
-Tcl_SetTimer(
+TclpSetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
ThreadSpecificData *tsdPtr;
CFRunLoopTimerRef runLoopTimer;
CFTimeInterval waitTime;
- if (tclNotifierHooks.setTimerProc) {
- tclNotifierHooks.setTimerProc(timePtr);
- return;
- }
-
tsdPtr = TCL_TSD_INIT(&dataKey);
runLoopTimer = tsdPtr->runLoopTimer;
if (!runLoopTimer) {
@@ -887,7 +1015,7 @@ Tcl_SetTimer(
Tcl_Time vTime = *timePtr;
if (vTime.sec != 0 || vTime.usec != 0) {
- tclScaleTimeProcPtr(&vTime, tclTimeClientData);
+ TclScaleTime(&vTime);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
waitTime = 0;
@@ -918,15 +1046,15 @@ Tcl_SetTimer(
static void
TimerWakeUp(
- CFRunLoopTimerRef timer,
- void *info)
+ TCL_UNUSED(CFRunLoopTimerRef),
+ TCL_UNUSED(ClientData))
{
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ServiceModeHook --
+ * TclpServiceModeHook --
*
* This function is invoked whenever the service mode changes.
*
@@ -940,18 +1068,11 @@ TimerWakeUp(
*/
void
-Tcl_ServiceModeHook(
+TclpServiceModeHook(
int mode) /* Either TCL_SERVICE_ALL, or
* TCL_SERVICE_NONE. */
{
- ThreadSpecificData *tsdPtr;
-
- if (tclNotifierHooks.serviceModeHookProc) {
- tclNotifierHooks.serviceModeHookProc(mode);
- return;
- }
-
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (mode == TCL_SERVICE_ALL && !tsdPtr->runLoopTimer) {
if (!tsdPtr->runLoop) {
@@ -971,9 +1092,9 @@ Tcl_ServiceModeHook(
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateFileHandler --
+ * TclpCreateFileHandler --
*
- * This function registers a file handler with the select notifier.
+ * This function registers a file handler with the notifier.
*
* Results:
* None.
@@ -985,7 +1106,7 @@ Tcl_ServiceModeHook(
*/
void
-Tcl_CreateFileHandler(
+TclpCreateFileHandler(
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
@@ -995,24 +1116,11 @@ Tcl_CreateFileHandler(
* event. */
ClientData clientData) /* Arbitrary data to pass to proc. */
{
- ThreadSpecificData *tsdPtr;
- FileHandler *filePtr;
-
- if (tclNotifierHooks.createFileHandlerProc) {
- tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData);
- return;
- }
-
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
- for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd == fd) {
- break;
- }
- }
if (filePtr == NULL) {
- filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
@@ -1051,7 +1159,7 @@ Tcl_CreateFileHandler(
/*
*----------------------------------------------------------------------
*
- * Tcl_DeleteFileHandler --
+ * TclpDeleteFileHandler --
*
* Cancel a previously-arranged callback arrangement for a file.
*
@@ -1065,47 +1173,34 @@ Tcl_CreateFileHandler(
*/
void
-Tcl_DeleteFileHandler(
+TclpDeleteFileHandler(
int fd) /* Stream id for which to remove callback
* function. */
{
FileHandler *filePtr, *prevPtr;
- int i, numFdBits;
- ThreadSpecificData *tsdPtr;
-
- if (tclNotifierHooks.deleteFileHandlerProc) {
- tclNotifierHooks.deleteFileHandlerProc(fd);
- return;
- }
-
- tsdPtr = TCL_TSD_INIT(&dataKey);
- numFdBits = -1;
+ int i, numFdBits = -1;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Find the entry for the given file (and return if there isn't one).
*/
- for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
- prevPtr = filePtr, filePtr = filePtr->nextPtr) {
- if (filePtr == NULL) {
- return;
- }
- if (filePtr->fd == fd) {
- break;
- }
+ filePtr = LookUpFileHandler(tsdPtr, fd, &prevPtr);
+ if (filePtr == NULL) {
+ return;
}
/*
* Find current max fd.
*/
- if (fd+1 == tsdPtr->numFdBits) {
+ if (fd + 1 == tsdPtr->numFdBits) {
numFdBits = 0;
- for (i = fd-1; i >= 0; i--) {
+ for (i = fd - 1; i >= 0; i--) {
if (FD_ISSET(i, &tsdPtr->checkMasks.readable)
|| FD_ISSET(i, &tsdPtr->checkMasks.writable)
|| FD_ISSET(i, &tsdPtr->checkMasks.exceptional)) {
- numFdBits = i+1;
+ numFdBits = i + 1;
break;
}
}
@@ -1188,12 +1283,8 @@ FileHandlerEventProc(
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
- for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
- filePtr = filePtr->nextPtr) {
- if (filePtr->fd != fileEvPtr->fd) {
- continue;
- }
-
+ filePtr = LookUpFileHandler(tsdPtr, fileEvPtr->fd, NULL);
+ if (filePtr != NULL) {
/*
* The code is tricky for two reasons:
* 1. The file handler's desired events could have changed since the
@@ -1222,7 +1313,6 @@ FileHandlerEventProc(
UNLOCK_NOTIFIER_TSD;
filePtr->proc(filePtr->clientData, mask);
}
- break;
}
return 1;
}
@@ -1230,7 +1320,30 @@ FileHandlerEventProc(
/*
*----------------------------------------------------------------------
*
- * Tcl_WaitForEvent --
+ * TclpNotifierData --
+ *
+ * This function returns a ClientData pointer to be associated
+ * with a Tcl_AsyncHandler.
+ *
+ * Results:
+ * On MacOSX, returns always NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpNotifierData(void)
+{
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpWaitForEvent --
*
* This function is called by Tcl_DoOneEvent to wait for new events on
* the message queue. If the block time is 0, then Tcl_WaitForEvent just
@@ -1247,7 +1360,7 @@ FileHandlerEventProc(
*/
int
-Tcl_WaitForEvent(
+TclpWaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
int result, polling, runLoopRunning;
@@ -1255,9 +1368,6 @@ Tcl_WaitForEvent(
SInt32 runLoopStatus;
ThreadSpecificData *tsdPtr;
- if (tclNotifierHooks.waitForEventProc) {
- return tclNotifierHooks.waitForEventProc(timePtr);
- }
result = -1;
polling = 0;
waitTime = CF_TIMEINTERVAL_FOREVER;
@@ -1281,10 +1391,9 @@ Tcl_WaitForEvent(
*/
if (vTime.sec != 0 || vTime.usec != 0) {
- tclScaleTimeProcPtr(&vTime, tclTimeClientData);
+ TclScaleTime(&vTime);
waitTime = vTime.sec + 1.0e-6 * vTime.usec;
} else {
-
/*
* The max block time was set to 0.
*
@@ -1295,8 +1404,8 @@ Tcl_WaitForEvent(
* or timers are ready to fire immediately, only one (possibly two
* if one is a version 0 source) will be fired, regardless of the
* value of returnAfterSourceHandled." This can cause some chanio
- * tests to fail. So we use a small positive waitTime unless there
- * is another RunLoop running.
+ * tests to fail. So we use a small positive waitTime unless
+ * there is another RunLoop running.
*/
polling = 1;
@@ -1369,7 +1478,7 @@ QueueFileEvents(
{
SelectMasks readyMasks;
FileHandler *filePtr;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) info;
/*
* Queue all detected file events.
@@ -1408,7 +1517,8 @@ QueueFileEvents(
*/
if (filePtr->readyMask == 0) {
- FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+ ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
@@ -1423,8 +1533,8 @@ QueueFileEvents(
*
* UpdateWaitingListAndServiceEvents --
*
- * CFRunLoopObserver callback for updating waitingList and
- * servicing Tcl events.
+ * CFRunLoopObserver callback for updating waitingList and servicing Tcl
+ * events.
*
* Results:
* None.
@@ -1437,11 +1547,12 @@ QueueFileEvents(
static void
UpdateWaitingListAndServiceEvents(
- CFRunLoopObserverRef observer,
+ TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) info;
+
if (tsdPtr->sleeping) {
return;
}
@@ -1564,8 +1675,7 @@ Tcl_Sleep(
vdelay.sec = ms / 1000;
vdelay.usec = (ms % 1000) * 1000;
- tclScaleTimeProcPtr(&vdelay, tclTimeClientData);
-
+ TclScaleTime(&vdelay);
if (tsdPtr->runLoop) {
CFTimeInterval waitTime;
@@ -1779,6 +1889,61 @@ TclUnixWaitForFile(
/*
*----------------------------------------------------------------------
*
+ * TclAsyncNotifier --
+ *
+ * This procedure sets the async mark of an async handler to a
+ * given value, if it is called from the notifier thread.
+ *
+ * Result:
+ * True, when the handler will be marked, false otherwise.
+ *
+ * Side effetcs:
+ * The trigger pipe is written when called from the notifier
+ * thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclAsyncNotifier(
+ int sigNumber, /* Signal number. */
+ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
+ TCL_UNUSED(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,
+ * only few async-signal-safe system calls are allowed,
+ * e.g. pthread_self(), sem_post(), write().
+ */
+
+ if (pthread_equal(pthread_self(), (pthread_t) notifierThread)) {
+ if (notifierThreadRunning) {
+ *flagPtr = value;
+ if (!asyncPending) {
+ asyncPending = 1;
+ write(triggerPipe, "S", 1);
+ }
+ return 1;
+ }
+ return 0;
+ }
+
+ /*
+ * Re-send the signal to the notifier thread.
+ */
+
+ pthread_kill((pthread_t) notifierThread, sigNumber);
+#endif
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NotifierThreadProc --
*
* This routine is the initial (and only) function executed by the
@@ -1791,7 +1956,7 @@ TclUnixWaitForFile(
*
* Result:
* None. Once started, this routine never exits. It dies with the overall
- * process.
+ * process or terminates its own thread (on notifier termination).
*
* Side effects:
* The trigger pipe used to signal the notifier thread is created when
@@ -1800,13 +1965,13 @@ TclUnixWaitForFile(
*----------------------------------------------------------------------
*/
-static void
+static TCL_NORETURN void
NotifierThreadProc(
- ClientData clientData) /* Not used. */
+ TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask, writableMask, exceptionalMask;
- int i, numFdBits = 0, polling;
+ int i, ret, numFdBits = 0, polling;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
@@ -1859,8 +2024,25 @@ NotifierThreadProc(
}
FD_SET(receivePipe, &readableMask);
- if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask,
- timePtr) == -1) {
+ /*
+ * Signals are unblocked only during select().
+ */
+
+ pthread_sigmask(SIG_SETMASK, &notifierSigMask, NULL);
+ ret = select(numFdBits, &readableMask, &writableMask, &exceptionalMask,
+ timePtr);
+ pthread_sigmask(SIG_BLOCK, &allSigMask, NULL);
+
+ if (ret == -1) {
+ /*
+ * In case a signal was caught during select(),
+ * perform work on async handlers now.
+ */
+ if (errno == EINTR && asyncPending) {
+ asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
+
/*
* Try again immediately on an error.
*/
@@ -1948,6 +2130,11 @@ NotifierThreadProc(
break;
}
+
+ if (asyncPending) {
+ asyncPending = 0;
+ TclAsyncMarkFromNotifier();
+ }
}
}
pthread_exit(0);
@@ -2028,18 +2215,23 @@ AtForkChild(void)
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * If a child process unlocks an os_unfair_lock that was created in its parent
- * the child will exit with an illegal instruction error. So we reinitialize
- * the lock in the child rather than attempt to unlock it.
+ * If a child process unlocks an os_unfair_lock that was created in its
+ * parent the child will exit with an illegal instruction error. So we
+ * reinitialize the lock in the child rather than attempt to unlock it.
*/
#if defined(USE_OS_UNFAIR_LOCK)
- tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
+ notifierInitLock = OS_UNFAIR_LOCK_INIT;
+ notifierLock = OS_UNFAIR_LOCK_INIT;
+ tsdPtr->tsdLock = OS_UNFAIR_LOCK_INIT;
#else
- UNLOCK_NOTIFIER_TSD;
- UNLOCK_NOTIFIER;
- UNLOCK_NOTIFIER_INIT;
+ UNLOCK_NOTIFIER_TSD;
+ UNLOCK_NOTIFIER;
+ UNLOCK_NOTIFIER_INIT;
#endif
+
+ asyncPending = 0;
+
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
if (!noCFafterFork) {
@@ -2069,6 +2261,12 @@ AtForkChild(void)
if (!noCFafterFork) {
Tcl_InitNotifier();
}
+
+ /*
+ * Restart the notifier thread for signal handling.
+ */
+
+ StartNotifierThread();
}
}
#endif /* HAVE_PTHREAD_ATFORK */
@@ -2076,10 +2274,10 @@ AtForkChild(void)
#else /* HAVE_COREFOUNDATION */
void
-TclMacOSXNotifierAddRunLoopMode(
+Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode)
{
- Tcl_Panic("TclMacOSXNotifierAddRunLoopMode: "
+ Tcl_Panic("Tcl_MacOSXNotifierAddRunLoopMode: "
"Tcl not built with CoreFoundation support");
}
diff --git a/tests-perf/clock.perf.tcl b/tests-perf/clock.perf.tcl
index 35fe219..ad928c2 100644
--- a/tests-perf/clock.perf.tcl
+++ b/tests-perf/clock.perf.tcl
@@ -9,7 +9,7 @@
#
# ------------------------------------------------------------------------
#
-# Copyright (c) 2014 Serg G. Brester (aka sebres)
+# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
diff --git a/tests-perf/comparePerf.tcl b/tests-perf/comparePerf.tcl
new file mode 100644
index 0000000..f35da21
--- /dev/null
+++ b/tests-perf/comparePerf.tcl
@@ -0,0 +1,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
diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl
new file mode 100644
index 0000000..575c78e
--- /dev/null
+++ b/tests-perf/listPerf.tcl
@@ -0,0 +1,1295 @@
+#!/usr/bin/tclsh
+# ------------------------------------------------------------------------
+#
+# listPerf.tcl --
+#
+# This file provides performance tests for list operations. Run
+# tclsh listPerf.tcl help
+# for options.
+# ------------------------------------------------------------------------
+#
+# 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
+ }
+ --* {
+ puts stderr "Unknown option $arg"
+ print_usage
+ exit 1
+ }
+ 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}]]
+ }
+
+ perf destroy
+ }
+
+ 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
+ exit 0
+ }
+ 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
+}
diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl
index 749e85e..d360426 100644
--- a/tests-perf/test-performance.tcl
+++ b/tests-perf/test-performance.tcl
@@ -9,7 +9,7 @@
#
# ------------------------------------------------------------------------
#
-# Copyright (c) 2014 Serg G. Brester (aka sebres)
+# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
@@ -49,7 +49,7 @@ proc _test_out_total {} {
return
}
- set mintm 0x7fffffff
+ set mintm 0x7FFFFFFF
set maxtm 0
set nettm 0
set wtm 0
diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl
index f68a56a..5d1d3c6 100644
--- a/tests-perf/timer-event.perf.tcl
+++ b/tests-perf/timer-event.perf.tcl
@@ -9,7 +9,7 @@
#
# ------------------------------------------------------------------------
#
-# Copyright (c) 2014 Serg G. Brester (aka sebres)
+# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test
index d4d2a7c..fffc1cc 100644
--- a/tests/aaa_exit.test
+++ b/tests/aaa_exit.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/all.tcl b/tests/all.tcl
index 5ac2abb..8cd0cf4 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -1,16 +1,16 @@
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
-# tests. Execute it by invoking "source all.test" when running tcltest
+# tests. Execute it by invoking "source all.tcl" when running tcltest
# in this directory.
#
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2000 by Ajuba Solutions
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2000 Ajuba Solutions
#
# 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.5-
+package prefer latest
package require tcltest 2.5
namespace import ::tcltest::*
diff --git a/tests/append.test b/tests/append.test
index d3131e8..1055ae0 100644
--- a/tests/append.test
+++ b/tests/append.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -15,8 +15,12 @@ if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
unset -nocomplain x
+catch [list package require -exact tcl::test [info patchlevel]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+
test append-1.1 {append command} {
unset -nocomplain x
list [append x 1 2 abc "long string"] $x
@@ -53,6 +57,35 @@ test append-3.3 {append errors} -returnCodes error -body {
unset -nocomplain x
append x
} -result {can't read "x": no such variable}
+test append-3.4 {append surrogates} -body {
+ set x \uD83D
+ append x \uDE02
+} -result \uD83D\uDE02
+test append-3.5 {append surrogates} -body {
+ set x \uD83D
+ set x $x\uDE02
+} -result \uD83D\uDE02
+test append-3.6 {append surrogates} -body {
+ set x \uDE02
+ set x \uD83D$x
+} -result \uD83D\uDE02
+test append-3.7 {append \xC0 \x80} -constraints testbytestring -body {
+ set x [testbytestring \xC0]
+ string length [append x [testbytestring \x80]]
+} -result 2
+test append-3.8 {append \xC0 \x80} -constraints testbytestring -body {
+ set x [testbytestring \xC0]
+ string length $x[testbytestring \x80]
+} -result 2
+test append-3.9 {append \xC0 \x80} -constraints testbytestring -body {
+ set x [testbytestring \x80]
+ string length [testbytestring \xC0]$x
+} -result 2
+test append-3.10 {append surrogates} -body {
+ set x \uD83D
+ string range $x 0 end
+ append x \uDE02
+} -result [string range \uD83D\uDE02 0 end]
test append-4.1 {lappend command} {
unset -nocomplain x
diff --git a/tests/appendComp.test b/tests/appendComp.test
index 3a18404..ddb4fb2 100644
--- a/tests/appendComp.test
+++ b/tests/appendComp.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/apply.test b/tests/apply.test
index 1a3c96d..24b27cc 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -4,10 +4,10 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2005-2006 Miguel Sofer
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup {
lindex $lines 3 3
}
set lam [list {} {set a 1}]
-} -constraints memory -body {
+} -constraints {memory} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
::apply [lrange $lam 0 end]
diff --git a/tests/assemble.test b/tests/assemble.test
index 6ac090a..4452b38 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -2,8 +2,8 @@
#
# Test suite for the 'tcl::unsupported::assemble' command
#
-# Copyright (c) 2010 by Ozgur Dogan Ugurlu.
-# Copyright (c) 2010 by Kevin B. Kenny.
+# Copyright © 2010 Ozgur Dogan Ugurlu.
+# Copyright © 2010 Kevin B. Kenny.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -784,7 +784,7 @@ test assemble-7.43 {uplus} {
}
}
-returnCodes error
- -result {can't use non-numeric floating-point value as operand of "+"}
+ -result {can't use non-numeric floating-point value "NaN" as operand of "+"}
}
test assemble-7.43.1 {tryCvtToNumeric} {
-body {
@@ -855,10 +855,11 @@ test assemble-8.5 {bad context} {
-body {
namespace eval assem {
set x 1
- list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode]
+ assemble {load x}
}
}
- -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
+ -result {cannot use this instruction to create a variable in a non-proc context}
+ -errorCode {TCL ASSEM LVT}
-cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
@@ -1113,10 +1114,10 @@ test assemble-9.6 {concat} {
}
test assemble-9.7 {concat} {
-body {
- list [catch {assemble {concat 0}} result] $result $::errorCode
+ assemble {concat 0}
}
- -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
- -cleanup {unset result}
+ -result {operand must be positive}
+ -errorCode {TCL ASSEM POSITIVE}
}
# assemble-10 -- eval and expr
diff --git a/tests/assocd.test b/tests/assocd.test
index 863bf78..9a200ae 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -4,18 +4,20 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
-package require tcltest 2.5
-namespace import ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
diff --git a/tests/async.test b/tests/async.test
index 86527bf..49a00ff 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -4,9 +4,9 @@
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,11 +17,11 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint testasync [llength [info commands testasync]]
-testConstraint threaded [::tcl::pkgconfig get threaded]
-testConstraint notWinCI [expr {$::tcl_platform(platform) != "windows" || ![info exists ::env(CI)]}]
+testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]]
proc async1 {result code} {
global aresult acode
@@ -150,7 +150,7 @@ test async-3.1 {deleting handlers} testasync {
} {3 del2 {0 0 0 del1 del2}}
test async-4.1 {async interrupting bytecode sequence} -constraints {
- testasync threaded
+ testasync thread
} -setup {
set hm [testasync create async3]
proc nothing {} {
@@ -179,7 +179,7 @@ test async-4.1 {async interrupting bytecode sequence} -constraints {
testasync delete $hm
}
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
- testasync threaded
+ testasync thread
} -setup {
set hm [testasync create async3]
} -body {
@@ -204,7 +204,7 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints {
testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
- testasync threaded notWinCI
+ testasync thread knownMsvcBug
} -setup {
set hm [testasync create async3]
} -body {
diff --git a/tests/auto-files.zip b/tests/auto-files.zip
new file mode 100644
index 0000000..b8bdf88
--- /dev/null
+++ b/tests/auto-files.zip
Binary files differ
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test
index 6adb403..214a969 100644
--- a/tests/autoMkindex.test
+++ b/tests/autoMkindex.test
@@ -3,8 +3,8 @@
# This file contains tests related to autoloading and generating the
# autoloading index.
#
-# Copyright (c) 1998 Lucent Technologies, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1998 Lucent Technologies, Inc.
+# Copyright © 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.
@@ -32,7 +32,7 @@ makeFile {# Test file for:
# Note that procedures and itcl class definitions can be nested inside of
# namespaces.
#
-# Copyright (c) 1993-1998 Lucent Technologies, Inc.
+# Copyright © 1993-1998 Lucent Technologies, Inc.
# This shouldn't cause any problems
namespace import -force blt::*
@@ -164,17 +164,17 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup {
# Test auto_mkindex hooks
-# Slave hook executes interesting code in the interp used to watch code.
-test autoMkindex-3.1 {slaveHook} -setup {
+# Child hook executes interesting code in the interp used to watch code.
+test autoMkindex-3.1 {childHook} -setup {
file delete tclIndex
} -body {
- auto_mkindex_parser::slavehook {
+ auto_mkindex_parser::childhook {
_%@namespace eval ::blt {
proc foo {} {}
_%@namespace export foo
}
}
- auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* }
+ auto_mkindex_parser::childhook { _%@namespace import -force ::blt::* }
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} -cleanup {
diff --git a/tests/basic.test b/tests/basic.test
index bf2b08f..c90d80e 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -9,8 +9,8 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -21,7 +21,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
@@ -348,7 +348,7 @@ test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespac
test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
catch {rename \# ""}
set x [testcmdtoken create \#]
- testcmdtoken name $x
+ return [testcmdtoken name $x]
} {{#} ::#}
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
@@ -672,7 +672,7 @@ proc l3 {} {
}
# Do all tests once byte compiled and once with direct string evaluation
-for {set noComp 0} {$noComp <= 1} {incr noComp} {
+foreach noComp {0 1} {
if {$noComp} {
interp alias {} run {} testevalex
@@ -895,21 +895,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
rename stress {}
} -result 0
-test basic-48.17.$noComp {expansion: object safety} -setup {
- set old_precision $::tcl_precision
- set ::tcl_precision 4
- } -constraints $constraints -body {
+test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body {
set third [expr {1.0/3.0}]
set l [list $third $third]
set x [run {list $third {*}$l $third}]
- set res [list]
+ set res [list]
foreach t $x {
lappend res [expr {$t * 3.0}]
}
set res
} -cleanup {
- set ::tcl_precision $old_precision
- unset old_precision res t l x third
+ unset res t l x third
} -result {1.0 1.0 1.0 1.0}
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
diff --git a/tests/binary.test b/tests/binary.test
index 15c0b28..03ef846 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -15,10 +15,11 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch {package require -exact Tcltest [info patchlevel]}
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
+testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -27,9 +28,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -39,19 +40,19 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -61,11 +62,11 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -162,16 +163,16 @@ test binary-4.3 {Tcl_BinaryObjCmd: format} {
} \x80
test binary-4.4 {Tcl_BinaryObjCmd: format} {
binary format B* 010011
-} \x4c
+} \x4C
test binary-4.5 {Tcl_BinaryObjCmd: format} {
binary format B8 01001101
-} \x4d
+} \x4D
test binary-4.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2B9 oo 01001101
-} \x4d\x00
+} \x4D\x00
test binary-4.7 {Tcl_BinaryObjCmd: format} {
binary format B9 010011011010
-} \x4d\x80
+} \x4D\x80
test binary-4.8 {Tcl_BinaryObjCmd: format} {
binary format B2B3 10 010
} \x80\x40
@@ -193,16 +194,16 @@ test binary-5.4 {Tcl_BinaryObjCmd: format} {
} 2
test binary-5.5 {Tcl_BinaryObjCmd: format} {
binary format b8 01001101
-} \xb2
+} \xB2
test binary-5.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2b9 oo 01001101
-} \xb2\x00
+} \xB2\x00
test binary-5.7 {Tcl_BinaryObjCmd: format} {
binary format b9 010011011010
-} \xb2\x01
+} \xB2\x01
test binary-5.8 {Tcl_BinaryObjCmd: format} {
binary format b17 1
-} \x01\00\00
+} \x01\x00\x00
test binary-5.9 {Tcl_BinaryObjCmd: format} {
binary format b2b3 10 010
} \x01\x02
@@ -221,19 +222,19 @@ test binary-6.3 {Tcl_BinaryObjCmd: format} {
} \x01
test binary-6.4 {Tcl_BinaryObjCmd: format} {
binary format h c
-} \x0c
+} \x0C
test binary-6.5 {Tcl_BinaryObjCmd: format} {
binary format h* baadf00d
-} \xab\xda\x0f\xd0
+} \xAB\xDA\x0F\xD0
test binary-6.6 {Tcl_BinaryObjCmd: format} {
binary format h4 c410
-} \x4c\x01
+} \x4C\x01
test binary-6.7 {Tcl_BinaryObjCmd: format} {
binary format h6 c4102
-} \x4c\x01\x02
+} \x4C\x01\x02
test binary-6.8 {Tcl_BinaryObjCmd: format} {
binary format h5 c41020304
-} \x4c\x01\x02
+} \x4C\x01\x02
test binary-6.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3h5 foo 2
} \x02\x00\x00
@@ -255,19 +256,19 @@ test binary-7.3 {Tcl_BinaryObjCmd: format} {
} \x10
test binary-7.4 {Tcl_BinaryObjCmd: format} {
binary format H c
-} \xc0
+} \xC0
test binary-7.5 {Tcl_BinaryObjCmd: format} {
binary format H* baadf00d
-} \xba\xad\xf0\x0d
+} \xBA\xAD\xF0\x0D
test binary-7.6 {Tcl_BinaryObjCmd: format} {
binary format H4 c410
-} \xc4\x10
+} \xC4\x10
test binary-7.7 {Tcl_BinaryObjCmd: format} {
binary format H6 c4102
-} \xc4\x10\x20
+} \xC4\x10\x20
test binary-7.8 {Tcl_BinaryObjCmd: format} {
binary format H5 c41023304
-} \xc4\x10\x20
+} \xC4\x10\x20
test binary-7.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3H5 foo 2
} \x20\x00\x00
@@ -487,34 +488,34 @@ test binary-13.3 {Tcl_BinaryObjCmd: format} {
} {}
test binary-13.4 {Tcl_BinaryObjCmd: format} bigEndian {
binary format f 1.6
-} \x3f\xcc\xcc\xcd
+} \x3F\xCC\xCC\xCD
test binary-13.5 {Tcl_BinaryObjCmd: format} littleEndian {
binary format f 1.6
-} \xcd\xcc\xcc\x3f
+} \xCD\xCC\xCC\x3F
test binary-13.6 {Tcl_BinaryObjCmd: format} bigEndian {
binary format f* {1.6 3.4}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-13.7 {Tcl_BinaryObjCmd: format} littleEndian {
binary format f* {1.6 3.4}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-13.8 {Tcl_BinaryObjCmd: format} bigEndian {
binary format f2 {1.6 3.4}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-13.9 {Tcl_BinaryObjCmd: format} littleEndian {
binary format f2 {1.6 3.4}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-13.10 {Tcl_BinaryObjCmd: format} bigEndian {
binary format f2 {1.6 3.4 5.6}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-13.11 {Tcl_BinaryObjCmd: format} littleEndian {
binary format f2 {1.6 3.4 5.6}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-13.12 {Tcl_BinaryObjCmd: float overflow} bigEndian {
binary format f -3.402825e+38
-} \xff\x7f\xff\xff
+} \xFF\x80\x00\x00
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} littleEndian {
binary format f -3.402825e+38
-} \xff\xff\x7f\xff
+} \x00\x00\x80\xFF
test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian {
binary format f -3.402825e-100
} \x80\x00\x00\x00
@@ -531,11 +532,23 @@ test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format f1 $a
-} \x3f\xcc\xcc\xcd
+} \x3F\xCC\xCC\xCD
test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian {
set a {1.6 3.4}
binary format f1 $a
-} \xcd\xcc\xcc\x3f
+} \xCD\xCC\xCC\x3F
+test binary-13.20 {Tcl_BinaryObjCmd: format float Inf} bigEndian {
+ binary format f Inf
+} \x7F\x80\x00\x00
+test binary-13.21 {Tcl_BinaryObjCmd: format float Inf} littleEndian {
+ binary format f Inf
+} \x00\x00\x80\x7F
+test binary-13.22 {Tcl_BinaryObjCmd: format float -Inf} bigEndian {
+ binary format f -Inf
+} \xFF\x80\x00\x00
+test binary-13.23 {Tcl_BinaryObjCmd: format float -Inf} littleEndian {
+ binary format f -Inf
+} \x00\x00\x80\xFF
test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format d
@@ -548,28 +561,28 @@ test binary-14.3 {Tcl_BinaryObjCmd: format} {
} {}
test binary-14.4 {Tcl_BinaryObjCmd: format} bigEndian {
binary format d 1.6
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-14.5 {Tcl_BinaryObjCmd: format} littleEndian {
binary format d 1.6
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F
test binary-14.6 {Tcl_BinaryObjCmd: format} bigEndian {
binary format d* {1.6 3.4}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-14.7 {Tcl_BinaryObjCmd: format} littleEndian {
binary format d* {1.6 3.4}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-14.8 {Tcl_BinaryObjCmd: format} bigEndian {
binary format d2 {1.6 3.4}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-14.9 {Tcl_BinaryObjCmd: format} littleEndian {
binary format d2 {1.6 3.4}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian {
binary format d2 {1.6 3.4 5.6}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian {
binary format d2 {1.6 3.4 5.6}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format d2 {1.6}
} -result {number of elements in list does not match count}
@@ -580,11 +593,11 @@ test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
set a {1.6 3.4}
binary format d1 $a
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian {
set a {1.6 3.4}
binary format d1 $a
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F
test binary-14.18 {FormatNumber: Bug 1116542} {
binary scan [binary format d 1.25] d w
set w
@@ -761,7 +774,16 @@ test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup {
} -body {
list [binary scan "abc def \x00ghi " A* arg1] $arg1
} -result [list 1 "abc def \x00ghi"]
-
+test binary-21.13 {Tcl_BinaryObjCmd: scan} -setup {
+ unset -nocomplain arg1
+} -body {
+ list [binary scan "abc def \x00 " C* arg1] $arg1
+} -result {1 {abc def }}
+test binary-21.14 {Tcl_BinaryObjCmd: scan} -setup {
+ unset -nocomplain arg1
+} -body {
+ list [binary scan "abc def \x00ghi" C* arg1] $arg1
+} -result {1 {abc def }}
test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
binary scan abc b
} -result {not enough arguments for all format specifiers}
@@ -867,11 +889,11 @@ test binary-24.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-24.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 h* arg1] $arg1
+ list [binary scan \x52\xA3 h* arg1] $arg1
} {1 253a}
test binary-24.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xc2\xa3 h arg1] $arg1
+ list [binary scan \xC2\xA3 h arg1] $arg1
} {1 2}
test binary-24.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -883,7 +905,7 @@ test binary-24.5 {Tcl_BinaryObjCmd: scan} {
} {1 {}}
test binary-24.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xf2\x53 h2 arg1] $arg1
+ list [binary scan \xF2\x53 h2 arg1] $arg1
} {1 2f}
test binary-24.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -913,11 +935,11 @@ test binary-25.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-25.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 H* arg1] $arg1
+ list [binary scan \x52\xA3 H* arg1] $arg1
} {1 52a3}
test binary-25.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xc2\xa3 H arg1] $arg1
+ list [binary scan \xC2\xA3 H arg1] $arg1
} {1 c}
test binary-25.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -929,7 +951,7 @@ test binary-25.5 {Tcl_BinaryObjCmd: scan} {
} {1 {}}
test binary-25.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xf2\x53 H2 arg1] $arg1
+ list [binary scan \xF2\x53 H2 arg1] $arg1
} {1 f2}
test binary-25.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -958,27 +980,27 @@ test binary-26.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-26.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c* arg1] $arg1
+ list [binary scan \x52\xA3 c* arg1] $arg1
} {1 {82 -93}}
test binary-26.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c arg1] $arg1
+ list [binary scan \x52\xA3 c arg1] $arg1
} {1 82}
test binary-26.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c1 arg1] $arg1
+ list [binary scan \x52\xA3 c1 arg1] $arg1
} {1 82}
test binary-26.5 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c0 arg1] $arg1
+ list [binary scan \x52\xA3 c0 arg1] $arg1
} {1 {}}
test binary-26.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c2 arg1] $arg1
+ list [binary scan \x52\xA3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-26.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xff c arg1] $arg1
+ list [binary scan \xFF c arg1] $arg1
} {1 -1}
test binary-26.8 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -999,15 +1021,15 @@ test binary-26.10 {Tcl_BinaryObjCmd: scan} {
} {2 {112 -121} 5}
test binary-26.11 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 cu* arg1] $arg1
+ list [binary scan \x52\xA3 cu* arg1] $arg1
} {1 {82 163}}
test binary-26.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 cu arg1] $arg1
+ list [binary scan \x52\xA3 cu arg1] $arg1
} {1 82}
test binary-26.13 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xff cu arg1] $arg1
+ list [binary scan \xFF cu arg1] $arg1
} {1 255}
test binary-26.14 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
@@ -1027,23 +1049,23 @@ test binary-27.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-27.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 s* arg1] $arg1
} {1 {-23726 21587}}
test binary-27.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 s arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 s arg1] $arg1
} {1 -23726}
test binary-27.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 s1 arg1] $arg1
+ list [binary scan \x52\xA3 s1 arg1] $arg1
} {1 -23726}
test binary-27.5 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 s0 arg1] $arg1
+ list [binary scan \x52\xA3 s0 arg1] $arg1
} {1 {}}
test binary-27.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 s2 arg1] $arg1
} {1 {-23726 21587}}
test binary-27.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1060,23 +1082,23 @@ test binary-27.9 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
test binary-27.10 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 su* arg1] $arg1
} {1 {41810 21587}}
test binary-27.11 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF sus arg1 arg2] $arg1 $arg2
} {2 65535 -1}
test binary-27.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF ssu arg1 arg2] $arg1 $arg2
} {2 -1 65535}
test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
@@ -1084,23 +1106,23 @@ test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-28.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 S* arg1] $arg1
} {1 {21155 21332}}
test binary-28.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 S arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 S arg1] $arg1
} {1 21155}
test binary-28.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 S1 arg1] $arg1
+ list [binary scan \x52\xA3 S1 arg1] $arg1
} {1 21155}
test binary-28.5 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 S0 arg1] $arg1
+ list [binary scan \x52\xA3 S0 arg1] $arg1
} {1 {}}
test binary-28.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 S2 arg1] $arg1
} {1 {21155 21332}}
test binary-28.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1117,15 +1139,15 @@ test binary-28.9 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
test binary-28.10 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 Su* arg1] $arg1
} {1 {21155 21332}}
test binary-28.11 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1
+ list [binary scan \xA3\x52\x54\x53 Su* arg1] $arg1
} {1 {41810 21587}}
test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
@@ -1133,23 +1155,23 @@ test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-29.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i arg1] $arg1
} {1 1414767442}
test binary-29.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 i1 arg1] $arg1
} {1 1414767442}
test binary-29.5 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53 i0 arg1] $arg1
+ list [binary scan \x52\xA3\x53 i0 arg1] $arg1
} {1 {}}
test binary-29.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1166,15 +1188,15 @@ test binary-29.9 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
test binary-29.10 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
- list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iui arg1 arg2] $arg1 $arg2
} {2 4294967295 -1}
test binary-29.11 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
- list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iiu arg1 arg2] $arg1 $arg2
} {2 -1 4294967295}
test binary-29.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
@@ -1186,23 +1208,23 @@ test binary-30.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-30.2 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.3 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I arg1] $arg1
} {1 1386435412}
test binary-30.4 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 I1 arg1] $arg1
} {1 1386435412}
test binary-30.5 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53 I0 arg1] $arg1
+ list [binary scan \x52\xA3\x53 I0 arg1] $arg1
} {1 {}}
test binary-30.6 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.7 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1219,15 +1241,15 @@ test binary-30.9 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
test binary-30.10 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
- list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IuI arg1 arg2] $arg1 $arg2
} {2 4294967295 -1}
test binary-30.11 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
- list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2
+ list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IIu arg1 arg2] $arg1 $arg2
} {2 -1 4294967295}
test binary-30.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1 arg2
@@ -1239,43 +1261,43 @@ test binary-31.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f arg1] $arg1
} {1 1.600000023841858}
test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f arg1] $arg1
} {1 1.600000023841858}
test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD f0 arg1] $arg1
} {1 {}}
test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F f0 arg1] $arg1
} {1 {}}
test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1286,19 +1308,19 @@ test binary-31.13 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -returnCodes error -body {
set arg1 1
- binary scan \x3f\xcc\xcc\xcd f1 arg1(a)
+ binary scan \x3F\xCC\xCC\xCD f1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
@@ -1306,43 +1328,43 @@ test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d arg1] $arg1
} {1 1.6}
test binary-32.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d arg1] $arg1
} {1 1.6}
test binary-32.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1] $arg1
} {1 1.6}
test binary-32.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d1 arg1] $arg1
} {1 1.6}
test binary-32.8 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d0 arg1] $arg1
} {1 {}}
test binary-32.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d0 arg1] $arg1
} {1 {}}
test binary-32.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.11 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -1353,19 +1375,19 @@ test binary-32.13 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -returnCodes error -body {
set arg1 1
- binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)
+ binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-32.14 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-32.15 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-33.1 {Tcl_BinaryObjCmd: scan} {
@@ -1536,20 +1558,20 @@ test binary-38.4 {FormatNumber: word alignment} {
} \x01\x00\x00\x00\x01
test binary-38.5 {FormatNumber: word alignment} bigEndian {
set x [binary format c1d1 1 1.6]
-} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a
+} \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-38.6 {FormatNumber: word alignment} littleEndian {
set x [binary format c1d1 1 1.6]
-} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f
+} \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F
test binary-38.7 {FormatNumber: word alignment} bigEndian {
set x [binary format c1f1 1 1.6]
-} \x01\x3f\xcc\xcc\xcd
+} \x01\x3F\xCC\xCC\xCD
test binary-38.8 {FormatNumber: word alignment} littleEndian {
set x [binary format c1f1 1 1.6]
-} \x01\xcd\xcc\xcc\x3f
+} \x01\xCD\xCC\xCC\x3F
test binary-39.1 {ScanNumber: sign extension} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 c2 arg1] $arg1
+ list [binary scan \x52\xA3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-39.2 {ScanNumber: sign extension} {
unset -nocomplain arg1
@@ -1569,7 +1591,7 @@ test binary-39.5 {ScanNumber: sign extension} {
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
test binary-39.6 {ScanNumber: no sign extension} {
unset -nocomplain arg1
- list [binary scan \x52\xa3 cu2 arg1] $arg1
+ list [binary scan \x52\xA3 cu2 arg1] $arg1
} {1 {82 163}}
test binary-39.7 {ScanNumber: no sign extension} {
unset -nocomplain arg1
@@ -1590,11 +1612,11 @@ test binary-39.10 {ScanNumber: no sign extension} {
test binary-40.3 {ScanNumber: NaN} -body {
unset -nocomplain arg1
- list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
+ list [binary scan \xFF\xFF\xFF\xFF f1 arg1] $arg1
} -match glob -result {1 -NaN*}
test binary-40.4 {ScanNumber: NaN} -body {
unset -nocomplain arg1
- list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1
+ list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF d arg1] $arg1
} -match glob -result {1 -NaN*}
test binary-41.1 {ScanNumber: word alignment} -setup {
@@ -1620,22 +1642,22 @@ test binary-41.4 {ScanNumber: word alignment} -setup {
test binary-41.5 {ScanNumber: word alignment} -setup {
unset -nocomplain arg1 arg2
} -constraints bigEndian -body {
- list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
+ list [binary scan \x01\x3F\xCC\xCC\xCD c1f1 arg1 arg2] $arg1 $arg2
} -result {2 1 1.600000023841858}
test binary-41.6 {ScanNumber: word alignment} -setup {
unset -nocomplain arg1 arg2
} -constraints littleEndian -body {
- list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
+ list [binary scan \x01\xCD\xCC\xCC\x3F c1f1 arg1 arg2] $arg1 $arg2
} -result {2 1 1.600000023841858}
test binary-41.7 {ScanNumber: word alignment} -setup {
unset -nocomplain arg1 arg2
} -constraints bigEndian -body {
- list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
+ list [binary scan \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A c1d1 arg1 arg2] $arg1 $arg2
} -result {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} -setup {
unset -nocomplain arg1 arg2
} -constraints littleEndian -body {
- list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
+ list [binary scan \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F c1d1 arg1 arg2] $arg1 $arg2
} -result {2 1 1.6}
test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body {
@@ -1650,22 +1672,6 @@ test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
-test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
- binary scan HelloTcl W x
- set x
-} 5216694956358656876
-test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
- binary scan lcTolleH w x
- set x
-} 5216694956358656876
-test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
- binary scan [binary format w [expr {wide(3) << 31}]] w x
- set x
-} 6442450944
-test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
- binary scan [binary format W [expr {wide(3) << 31}]] W x
- set x
-} 6442450944
test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
unset -nocomplain arg1
list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
@@ -1687,6 +1693,31 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}
+test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan HelloTcl W x
+ set x
+} 5216694956358656876
+test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan lcTolleH w x
+ set x
+} 5216694956358656876
+test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+ binary scan [binary format w [expr {wide(3) << 31}]] w x
+ set x
+} 6442450944
+test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+ binary scan [binary format W [expr {wide(3) << 31}]] W x
+ set x
+} 6442450944
+test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
+ binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x
+ set x
+} 6442450944
+test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
+ binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x
+ set x
+} 6442450944
+
test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sws 16450 -1 19521] c* x
set x
@@ -1697,26 +1728,26 @@ test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
} {66 64 0 0 0 0 127 -1 -1 -1 65 76}
test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
- binary format a* \u20ac
-} \u00ac
+ binary format a* €
+} \xAC
test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
- list [binary scan [binary format a* \u20ac\u20bd] s x] $x
+ list [binary scan [binary format a* €₽] s x] $x
} {1 -16980}
test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x {}
set y {}
set z {}
- list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z
-} "2 \u00ac \u00bd {}"
+ list [binary scan [binary format a* €₽] aaa x y z] $x $y $z
+} "2 \xAC \xBD {}"
test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
- set x [encoding convertto iso8859-15 \u20ac]
+ set x [encoding convertto iso8859-15 €]
set y [binary format a* $x]
list $x $y
-} "\u00a4 \u00a4"
+} "\xA4 \xA4"
test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
- set x [binary scan \u00a4 a* y]
+ set x [binary scan \xA4 a* y]
list $x $y [encoding convertfrom iso8859-15 $y]
-} "1 \u00a4 \u20ac"
+} "1 \xA4 €"
test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} {
# This test is only reliable when memory debugging is turned on, but
@@ -1882,28 +1913,28 @@ test binary-51.3 {Tcl_BinaryObjCmd: format} {
} {}
test binary-51.4 {Tcl_BinaryObjCmd: format} {} {
binary format Q 1.6
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-51.5 {Tcl_BinaryObjCmd: format} {} {
binary format q 1.6
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F
test binary-51.6 {Tcl_BinaryObjCmd: format} {} {
binary format Q* {1.6 3.4}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-51.7 {Tcl_BinaryObjCmd: format} {} {
binary format q* {1.6 3.4}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-51.8 {Tcl_BinaryObjCmd: format} {} {
binary format Q2 {1.6 3.4}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-51.9 {Tcl_BinaryObjCmd: format} {} {
binary format q2 {1.6 3.4}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-51.10 {Tcl_BinaryObjCmd: format} {} {
binary format Q2 {1.6 3.4 5.6}
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33
test binary-51.11 {Tcl_BinaryObjCmd: format} {} {
binary format q2 {1.6 3.4 5.6}
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40
test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format q2 {1.6}
} -result {number of elements in list does not match count}
@@ -1914,11 +1945,11 @@ test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-51.16 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format Q1 $a
-} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+} \x3F\xF9\x99\x99\x99\x99\x99\x9A
test binary-51.17 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format q1 $a
-} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+} \x9A\x99\x99\x99\x99\x99\xF9\x3F
# format R/r
test binary-53.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
@@ -1932,34 +1963,34 @@ test binary-53.3 {Tcl_BinaryObjCmd: format} {
} {}
test binary-53.4 {Tcl_BinaryObjCmd: format} {} {
binary format R 1.6
-} \x3f\xcc\xcc\xcd
+} \x3F\xCC\xCC\xCD
test binary-53.5 {Tcl_BinaryObjCmd: format} {} {
binary format r 1.6
-} \xcd\xcc\xcc\x3f
+} \xCD\xCC\xCC\x3F
test binary-53.6 {Tcl_BinaryObjCmd: format} {} {
binary format R* {1.6 3.4}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-53.7 {Tcl_BinaryObjCmd: format} {} {
binary format r* {1.6 3.4}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-53.8 {Tcl_BinaryObjCmd: format} {} {
binary format R2 {1.6 3.4}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-53.9 {Tcl_BinaryObjCmd: format} {} {
binary format r2 {1.6 3.4}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-53.10 {Tcl_BinaryObjCmd: format} {} {
binary format R2 {1.6 3.4 5.6}
-} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A
test binary-53.11 {Tcl_BinaryObjCmd: format} {} {
binary format r2 {1.6 3.4 5.6}
-} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40
test binary-53.12 {Tcl_BinaryObjCmd: float overflow} {} {
binary format R -3.402825e+38
-} \xff\x7f\xff\xff
+} \xFF\x80\x00\x00
test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} {
binary format r -3.402825e+38
-} \xff\xff\x7f\xff
+} \x00\x00\x80\xFF
test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} {
binary format R -3.402825e-100
} \x80\x00\x00\x00
@@ -1976,11 +2007,44 @@ test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
test binary-53.18 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format R1 $a
-} \x3f\xcc\xcc\xcd
+} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
-} \xcd\xcc\xcc\x3f
+} \xCD\xCC\xCC\x3F
+test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} {
+ binary format R Inf
+} \x7F\x80\x00\x00
+test binary-53.21 {Tcl_BinaryObjCmd: float Inf} {} {
+ binary format r Inf
+} \x00\x00\x80\x7F
+test binary-53.22 {Binary float Inf round trip} -body {
+ binary scan [binary format R Inf] R inf
+ binary scan [binary format R -Inf] R inf_
+ list $inf $inf_
+} -result {Inf -Inf}
+test binary-53.23 {Binary float round to FLT_MAX} -body {
+ binary scan [binary format H* 7f7fffff] R fltmax
+ binary scan [binary format H* 47effffff0000000] Q round_to_fltmax
+ binary scan [binary format R $round_to_fltmax] R fltmax1
+ expr {$fltmax eq $fltmax1}
+} -result 1
+test binary-53.24 {Binary float round to -FLT_MAX} -body {
+ binary scan [binary format H* ff7fffff] R fltmax
+ binary scan [binary format H* c7effffff0000000] Q round_to_fltmax
+ binary scan [binary format R $round_to_fltmax] R fltmax1
+ expr {$fltmax eq $fltmax1}
+} -result 1
+test binary-53.25 {Binary float round to Inf} -body {
+ binary scan [binary format H* 47effffff0000001] Q round_to_inf
+ binary scan [binary format R $round_to_inf] R inf1
+ expr {$inf1 eq Inf}
+} -result 1
+test binary-53.26 {Binary float round to -Inf} -body {
+ binary scan [binary format H* c7effffff0000001] Q round_to_inf
+ binary scan [binary format R $round_to_inf] R inf1
+ expr {$inf1 eq -Inf}
+} -result 1
# scan t (s)
test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
@@ -1988,23 +2052,23 @@ test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-54.2 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1
} {1 {-23726 21587}}
test binary-54.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t arg1] $arg1
} {1 -23726}
test binary-54.4 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3 t1 arg1] $arg1
+ list [binary scan \x52\xA3 t1 arg1] $arg1
} {1 -23726}
test binary-54.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3 t0 arg1] $arg1
+ list [binary scan \x52\xA3 t0 arg1] $arg1
} {1 {}}
test binary-54.6 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1
} {1 {-23726 21587}}
test binary-54.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
@@ -2021,7 +2085,7 @@ test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
@@ -2042,23 +2106,23 @@ test binary-55.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1
} {1 {21155 21332}}
test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t arg1] $arg1
} {1 21155}
test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3 t1 arg1] $arg1
+ list [binary scan \x52\xA3 t1 arg1] $arg1
} {1 21155}
test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3 t0 arg1] $arg1
+ list [binary scan \x52\xA3 t0 arg1] $arg1
} {1 {}}
test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1
} {1 {21155 21332}}
test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
@@ -2075,7 +2139,7 @@ test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
@@ -2096,23 +2160,23 @@ test binary-56.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-56.2 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
} {1 {1414767442 67305985}}
test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
} {1 1414767442}
test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1
} {1 1414767442}
test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53 n0 arg1] $arg1
+ list [binary scan \x52\xA3\x53 n0 arg1] $arg1
} {1 {}}
test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
} {1 {1414767442 67305985}}
test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
@@ -2129,7 +2193,7 @@ test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
@@ -2150,23 +2214,23 @@ test binary-57.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
} {1 {1386435412 16909060}}
test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
} {1 1386435412}
test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1
} {1 1386435412}
test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53 n0 arg1] $arg1
+ list [binary scan \x52\xA3\x53 n0 arg1] $arg1
} {1 {}}
test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
} {1 {1386435412 16909060}}
test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
@@ -2183,7 +2247,7 @@ test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
@@ -2204,43 +2268,43 @@ test binary-58.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q* arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q arg1] $arg1
} {1 1.6}
test binary-58.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q arg1] $arg1
} {1 1.6}
test binary-58.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q1 arg1] $arg1
} {1 1.6}
test binary-58.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q1 arg1] $arg1
} {1 1.6}
test binary-58.8 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q0 arg1] $arg1
} {1 {}}
test binary-58.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q0 arg1] $arg1
} {1 {}}
test binary-58.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.11 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -2251,19 +2315,19 @@ test binary-58.13 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -returnCodes error -body {
set arg1 1
- binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a)
+ binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A q1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-58.14 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-58.15 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 q2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
# scan R/r
@@ -2272,43 +2336,43 @@ test binary-59.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
} -result {not enough arguments for all format specifiers}
test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R arg1] $arg1
} {1 1.600000023841858}
test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r arg1] $arg1
} {1 1.600000023841858}
test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD R1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F r1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD R0 arg1] $arg1
} {1 {}}
test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F r0 arg1] $arg1
} {1 {}}
test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.12 {Tcl_BinaryObjCmd: scan} {
unset -nocomplain arg1
@@ -2319,19 +2383,19 @@ test binary-59.13 {Tcl_BinaryObjCmd: scan} -setup {
unset -nocomplain arg1
} -returnCodes error -body {
set arg1 1
- binary scan \x3f\xcc\xcc\xcd r1 arg1(a)
+ binary scan \x3F\xCC\xCC\xCD r1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 R2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian {
unset -nocomplain arg1 arg2
set arg1 foo
set arg2 bar
- list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
+ list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-60.1 {[binary format] with NaN} -body {
@@ -2377,11 +2441,27 @@ test binary-62.4 {infinity} ieeeFloatingPoint {
format 0x%016lx $w
} 0xfff0000000000000
test binary-62.5 {infinity} ieeeFloatingPoint {
- binary scan [binary format w 0x7ff0000000000000] q d
+ binary scan [binary format w 0x7FF0000000000000] q d
set d
} Inf
test binary-62.6 {infinity} ieeeFloatingPoint {
- binary scan [binary format w 0xfff0000000000000] q d
+ binary scan [binary format w 0xFFF0000000000000] q d
+ set d
+} -Inf
+test binary-62.7 {infinity} ieeeFloatingPoint {
+ binary scan [binary format r Inf] iu i
+ format 0x%08x $i
+} 0x7f800000
+test binary-62.8 {infinity} ieeeFloatingPoint {
+ binary scan [binary format r -Inf] iu i
+ format 0x%08x $i
+} 0xff800000
+test binary-62.9 {infinity} ieeeFloatingPoint {
+ binary scan [binary format i 0x7F800000] r d
+ set d
+} Inf
+test binary-62.10 {infinity} ieeeFloatingPoint {
+ binary scan [binary format i 0xFF800000] r d
set d
} -Inf
@@ -2389,19 +2469,19 @@ test binary-62.6 {infinity} ieeeFloatingPoint {
test binary-63.1 {NaN} ieeeFloatingPoint {
binary scan [binary format q NaN] w w
- format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
+ format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}]
} 0x7ff0000000000000
test binary-63.2 {NaN} ieeeFloatingPoint {
binary scan [binary format q -NaN] w w
- format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
+ format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}]
} 0xfff0000000000000
test binary-63.3 {NaN} ieeeFloatingPoint {
binary scan [binary format q NaN(3123456789aBc)] w w
- format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
+ format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}]
} 0x7ff3123456789abc
test binary-63.4 {NaN} ieeeFloatingPoint {
binary scan [binary format q {NaN( 3123456789aBc)}] w w
- format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
+ format 0x%016lx [expr {$w & 0xFFF3FFFFFFFFFFFF}]
} 0x7ff3123456789abc
# Make sure TclParseNumber() rejects invalid nan-hex formats [Bug 3402540]
@@ -2480,7 +2560,7 @@ test binary-70.4 {binary encode hex} -body {
binary encode hex [string repeat a 20]
} -result [string repeat 61 20]
test binary-70.5 {binary encode hex} -body {
- binary encode hex \0\1\2\3\4\0\1\2\3\4
+ binary encode hex \x00\x01\x02\x03\x04\x00\x01\x02\x03\x04
} -result {00010203040001020304}
test binary-71.1 {binary decode hex} -body {
@@ -2497,16 +2577,16 @@ test binary-71.4 {binary decode hex} -body {
} -result [string repeat a 20]
test binary-71.5 {binary decode hex} -body {
binary decode hex 00010203040001020304
-} -result "\0\1\2\3\4\0\1\2\3\4"
+} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03\x04"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
-test binary-71.8 {binary decode hex} -body {
+test binary-71.8 {binary decode hex} -match glob -body {
binary decode hex -strict "61 61"
-} -returnCodes error -result {invalid hexadecimal digit " " at position 2}
+} -returnCodes error -result {invalid hexadecimal digit " " * at position 2}
test binary-71.9 {binary decode hex} -body {
set r [binary decode hex "6"]
list [string length $r] $r
@@ -2556,19 +2636,19 @@ test binary-72.4 {binary encode base64} -body {
binary encode base64 [string repeat abc 20]
} -result [string repeat YWJj 20]
test binary-72.5 {binary encode base64} -body {
- binary encode base64 \0\1\2\3\4\0\1\2\3
+ binary encode base64 \x00\x01\x02\x03\x04\x00\x01\x02\x03
} -result {AAECAwQAAQID}
test binary-72.6 {binary encode base64} -body {
- binary encode base64 \0
+ binary encode base64 \x00
} -result {AA==}
test binary-72.7 {binary encode base64} -body {
- binary encode base64 \0\0
+ binary encode base64 \x00\x00
} -result {AAA=}
test binary-72.8 {binary encode base64} -body {
- binary encode base64 \0\0\0
+ binary encode base64 \x00\x00\x00
} -result {AAAA}
test binary-72.9 {binary encode base64} -body {
- binary encode base64 \0\0\0\0
+ binary encode base64 \x00\x00\x00\x00
} -result {AAAAAA==}
test binary-72.10 {binary encode base64} -body {
binary encode base64 -maxlen 0 -wrapchar : abcabcabc
@@ -2628,8 +2708,14 @@ test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-72.29 {binary encode base64} {
- string length [binary encode base64 -maxlen 3 -wrapchar \xca abc]
+ string length [binary encode base64 -maxlen 3 -wrapchar \xCA abc]
} 5
+test binary-72.30 {binary encode base64} {
+ string length [binary encode base64 -maxlen 4294967296 abc]
+} 4
+test binary-72.31 {binary encode base64} -body {
+ string length [binary encode base64 -maxlen 18446744073709551616 abc]
+} -returnCodes 1 -result {integer value too large to represent}
test binary-73.1 {binary decode base64} -body {
binary decode base64
@@ -2645,19 +2731,19 @@ test binary-73.4 {binary decode base64} -body {
} -result [string repeat abc 20]
test binary-73.5 {binary decode base64} -body {
binary decode base64 AAECAwQAAQID
-} -result "\0\1\2\3\4\0\1\2\3"
+} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03"
test binary-73.6 {binary decode base64} -body {
binary decode base64 AA==
-} -result "\0"
+} -result "\x00"
test binary-73.7 {binary decode base64} -body {
binary decode base64 AAA=
-} -result "\0\0"
+} -result "\x00\x00"
test binary-73.8 {binary decode base64} -body {
binary decode base64 AAAA
-} -result "\0\0\0"
+} -result "\x00\x00\x00"
test binary-73.9 {binary decode base64} -body {
binary decode base64 AAAAAA==
-} -result "\0\0\0\0"
+} -result "\x00\x00\x00\x00"
test binary-73.10 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n[string repeat YWJj 10]"
binary decode base64 $s
@@ -2668,11 +2754,11 @@ test binary-73.11 {binary decode base64} -body {
} -result [string repeat abc 20]
test binary-73.12 {binary decode base64} -body {
binary decode base64 -strict ":YWJj"
-} -returnCodes error -match glob -result {invalid base64 character ":" at position 0}
+} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0}
test binary-73.13 {binary decode base64} -body {
set s "[string repeat YWJj 10]:[string repeat YWJj 10]"
binary decode base64 -strict $s
-} -returnCodes error -match glob -result {invalid base64 character ":" at position 40}
+} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40}
test binary-73.14 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 -strict $s
@@ -2775,22 +2861,22 @@ test binary-74.4 {binary encode uuencode} -body {
binary encode uuencode [string repeat abc 20]
} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n"
test binary-74.5 {binary encode uuencode} -body {
- binary encode uuencode \0\1\2\3\4\0\1\2\3
+ binary encode uuencode \x00\x01\x02\x03\x04\x00\x01\x02\x03
} -result ")``\$\"`P0``0(#\n"
test binary-74.6 {binary encode uuencode} -body {
binary encode uuencode \0
} -result {!``
}
test binary-74.7 {binary encode uuencode} -body {
- binary encode uuencode \0\0
+ binary encode uuencode \x00\x00
} -result "\"```
"
test binary-74.8 {binary encode uuencode} -body {
- binary encode uuencode \0\0\0
+ binary encode uuencode \x00\x00\x00
} -result {#````
}
test binary-74.9 {binary encode uuencode} -body {
- binary encode uuencode \0\0\0\0
+ binary encode uuencode \x00\x00\x00\x00
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
@@ -2826,7 +2912,7 @@ test binary-75.4 {binary decode uuencode} -body {
} -result [string repeat abc 20]
test binary-75.5 {binary decode uuencode} -body {
binary decode uuencode ")``\$\"`P0``0(#"
-} -result "\0\1\2\3\4\0\1\2\3"
+} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03"
test binary-75.6 {binary decode uuencode} -body {
string length [binary decode uuencode "`\n"]
} -result 0
@@ -2849,11 +2935,11 @@ test binary-75.11 {binary decode uuencode} -body {
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
-} -returnCodes error -match glob -result {invalid uuencode character "|" at position 0}
+} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0}
test binary-75.13 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]|[string repeat 86)C 10]"
binary decode uuencode -strict $s
-} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41}
+} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41}
test binary-75.14 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]"
binary decode uuencode -strict $s
@@ -2881,7 +2967,7 @@ test binary-75.24 {binary decode uuencode} -body {
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
-} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5}
+} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5}
test binary-75.26 {binary decode uuencode} -body {
string length [binary decode uuencode " "]
} -result 0
@@ -2905,6 +2991,26 @@ test binary-76.2 {binary string appending growth algorithm} win {
string length [append str [binary format a* foo]]
} 3
+test binary-77.1 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ return [binary format H* $a][binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+test binary-77.2 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ set one [binary format H* $a]
+ return $one[binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+
+test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
+ # just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3):
+ binary encode hex \U0001f415
+ binary scan \U0001f415 a* v; set v
+ set str {}
+} -result {}
+
+
testConstraint testsetbytearraylength \
[expr {"testsetbytearraylength" in [info commands]}]
@@ -2912,10 +3018,22 @@ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat A B C] 1
} A
test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
- testsetbytearraylength [string cat \u0141 B C] 1
+ testsetbytearraylength [string cat Ł B C] 1
} A
-
+test binary-80.1 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring "乎"
+} -result "expected byte sequence but character 0 was '乎' (U+004E4E)"
+test binary-80.2 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"]
+} -result "expected byte sequence but character 4 was '乎' (U+004E4E)"
+test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"]
+} -result "expected byte sequence but character 4 was '乎' (U+004E4E)"
+test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
+ testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"]
+} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)"
+
# ----------------------------------------------------------------------
# cleanup
diff --git a/tests/case.test b/tests/case.test
index d32d7d3..1c12e3a 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -4,13 +4,18 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
+if {![llength [info commands case]]} {
+ # No "case" command? So no need to test
+ return
+}
+
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
diff --git a/tests/chan.test b/tests/chan.test
index 5d05935..4155c36 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -2,7 +2,7 @@
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
-# Copyright (c) 2005 Donal K. Fellows
+# Copyright © 2005 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -48,20 +48,20 @@ test chan-4.1 {chan command: configure subcommand} -body {
chan configure
} -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
- chan configure stdout -eofchar \u0100
+ chan configure stdout -eofchar Ā
} -returnCodes error -match glob -result {bad value*}
test chan-4.3 {chan command: [Bug 800753]} -body {
- chan configure stdout -eofchar \u0000
+ 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 {}]
-} -returnCodes ok -result {}
+} -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]
-} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
+} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
test chan-5.1 {chan command: copy subcommand} -body {
chan copy foo
diff --git a/tests/chanio.test b/tests/chanio.test
index aef6a1b..f3461f0 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -6,19 +6,24 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::io {
- namespace import ::tcltest::*
+
+ if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+ }
variable umaskValue
variable path
@@ -31,8 +36,8 @@ namespace eval ::tcl::test::io {
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
- set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+ package require -exact tcl::test [info patchlevel]
+ set ::tcltestlib [info loaded {} Tcltest]
}
source [file join [file dirname [info script]] tcltests.tcl]
@@ -47,6 +52,7 @@ namespace eval ::tcl::test::io {
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]
+ testConstraint specialfiles [expr {[file exists /dev/zero] || [file exists NUL]}]
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
@@ -76,7 +82,7 @@ namespace eval ::tcl::test::io {
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
- chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A
+ chan configure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A"
chan configure stdout -encoding binary -translation lf -buffering none
chan event $f readable "foo $f"
proc foo {f} {
@@ -112,14 +118,14 @@ set path(test1) [makeFile {} test1]
test chan-io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
chan configure $f -encoding binary
- chan puts -nonewline $f a\u4E4D\x00
+ chan puts -nonewline $f "a\x4D\x00"
chan close $f
contents $path(test1)
} aM\x00
test chan-io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
chan configure $f -encoding shiftjis
- chan puts -nonewline $f "a\u4E4D\0"
+ chan puts -nonewline $f "a乍\x00"
chan close $f
contents $path(test1)
} "a\x93\xE1\x00"
@@ -248,7 +254,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod
test chan-io-3.4 {WriteChars: loop over stage buffer} -body {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
- chan configure $f -encoding jis0208 -buffersize 16
+ chan configure $f -encoding jis0208 -buffersize 16 -profile tcl8
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
chan close $f
@@ -261,7 +267,7 @@ test chan-io-3.5 {WriteChars: saved != 0} -body {
# be moved to beginning of next channel buffer to preserve requested
# buffersize.
set f [open $path(test1) w]
- chan configure $f -encoding jis0208 -buffersize 17
+ chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
chan close $f
@@ -274,13 +280,13 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body {
# to the beginning of that UTF-8 character and try again.
#
# Translate the first 16 bytes, produce 14 bytes of output, 2 left over
- # (first two bytes of \uFF21 in UTF-8). Given those two bytes try
+ # (first two bytes of A in UTF-8). Given those two bytes try
# translating them again, find that no bytes are read produced, and break
# to outer loop where those two bytes will have the remaining 4 bytes (the
- # last byte of \uFF21 plus the all of \uFF22) appended.
+ # last byte of A plus the all of B) appended.
set f [open $path(test1) w]
chan configure $f -encoding shiftjis -buffersize 16
- chan puts -nonewline $f 12345678901234\uFF21\uFF22
+ chan puts -nonewline $f 12345678901234AB
set x [list [contents $path(test1)]]
chan close $f
lappend x [contents $path(test1)]
@@ -294,7 +300,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body {
# on flush. The truncated bytes are moved to the beginning of the next
# channel buffer.
set f [open $path(test1) w]
- chan configure $f -encoding jis0208 -buffersize 17
+ chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
chan close $f
@@ -428,7 +434,7 @@ test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body {
test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body {
set f [open $path(test1) w]
chan configure $f -translation binary
- chan puts $f "\x81\u1234\x00"
+ chan puts $f "\x81\x34\x00"
chan close $f
set f [open $path(test1)]
chan configure $f -translation binary
@@ -446,7 +452,7 @@ test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body {
list [chan gets $f line] $line
} -cleanup {
chan close $f
-} -result [list 2 "\u4E00\u4E01"]
+} -result [list 2 "一丁"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
@@ -477,17 +483,17 @@ test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body {
chan puts $f "abcdef\x1Aghijk\nwombat"
chan close $f
set f [open $path(test1)]
- chan configure $f -eofchar \x1A
+ chan configure $f -eofchar "\x1A \x1A"
list [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
} -result {6 abcdef -1 {}}
test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body {
set f [open $path(test1) w]
- chan puts $f "abcdefghijk\nwom\u001Abat"
+ chan puts $f "abcdefghijk\nwom\x1Abat"
chan close $f
set f [open $path(test1)]
- chan configure $f -eofchar \x1A
+ chan configure $f -eofchar "\x1A \x1A"
list [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
@@ -902,7 +908,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup
# Tcl_ExternalToUtf()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
- chan configure $f -encoding unicode
+ chan configure $f -encoding utf-16
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
@@ -995,7 +1001,7 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b
chan puts -nonewline $f "123456\x1Ak9012345\r"
chan close $f
set f [open $path(test1)]
- chan configure $f -eofchar \x1A
+ chan configure $f -eofchar "\x1A \x1A"
list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]
} -cleanup {
chan close $f
@@ -1023,14 +1029,14 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} -body {
# Tcl_ExternalToUtf(), make sure state updated
set f [open $path(test1) w]
chan configure $f -encoding iso2022-jp
- chan puts $f "there\u4E00ok\n\u4E01more bytes\nhere"
+ chan puts $f "there一ok\n丁more bytes\nhere"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding iso2022-jp
list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
chan close $f
-} -result [list 8 "there\u4E00ok" 11 "\u4E01more bytes" 4 "here"]
+} -result [list 8 "there一ok" 11 "丁more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
update
variable x {}
@@ -1064,14 +1070,14 @@ test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body {
# (result == TCL_CONVERT_MULTIBYTE)
set f [open $path(test1) w]
chan configure $f -encoding shiftjis
- chan puts $f "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14\nend"
+ chan puts $f "123456789012301234\nend"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis -buffersize 16
chan gets $f
} -cleanup {
chan close $f
-} -result "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14"
+} -result "123456789012301234"
test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
@@ -1092,13 +1098,13 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
- chan configure $f -encoding shiftjis
+ chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
-} -result [list 16 "1234567890123\uFF10\uFF11\x82" 18 0 1 -1 ""]
+} -result [list 16 "123456789012301\x82" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
} -constraints {stdio fileevent} -body {
@@ -1117,7 +1123,7 @@ test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
return $x
} -cleanup {
chan close $f
-} -result [list -1 "" 1 17 "1234567890123\uFF10\uFF11\uFF12\uFF13" 0]
+} -result [list -1 "" 1 17 "12345678901230123" 0]
test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body {
# (bufPtr->nextPtr == NULL)
@@ -1143,7 +1149,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup {
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
}]
- chan configure $f -encoding unicode -buffersize 16 -blocking 0
+ chan configure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
chan configure $f -translation auto -encoding ascii -blocking 1
# here
@@ -1375,7 +1381,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup {
return $x
} -cleanup {
chan close $f
-} -result [list "123456789012345" 1 \u672C 0]
+} -result [list "123456789012345" 1 本 0]
test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
variable x {}
} -constraints {stdio fileevent} -body {
@@ -1408,7 +1414,7 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} -setup {
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {chan close $f} msg] $msg
-} -result "{} timeout {} timeout \u7266 {} eof 0 {}"
+} -result "{} timeout {} timeout 牦 {} eof 0 {}"
test chan-io-13.1 {TranslateInputEOL: cr mode} -body {
set f [open $path(test1) w]
@@ -3101,7 +3107,7 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup {
chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan read $f
} -cleanup {
chan close $f
@@ -3114,11 +3120,11 @@ test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup {
file delete $path(test1)
} -constraints {win} -body {
set f [open $path(test1) w]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan puts $f hello\nthere\nand\rhere
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan read $f
} -cleanup {
chan close $f
@@ -3136,7 +3142,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup {
chan puts $f $s
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3157,7 +3163,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup {
chan puts $f $s
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3235,7 +3241,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup {
chan puts $f [format abc\ndef\n%cqrs\ntuv 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3249,7 +3255,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup {
chan puts $f $c
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3263,7 +3269,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup {
chan puts $f $c
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3277,7 +3283,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup {
chan puts $f $c
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3291,7 +3297,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup {
chan puts $f $c
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3305,7 +3311,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup {
chan puts $f $c
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
list [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -3656,7 +3662,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup {
chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3672,11 +3678,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup {
set l ""
} -body {
set f [open $path(test1) w]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan puts $f hello\nthere\nand\rhere
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan gets $f]
@@ -3696,7 +3702,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3714,7 +3720,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar}
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3798,7 +3804,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3816,7 +3822,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3834,7 +3840,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3852,7 +3858,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3870,7 +3876,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -3888,7 +3894,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup {
chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
lappend l [chan gets $f]
lappend l [chan gets $f]
lappend l [chan eof $f]
@@ -4644,12 +4650,12 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4658,12 +4664,12 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4672,12 +4678,12 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4686,12 +4692,12 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4700,12 +4706,12 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4714,12 +4720,12 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup {
file delete $path(test1)
} -body {
set f [open $path(test1) w]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
chan puts $f abc\ndef
chan close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
list $s [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4733,7 +4739,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4747,7 +4753,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4761,7 +4767,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4775,7 +4781,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4789,7 +4795,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4803,7 +4809,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup {
chan close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
list $c [string length [chan read $f]] [chan eof $f]
} -cleanup {
chan close $f
@@ -4976,7 +4982,7 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup {
test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
- chan configure $chan -buffersize 10
+ chan configure $chan -buffersize 10 -encoding utf-8
set var [chan read $chan 2]
chan configure $chan -buffersize 32
append var [chan read $chan]
@@ -5180,7 +5186,7 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
chan read $f
} -cleanup {
chan close $f
-} -result \u7266
+} -result 牦
test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
file delete $path(test1)
} -body {
@@ -5193,7 +5199,7 @@ test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
chan read $f
} -cleanup {
chan close $f
-} -result \u7266
+} -result 牦
test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup {
file delete $path(test1)
set f [open $path(test1) w]
@@ -5286,7 +5292,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar {ON GO}
lappend l [chan configure $f1 -eofchar]
- chan configure $f1 -eofchar D
+ chan configure $f1 -eofchar {D D}
lappend l [chan configure $f1 -eofchar]
} -cleanup {
chan close $f1
@@ -5298,7 +5304,7 @@ test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup {
set f1 [open $path(test1) w+]
chan configure $f1 -eofchar {ON GO}
lappend l [chan configure $f1 -eofchar]
- chan configure $f1 -eofchar D
+ chan configure $f1 -eofchar {D D}
lappend l [chan configure $f1 -eofchar]
lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg]
} -cleanup {
@@ -5518,6 +5524,60 @@ test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body {
chan event gorp who-knows
} -returnCodes error -result {bad event name "who-knows": must be readable or writable}
+
+test chan-io-41.6 {Tcl_FileeventCmd: directory} -constraints {fileevent unix} -setup {
+ set tempdir [::tcltests::tempdir]
+} -body {
+ set chan [open $tempdir]
+ chan event $chan readable [list ::apply [list {} {
+ variable success
+ set success 1
+ } [namespace current]]]
+ vwait [namespace current]::success
+ return $success
+} -cleanup {
+ close $chan
+ file delete -force tempdir
+} -result 1
+
+
+test chan-io-41.7 {Tcl_FileeventCmd: special} -constraints {
+ fileevent specialfiles
+} -body {
+ set special /dev/zero
+ if {![file exists $special]} {
+ set special NUL
+ }
+ set chan [open $special]
+ chan event $chan readable [list ::apply [list {} {
+ variable success
+ set success 1
+ } [namespace current]]]
+ vwait [namespace current]::success
+ return $success
+} -cleanup {
+ close $chan
+} -result 1
+
+
+test chan-io-41.8 {Tcl_FileeventCmd: symbolic link} -constraints {fileevent unix} -setup {
+ set tempdir [::tcltests::tempdir]
+} -body {
+ set target [makeFile {not again} thefile $tempdir]
+ set link [file join $tempdir thelin]
+ file link -symbolic $link $target
+ set chan [open $link]
+ chan event $chan readable [list ::apply [list {} {
+ variable success
+ set success 1
+ } [namespace current]]]
+ vwait [namespace current]::success
+ return $success
+} -cleanup {
+ close $chan
+ file delete -force $tempdir
+} -result 1
+
#
# Test chan event on a file
#
@@ -5991,7 +6051,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6015,7 +6075,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode}
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6039,7 +6099,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6063,7 +6123,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode}
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6087,7 +6147,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6111,7 +6171,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation auto -eofchar \x1A
+ chan configure $f -translation auto -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6135,7 +6195,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} -
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6159,7 +6219,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode}
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation lf -eofchar \x1A
+ chan configure $f -translation lf -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6183,7 +6243,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} -
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6207,7 +6267,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode}
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation cr -eofchar \x1A
+ chan configure $f -translation cr -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6231,7 +6291,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod
chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6255,7 +6315,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} -
chan puts -nonewline $f [format "abc\ndef\n%c" 26]
chan close $f
set f [open $path(test1) r]
- chan configure $f -translation crlf -eofchar \x1A
+ chan configure $f -translation crlf -eofchar "\x1A \x1A"
chan event $f readable [namespace code {
if {[chan eof $f]} {
set x done
@@ -6792,7 +6852,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
chan configure $out -encoding koi8-r -translation lf
-chan puts $out \u0410\u0410
+chan puts $out АА
chan close $out
test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} {
# Copy kyrillic to UTF-8, using chan copy.
@@ -6815,7 +6875,7 @@ test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} {
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
-test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} {
+test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body {
# encoding to binary (=> implies that the internal utf-8 is written)
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
@@ -6823,14 +6883,16 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} {
# -translation binary is also -encoding binary
chan configure $out -translation binary
chan copy $in $out
+ file size $path(utf8-fcopy.txt)
+} -cleanup {
chan close $in
chan close $out
- file size $path(utf8-fcopy.txt)
-} 5
+ unset in out
+} -result 5
test chan-io-52.11 {TclCopyChannel & encodings} -setup {
set f [open $path(utf8-fcopy.txt) w]
fconfigure $f -encoding utf-8 -translation lf
- puts $f \u0410\u0410
+ puts $f АА
close $f
} -constraints {fcopy} -body {
# binary to encoding => the input has to be in utf-8 to make sense to the
@@ -7528,7 +7590,7 @@ test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# 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 {} catch {error writing "stdout": invalid argument}}}
+} {1 {gets {} catch {error writing "stdout": invalid or incomplete multibyte or wide character}}}
test chan-io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
diff --git a/tests/clock.test b/tests/clock.test
index 98a065e..7bcc002 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -6,7 +6,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+# Copyright © 2004 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -32,10 +32,6 @@ testConstraint detroit \
testConstraint y2038 \
[expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]
-if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
- namespace import ::tcl::unsupported::timerate
-}
-
# TEST PLAN
# clock-1:
@@ -238,7 +234,7 @@ namespace eval ::testClock {
Bias 300 \
StandardBias 0 \
DaylightBias -60 \
- StandardStart \x00\x00\x0b\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \
+ StandardStart \x00\x00\x0B\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \
DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]]
}
@@ -35488,7 +35484,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} {
expr {
($end > $start) && (($end - $start) <= 60) ?
"ok" :
- "test should have taken 0-60 ms, actually took [expr $end - $start]"}
+ "test should have taken 0-60 ms, actually took [expr {$end - $start}]"}
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
# This test can fail on a system that is so heavily loaded that
@@ -35504,7 +35500,7 @@ test clock-33.5a {clock tests, millisecond timing test} {
expr {
($end > $start) && (($end - $start) <= 60) ?
"ok" :
- "test should have taken 0-60 ms, actually took [expr $end - $start]"}
+ "test should have taken 0-60 ms, actually took [expr {$end - $start}]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
@@ -36815,16 +36811,16 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{
-body {
set trouble {}
foreach {date jdate} {
- 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
- 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
- 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
- 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
- 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
- 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
- 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
- 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
- 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
- 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
+ 1872-12-31 西暦1872年12月31日
+ 1873-01-01 明治06年01月01日
+ 1912-07-29 明治45年07月29日
+ 1912-07-30 大正01年07月30日
+ 1926-12-24 大正15年12月24日
+ 1926-12-25 昭和01年12月25日
+ 1989-01-07 昭和64年01月07日
+ 1989-01-08 平成01年01月08日
+ 2019-04-30 平成31年04月30日
+ 2019-05-01 令和01年05月01日
} {
set status [catch {
set secs [clock scan $date \
@@ -36956,10 +36952,10 @@ test clock-61.2 {overflow of a wide integer on output} {*}{
}
test clock-61.3 {near-miss overflow of a wide integer on output} {
clock format 0x7fffffffffffffff -format %s -gmt true
-} [expr 0x7fffffffffffffff]
+} [expr {0x7fffffffffffffff}]
test clock-61.4 {near-miss overflow of a wide integer on output} {
clock format -0x8000000000000000 -format %s -gmt true
-} [expr -0x8000000000000000]
+} [expr {-0x8000000000000000}]
test clock-62.1 {Bug 1902423} {*}{
-setup {::tcl::clock::ClearCaches}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 526c261..7cae5c8 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -4,23 +4,24 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1998 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1996-1998 Sun Microsystems, Inc.
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.1
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint time64bit [expr {
$::tcl_platform(pointerSize) >= 8 ||
[llength [info command testsize]] && [testsize st_mtime] >= 8
@@ -30,6 +31,8 @@ testConstraint linkDirectory [expr {
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
+# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]
global env
@@ -170,77 +173,502 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} {
list [catch {continue} msg] $msg
} {4 {}}
-test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body {
+###
+# encoding command
+
+set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl::encoding::)system \?encoding\?"$}
+set "numargErrors(encoding convertfrom)" {wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertfrom data"}
+set "numargErrors(encoding convertto)" {wrong # args: should be "(encoding |::tcl::encoding::)convertto \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertto data"}
+set "numargErrors(encoding names)" {wrong # args: should be "encoding names"}
+set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"}
+
+source [file join [file dirname [info script]] encodingVectors.tcl]
+
+
+# Maps utf-{16,32}{le,be} to utf-16, utf-32 and
+# others to "". Used to test utf-16, utf-32 based
+# on system endianness
+proc endianUtf {enc} {
+ if {$::tcl_platform(byteOrder) eq "littleEndian"} {
+ set endian le
+ } else {
+ set endian be
+ }
+ if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} {
+ return [string range $enc 0 5]
+ }
+ return ""
+}
+
+#
+# Check errors for invalid number of arguments
+proc badnumargs {id cmd cmdargs} {
+ variable numargErrors
+ test $id.a "Syntax error: $cmd $cmdargs" \
+ -body [list {*}$cmd {*}$cmdargs] \
+ -result $numargErrors($cmd) \
+ -match regexp \
+ -returnCodes error
+ test $id.b "Syntax error: $cmd (byte compiled)" \
+ -setup [list proc compiled_proc {} [list {*}$cmd {*}$cmdargs]] \
+ -body {compiled_proc} \
+ -cleanup {rename compiled_proc {}} \
+ -result $numargErrors($cmd) \
+ -match regexp \
+ -returnCodes error
+}
+
+# Wraps tests resulting in unknown encoding errors
+proc unknownencodingtest {id cmd} {
+ set result "unknown encoding \"[lindex $cmd end-1]\""
+ test $id.a "Unknown encoding error: $cmd" \
+ -body [list encoding {*}$cmd] \
+ -result $result \
+ -returnCodes error
+ test $id.b "Syntax error: $cmd (byte compiled)" \
+ -setup [list proc encoding_test {} [list encoding {*}$cmd]] \
+ -body {encoding_test} \
+ -cleanup {rename encoding_test {}} \
+ -result $result \
+ -returnCodes error
+}
+
+# Wraps tests for conversion, successful or not.
+# Really more general than just for encoding conversion.
+proc testconvert {id body result args} {
+ test $id.a $body \
+ -body $body \
+ -result $result \
+ {*}$args
+ dict append args -setup \n[list proc compiled_script {} $body]
+ dict append args -cleanup "\nrename compiled_script {}"
+ test $id.b "$body (byte compiled)" \
+ -body {compiled_script} \
+ -result $result \
+ {*}$args
+}
+
+# Wrapper to verify encoding convert{to,from} ?-profile?
+# Generates tests for compiled and uncompiled implementation.
+# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be}
+# The enc and profile are appended to id to generate the test id
+proc testprofile {id converter enc profile data result args} {
+ testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args
+ if {[set enc2 [endianUtf $enc]] ne ""} {
+ # If utf{16,32}-{le,be}, also do utf{16,32}
+ testconvert $id.$enc2.$profile [list encoding $converter -profile $profile $enc2 $data] $result {*}$args
+ }
+
+ # If this is the default profile, generate a test without specifying profile
+ if {$profile eq $::encDefaultProfile} {
+ testconvert $id.$enc.default [list encoding $converter $enc $data] $result {*}$args
+ if {[set enc2 [endianUtf $enc]] ne ""} {
+ # If utf{16,32}-{le,be}, also do utf{16,32}
+ testconvert $id.$enc2.default [list encoding $converter $enc2 $data] $result {*}$args
+ }
+ }
+}
+
+
+# Wrapper to verify encoding convert{to,from} -failindex ?-profile?
+# Generates tests for compiled and uncompiled implementation.
+# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be}
+# The enc and profile are appended to id to generate the test id
+proc testfailindex {id converter enc data result failidx {profile default}} {
+ testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc [list $data]\] \[set idx\]" [list $result $failidx]
+ if {[set enc2 [endianUtf $enc]] ne ""} {
+ # If utf{16,32}-{le,be}, also do utf{16,32}
+ testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx]
+ }
+
+ # If this is the default profile, generate a test without specifying profile
+ if {$profile eq $::encDefaultProfile} {
+ testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc [list $data]\] \[set idx]" [list $result $failidx]
+ if {[set enc2 [endianUtf $enc]] ne ""} {
+ # If utf{16,32}-{le,be}, also do utf{16,32}
+ testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx]
+ }
+ }
+}
+
+test cmdAH-4.1.1 {encoding} -returnCodes error -body {
encoding
} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
-test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
+test cmdAH-4.1.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 ?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 {
+} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, or system}
+
+#
+# encoding system 4.2.*
+badnumargs cmdAH-4.2.1 {encoding system} {ascii ascii}
+test cmdAH-4.2.2 {Tcl_EncodingObjCmd} -setup {
set system [encoding system]
} -body {
- encoding system jis0208
- encoding convertto \u4e4e
+ encoding system iso8859-1
+ encoding system
} -cleanup {
encoding system $system
-} -result 8C
-test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup {
+} -result iso8859-1
+
+#
+# encoding convertfrom 4.3.*
+
+# Odd number of args is always invalid since last two args
+# are ENCODING DATA and all options take a value
+badnumargs cmdAH-4.3.1 {encoding convertfrom} {}
+badnumargs cmdAH-4.3.2 {encoding convertfrom} {-failindex VAR ABC}
+badnumargs cmdAH-4.3.3 {encoding convertfrom} {-profile VAR ABC}
+badnumargs cmdAH-4.3.4 {encoding convertfrom} {-failindex VAR -profile strict ABC}
+badnumargs cmdAH-4.3.5 {encoding convertfrom} {-profile strict -failindex VAR ABC}
+
+# Test that last two args always treated as ENCODING DATA
+unknownencodingtest cmdAH-4.3.6 {convertfrom -failindex ABC}
+unknownencodingtest cmdAH-4.3.7 {convertfrom -profile ABC}
+unknownencodingtest cmdAH-4.3.8 {convertfrom nosuchencoding ABC}
+unknownencodingtest cmdAH-4.3.9 {convertfrom -failindex VAR -profile ABC}
+unknownencodingtest cmdAH-4.3.10 {convertfrom -profile strict -failindex ABC}
+testconvert cmdAH-4.3.11 {
+ encoding convertfrom jis0208 \x38\x43
+} 乎 -setup {
set system [encoding system]
-} -body {
encoding system iso8859-1
- encoding convertto jis0208 \u4e4e
} -cleanup {
encoding system $system
-} -result 8C
-test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body {
- encoding convertfrom
-} -result {wrong # args: should be "encoding convertfrom ?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 {
+}
+
+# Verify single arg defaults to system encoding
+testconvert cmdAH-4.3.12 {
+ encoding convertfrom \x38\x43
+} 乎 -setup {
set system [encoding system]
-} -body {
encoding system jis0208
- encoding convertfrom 8C
} -cleanup {
encoding system $system
-} -result \u4e4e
-test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup {
+}
+
+# convertfrom ?-profile? : valid byte sequences
+foreach {enc str hex ctrl comment} $encValidStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc A]
+ set suffix_bytes [encoding convertto $enc B]
+ foreach profile $encProfiles {
+ testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes $str
+ testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes $str$suffix
+ testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes $prefix$str
+ testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix
+ }
+}
+
+# convertfrom ?-profile? : invalid byte sequences
+foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary format H* $hex]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc $prefix]
+ set suffix_bytes [encoding convertto $enc $suffix]
+ set prefixLen [string length $prefix_bytes]
+ set result [list $str]
+ # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch
+ # so glob it out in error message pattern for now.
+ set errorWithoutPrefix [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob]
+ set errorWithPrefix [list "unexpected byte sequence starting at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob]
+ if {$ctrl eq {} || "solo" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $str]
+ } else {
+ set result $errorWithoutPrefix
+ }
+ testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes {*}$result
+ }
+ if {$ctrl eq {} || "lead" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $str$suffix]
+ } else {
+ set result $errorWithoutPrefix
+ }
+ testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes {*}$result
+ }
+ if {$ctrl eq {} || "tail" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $prefix$str]
+ } else {
+ set result $errorWithPrefix
+ }
+ testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes {*}$result
+ }
+ if {$ctrl eq {} || "middle" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $prefix$str$suffix]
+ } else {
+ set result $errorWithPrefix
+ }
+ testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes {*}$result
+ }
+}
+
+# convertfrom -failindex ?-profile? - valid data
+foreach {enc str hex ctrl comment} $encValidStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc $prefix]
+ set suffix_bytes [encoding convertto $enc $suffix]
+ foreach profile $encProfiles {
+ testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str -1 $profile
+ testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $str$suffix -1 $profile
+ testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $prefix$str -1 $profile
+ testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix -1 $profile
+ }
+}
+
+# convertfrom -failindex ?-profile? - invalid data
+foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes {
+ if {"knownBug" in $ctrl} continue
+ # There are multiple test cases based on location of invalid bytes
+ set bytes [binary decode hex $hex]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc $prefix]
+ set suffix_bytes [encoding convertto $enc $suffix]
+ set prefixLen [string length $prefix_bytes]
+ if {$ctrl eq {} || "solo" in $ctrl} {
+ testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str $failidx $profile
+ }
+ if {$ctrl eq {} || "lead" in $ctrl} {
+ if {$failidx == -1} {
+ # If success expected
+ set result $str$suffix
+ } else {
+ # Failure expected
+ set result ""
+ }
+ testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $result $failidx $profile
+ }
+ if {$ctrl eq {} || "tail" in $ctrl} {
+ set expected_failidx $failidx
+ if {$failidx == -1} {
+ # If success expected
+ set result $prefix$str
+ } else {
+ # Failure expected
+ set result $prefix
+ incr expected_failidx $prefixLen
+ }
+ testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $result $expected_failidx $profile
+ }
+ if {$ctrl eq {} || "middle" in $ctrl} {
+ set expected_failidx $failidx
+ if {$failidx == -1} {
+ # If success expected
+ set result $prefix$str$suffix
+ } else {
+ # Failure expected
+ set result $prefix
+ incr expected_failidx $prefixLen
+ }
+ testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $result $expected_failidx $profile
+ }
+}
+
+#
+# encoding convertto 4.4.*
+
+badnumargs cmdAH-4.4.1 {encoding convertto} {}
+badnumargs cmdAH-4.4.2 {encoding convertto} {-failindex VAR ABC}
+badnumargs cmdAH-4.4.3 {encoding convertto} {-profile VAR ABC}
+badnumargs cmdAH-4.4.4 {encoding convertto} {-failindex VAR -profile strict ABC}
+badnumargs cmdAH-4.4.5 {encoding convertto} {-profile strict -failindex VAR ABC}
+
+# Test that last two args always treated as ENCODING DATA
+unknownencodingtest cmdAH-4.4.6 {convertto -failindex ABC}
+unknownencodingtest cmdAH-4.4.7 {convertto -profile ABC}
+unknownencodingtest cmdAH-4.4.8 {convertto nosuchencoding ABC}
+unknownencodingtest cmdAH-4.4.9 {convertto -failindex VAR -profile ABC}
+unknownencodingtest cmdAH-4.4.10 {convertto -profile strict -failindex ABC}
+testconvert cmdAH-4.4.11 {
+ encoding convertto jis0208 乎
+} \x38\x43 -setup {
set system [encoding system]
-} -body {
encoding system iso8859-1
- encoding convertfrom jis0208 8C
} -cleanup {
encoding system $system
-} -result \u4e4e
-test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body {
- encoding names foo
-} -result {wrong # args: should be "encoding names"}
-test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body {
- encoding system foo bar
-} -result {wrong # args: should be "encoding system ?encoding?"}
-test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup {
+}
+
+# Verify single arg defaults to system encoding
+testconvert cmdAH-4.4.12 {
+ encoding convertto 乎
+} \x38\x43 -setup {
set system [encoding system]
-} -body {
- encoding system iso8859-1
- encoding system
+ encoding system jis0208
} -cleanup {
encoding system $system
-} -result iso8859-1
+}
+
+# convertto ?-profile? : valid byte sequences
+
+foreach {enc str hex ctrl comment} $encValidStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set printable [tcltest::Asciify $str]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc A]
+ set suffix_bytes [encoding convertto $enc B]
+ foreach profile $encProfiles {
+ testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str $bytes
+ testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix $bytes$suffix_bytes
+ testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str $prefix_bytes$bytes
+ testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes
+ }
+}
+
+# convertto ?-profile? : invalid byte sequences
+foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set printable [tcltest::Asciify $str]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc $prefix]
+ set suffix_bytes [encoding convertto $enc $suffix]
+ set prefixLen [string length $prefix_bytes]
+ set result [list $bytes]
+ # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch
+ # so glob it out in error message pattern for now.
+ set errorWithoutPrefix [list "unexpected character at index $failidx: *" -returnCodes error -match glob]
+ set errorWithPrefix [list "unexpected character at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob]
+ if {$ctrl eq {} || "solo" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $bytes]
+ } else {
+ set result $errorWithoutPrefix
+ }
+ testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str {*}$result
+ }
+ if {$ctrl eq {} || "lead" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $bytes$suffix_bytes]
+ } else {
+ set result $errorWithoutPrefix
+ }
+ testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix {*}$result
+ }
+ if {$ctrl eq {} || "tail" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $prefix_bytes$bytes]
+ } else {
+ set result $errorWithPrefix
+ }
+ testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str {*}$result
+ }
+ if {$ctrl eq {} || "middle" in $ctrl} {
+ if {$failidx == -1} {
+ set result [list $prefix_bytes$bytes$suffix_bytes]
+ } else {
+ set result $errorWithPrefix
+ }
+ testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix {*}$result
+ }
+}
+
+# convertto -failindex ?-profile? - valid data
+foreach {enc str hex ctrl comment} $encValidStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set printable [tcltest::Asciify $str]
+ set prefix A
+ set suffix B
+ set prefix_bytes [encoding convertto $enc A]
+ set suffix_bytes [encoding convertto $enc B]
+ foreach profile $encProfiles {
+ testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str $bytes -1 $profile
+ testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix $bytes$suffix_bytes -1 $profile
+ testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str $prefix_bytes$bytes -1 $profile
+ testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes -1 $profile
+ }
+}
+
+# convertto -failindex ?-profile? - invalid data
+foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
+ if {"knownBug" in $ctrl} continue
+ set bytes [binary decode hex $hex]
+ set printable [tcltest::Asciify $str]
+ set prefix A
+ set suffix B
+ set prefixLen [string length [encoding convertto $enc $prefix]]
+ if {$ctrl eq {} || "solo" in $ctrl} {
+ testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str $bytes $failidx $profile
+ }
+ if {$ctrl eq {} || "lead" in $ctrl} {
+ if {$failidx == -1} {
+ # If success expected
+ set result $bytes$suffix
+ } else {
+ # Failure expected
+ set result ""
+ }
+ testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix $result $failidx $profile
+ }
+ if {$ctrl eq {} || "tail" in $ctrl} {
+ set expected_failidx $failidx
+ if {$failidx == -1} {
+ # If success expected
+ set result $prefix$bytes
+ } else {
+ # Failure expected
+ set result $prefix
+ incr expected_failidx $prefixLen
+ }
+ testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str $result $expected_failidx $profile
+ }
+ if {$ctrl eq {} || "middle" in $ctrl} {
+ set expected_failidx $failidx
+ if {$failidx == -1} {
+ # If success expected
+ set result $prefix$bytes$suffix
+ } else {
+ # Failure expected
+ set result $prefix
+ incr expected_failidx $prefixLen
+ }
+ testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix $result $expected_failidx $profile
+ }
+}
+
+test cmdAH-4.4.xx {convertto -profile strict} -constraints {testbytestring knownBug} -body {
+ # TODO - what does testbytestring even test? Invalid UTF8 in the Tcl_Obj bytes field
+ encoding convertto -profile strict utf-8 A[testbytestring \x80]B
+} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'}
+
+#
+# encoding names 4.5.*
+badnumargs cmdAH-4.5.1 {encoding names} {foo}
+test cmdAH-4.5.2 {encoding names should include at least utf-8 and iso8859-1 and at least one more} -body {
+ set names [encoding names]
+ list [expr {"utf-8" in $names}] [expr {"iso8859-1" in $names}] [expr {[llength $names] > 2}]
+} -result {1 1 1}
+
+#
+# encoding profiles 4.6.*
+badnumargs cmdAH-4.6.1 {encoding profiles} {foo}
+test cmdAH-4.6.2 {encoding profiles} -body {
+ lsort [encoding profiles]
+} -result {replace strict tcl8}
+
+#
+# file command
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, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
+} -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"}
@@ -324,19 +752,19 @@ test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform {
test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
file dirname //foo
-} /
+} //foo
test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
file dirname //foo/bar
-} /foo
+} //foo
test cmdAH-8.16 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
file dirname {//foo\/bar/baz}
-} {/foo\/bar}
+} {//foo\/bar}
test cmdAH-8.17 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
file dirname {//foo\/bar/baz/blat}
-} {/foo\/bar/baz}
+} {//foo\/bar/baz}
test cmdAH-8.18 {Tcl_FileObjCmd: dirname} testsetplatform {
testsetplatform unix
file dirname /foo//
@@ -468,7 +896,7 @@ test cmdAH-9.13 {Tcl_FileObjCmd: tail} testsetplatform {
test cmdAH-9.14 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform unix
file tail //foo
-} foo
+} {}
test cmdAH-9.15 {Tcl_FileObjCmd: tail} testsetplatform {
testsetplatform unix
file tail //foo/bar
@@ -966,7 +1394,7 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
} -body {
makeDirectory /tmp/tcl.foo.dir
makeFile 12345 /tmp/tcl.foo.dir/file
- file attributes /tmp/tcl.foo.dir -permissions 0o000
+ file attributes /tmp/tcl.foo.dir -permissions 0
file exists /tmp/tcl.foo.dir/file
} -cleanup {
file attributes /tmp/tcl.foo.dir -permissions 0o775
@@ -1079,10 +1507,10 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0
catch {file link -symbolic $linkfile $gorpfile}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} -returnCodes error -body {
file lstat a
-} -result {wrong # args: should be "file lstat name varName"}
+} -result {could not read "a": no such file or directory}
test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body {
file lstat a b c
-} -result {wrong # args: should be "file lstat name varName"}
+} -result {wrong # args: should be "file lstat name ?varName?"}
test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup {
unset -nocomplain stat
} -constraints {unix nonPortable} -body {
@@ -1221,7 +1649,7 @@ test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup {
set oldfile $file
} -constraints unix -body {
# introduce some non-ascii characters.
- append file \u2022
+ append file •
file delete -force $file
file rename $oldfile $file
set mtime [file mtime $file]
@@ -1246,7 +1674,7 @@ test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup {
set oldfile $file
} -constraints win -body {
# introduce some non-ascii characters.
- append file \u2022
+ append file •
file delete -force $file
file rename $oldfile $file
set mtime [file mtime $file]
@@ -1349,7 +1777,7 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
file owned /
} 0
-test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body {
+test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win notWine} -body {
if {[info exists env(SystemRoot)]} {
file owned $env(SystemRoot)
} else {
@@ -1412,14 +1840,14 @@ catch {file attributes $gorpfile -permissions 0o765}
# stat
test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body {
- file stat _bogus_
-} -result {wrong # args: should be "file stat name varName"}
+ file stat
+} -result {wrong # args: should be "file stat name ?varName?"}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body {
file stat _bogus_ a b
-} -result {wrong # args: should be "file stat name varName"}
+} -result {wrong # args: should be "file stat name ?varName?"}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup {
unset -nocomplain stat
- set stat(blocks) [set stat(blksize) {}]
+ array set stat {blocks {} blksize {}}
} -body {
file stat $gorpfile stat
unset stat(blocks) stat(blksize); # Ignore these fields; not always set
@@ -1512,6 +1940,16 @@ test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints
}
set res
} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
+test cmdAH-28.14 {Tcl_FileObjCmd: stat} -setup {
+ unset -nocomplain stat
+} -body {
+ file stat $gorpfile stat
+ expr {
+ [lsort -stride 2 [array get stat]]
+ eq
+ [lsort -stride 2 [file stat $gorpfile]]
+ }
+} -result {1}
unset -nocomplain stat
# type
@@ -1539,7 +1977,7 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} -constraints {unix} -setup {
} -cleanup {
file delete $linkfile
} -result link
-test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup {
+test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory notWine} -setup {
set tempdir [makeDirectory temp]
} -body {
set linkdir [file join [temporaryDirectory] link.dir]
@@ -1571,7 +2009,7 @@ test cmdAH-29.6.1 {
# 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, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable}
+} -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 *}
@@ -1703,6 +2141,62 @@ test cmdAH-32.6 {file tempfile - templates} -body {
} -constraints {unix nonPortable} -cleanup {
catch {file delete $name}
} -result ok
+
+test cmdAH-33.1 {file tempdir} -body {
+ file tempdir a b
+} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"}
+test cmdAH-33.2 {file tempdir} -body {
+ set d [file tempdir]
+ list [file tail $d] [file exists $d] [file type $d] \
+ [glob -nocomplain -directory $d *]
+} -match glob -result {tcl_* 1 directory {}} -cleanup {
+ catch {file delete $d}
+}
+test cmdAH-33.3 {file tempdir} -body {
+ set d [file tempdir gorp]
+ list [file tail $d] [file exists $d] [file type $d] \
+ [glob -nocomplain -directory $d *]
+} -match glob -result {gorp_* 1 directory {}} -cleanup {
+ catch {file delete $d}
+}
+test cmdAH-33.4 {file tempdir} -setup {
+ set base [file join [temporaryDirectory] gorp]
+ file mkdir $base
+} -body {
+ set pre [glob -nocomplain -directory $base *]
+ set d [file normalize [file tempdir $base/]]
+ list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
+ $pre [glob -nocomplain -directory $d *]
+} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup {
+ catch {file delete -force $base}
+}
+test cmdAH-33.5 {file tempdir} -setup {
+ set base [file join [temporaryDirectory] gorp]
+ file mkdir $base
+} -body {
+ set pre [glob -nocomplain -directory $base *]
+ set d [file normalize [file tempdir $base/gorp]]
+ list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \
+ $pre [glob -nocomplain -directory $d *]
+} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup {
+ catch {file delete -force $base}
+}
+test cmdAH-33.6 {file tempdir: missing parent dir} -setup {
+ set base [file join [temporaryDirectory] gorp]
+ file mkdir $base
+} -returnCodes error -body {
+ file tempdir $base/quux/
+} -cleanup {
+ catch {file delete -force $base}
+} -result {can't create temporary directory: no such file or directory}
+test cmdAH-33.7 {file tempdir: missing parent dir} -setup {
+ set base [file join [temporaryDirectory] gorp]
+ file mkdir $base
+} -returnCodes error -body {
+ file tempdir $base/quux/foobar
+} -cleanup {
+ catch {file delete -force $base}
+} -result {can't create temporary directory: no such file or directory}
# This shouldn't work, but just in case a test above failed...
catch {close $newFileId}
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index e16bfcf..316a945 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -2,8 +2,8 @@
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -13,15 +13,16 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
source [file join [file dirname [info script]] internals.tcl]
namespace import -force ::tcltest::internals::*
-
+
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
@@ -136,7 +137,7 @@ test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body {
} -result {expected integer but got "foo"}
test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body {
lsort -stride 1 bar
-} -result {stride length must be at least 2}
+} -match glob -result {stride length must be between 2 and *}
test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body {
lsort -stride 2 {a b c}
} -result {list size must be a multiple of the stride length}
@@ -149,12 +150,27 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} {
{{b i g} 12345} {{d e m o} 34512}
}
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
+test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii [list \x00 \x7F \x80 \uFFFF]
+} [list \x00 \x7F \x80 \uFFFF]
+test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii -nocase [list \x00 \x7F \x80 \uFFFF]
+} [list \x00 \x7F \x80 \uFFFF]
+test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii [list \x00 \x7F \x80 \U01ffff \uFFFF]
+} [list \x00 \x7F \x80 \uFFFF \U01ffff]
+test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
+ lsort -ascii -nocase [list \x00 \x7F \x80 \U01ffff \uFFFF]
+} [list \x00 \x7F \x80 \uFFFF \U01FFFF]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
-} -returnCodes error -result {index "-2" cannot select an element from any list}
+} -returnCodes error -result {index "-2" out of range}
test cmdIL-1.42 {lsort -stride and-index} -body {
lsort -stride 2 -index -1-1 {a 2 b 1}
-} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+} -returnCodes error -result {index "-1-1" out of range}
+test cmdIL-1.43 {lsort -stride errors} -returnCodes error -body {
+ lsort -stride 4294967296 bar
+} -match glob -result {stride length must be between 2 and *}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
@@ -164,7 +180,7 @@ test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup {
set r 1435753299
proc rand {} {
global r
- set r [expr {(16807 * $r) % (0x7fffffff)}]
+ set r [expr {(16807 * $r) % (0x7FFFFFFF)}]
}
} -body {
for {set i 0} {$i < 150} {incr i} {
@@ -216,13 +232,13 @@ test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+} -returnCodes error -result {index "-1-1" out of range}
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {index "-2" cannot select an element from any list}
+} -returnCodes error -result {index "-2" out of range}
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {element -2 missing from sublist "1 . c"}
+} -returnCodes error -result {element end-4 missing from sublist "1 . c"}
test cmdIL-3.5.5 {SortCompare procedure, -index option} {
lsort -index {} {a b}
} {a b}
@@ -231,13 +247,16 @@ test cmdIL-3.5.6 {SortCompare procedure, -index option} {
} {a \{}
test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {index "end--1" cannot select an element from any list}
+} -returnCodes error -result {index "end--1" out of range}
test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {index "end+1" cannot select an element from any list}
+} -returnCodes error -result {index "end+1" out of range}
test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
-} -returnCodes error -result {index "end+2" cannot select an element from any list}
+} -returnCodes error -result {index "end+2" out of range}
+test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index 0 {{}}
+} -returnCodes error -result {element 0 missing from sublist ""}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
@@ -254,8 +273,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body {
lsort -integer {3 q}
} -returnCodes error -result {expected integer but got "q"}
test cmdIL-3.11 {SortCompare procedure, -integer option} {
- lsort -integer {35 21 0x20 30 0o23 100 8}
-} {8 0o23 21 30 0x20 35 100}
+ lsort -integer {35 21 0x20 0d30 0o23 100 8}
+} {8 0o23 21 0d30 0x20 35 100}
test cmdIL-3.12 {SortCompare procedure, -real option} -body {
lsort -real {6...4 3}
} -returnCodes error -result {expected floating-point number but got "6...4"}
@@ -380,16 +399,16 @@ test cmdIL-4.23 {DictionaryCompare procedure, case} {
} {ABcd AbCd}
test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
::tcltest::set_iso8859_1_locale
- set result [lsort -dictionary "a b c A B C \xe3 \xc4"]
+ set result [lsort -dictionary "a b c A B C ã Ä"]
::tcltest::restore_locale
set result
-} "A a B b C c \xe3 \xc4"
+} "A a B b C c ã Ä"
test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} {
::tcltest::set_iso8859_1_locale
- set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"]
+ set result [lsort -dictionary "a23ã a23Å a23ä"]
::tcltest::restore_locale
set result
-} "a23\xe3 a23\xe4 a23\xc5"
+} "a23ã a23ä a23Å"
test cmdIL-4.26 {DefaultCompare procedure, signed characters} {
set l [lsort [list "abc\200" "abc"]]
set viewlist {}
@@ -456,10 +475,10 @@ test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} {
scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c
} {257 32 256}
test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} {
- scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c
+ scan [lsort -ascii -nocase [list a\x00a a]] %c%c%c%c%c
} {97 32 97 0 97}
test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} {
- scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c
+ scan [lsort -ascii -nocase [list a a\x00a]] %c%c%c%c%c
} {97 32 97 0 97}
test cmdIL-5.1 {lsort with list style index} {
@@ -776,6 +795,52 @@ test cmdIL-7.8 {lreverse command - shared internalrep [Bug 1675044]} -setup {
rename K {}
} -result 1
+test cmdIL-8.1 {lremove command: error path} -returnCodes error -body {
+ lremove
+} -result {wrong # args: should be "lremove list ?index ...?"}
+test cmdIL-8.2 {lremove command: error path} -returnCodes error -body {
+ lremove {{}{}}
+} -result {list element in braces followed by "{}" instead of space}
+test cmdIL-8.3 {lremove command: error path} -returnCodes error -body {
+ lremove {a b c} gorp
+} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}
+test cmdIL-8.4 {lremove command: no indices} -body {
+ lremove {a b c}
+} -result {a b c}
+test cmdIL-8.5 {lremove command: before start} -body {
+ lremove {a b c} -1
+} -result {a b c}
+test cmdIL-8.6 {lremove command: after end} -body {
+ lremove {a b c} 3
+} -result {a b c}
+test cmdIL-8.7 {lremove command} -body {
+ lremove {a b c} 0
+} -result {b c}
+test cmdIL-8.8 {lremove command} -body {
+ lremove {a b c} 1
+} -result {a c}
+test cmdIL-8.9 {lremove command} -body {
+ lremove {a b c} end
+} -result {a b}
+test cmdIL-8.10 {lremove command} -body {
+ lremove {a b c} end-1
+} -result {a c}
+test cmdIL-8.11 {lremove command} -body {
+ lremove {a b c d e} 1 3
+} -result {a c e}
+test cmdIL-8.12 {lremove command} -body {
+ lremove {a b c d e} 3 1
+} -result {a c e}
+test cmdIL-8.13 {lremove command: same index twice} -body {
+ lremove {a b c d e} 2 2
+} -result {a b d e}
+test cmdIL-8.14 {lremove command: same index twice} -body {
+ lremove {a b c d e} 3 end-1
+} -result {a b c e}
+test cmdIL-8.15 {lremove command: many indices} -body {
+ lremove {a b c d e} 1 3 1 4 0
+} -result {c}
+
# This belongs in info test, but adding tests there breaks tests
# that compute source file line numbers.
test info-20.6 {Bug 3587651} -setup {
@@ -784,8 +849,7 @@ test info-20.6 {Bug 3587651} -setup {
}}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup {
namespace delete my
} -result 1
-
-
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index e690002..37b8a0b 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -6,9 +6,9 @@
# and generates output for errors. No output means no errors were
# found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 66213f9..89947bb 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -4,16 +4,16 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
-if {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
- return
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::cmdMZ {
@@ -25,10 +25,6 @@ namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
- if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
- namespace import ::tcl::unsupported::timerate
- }
-
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
@@ -63,7 +59,7 @@ test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup {
# This test fails on various Unix platforms (eg Linux) where permissions
# caching causes this to fail. The caching is strictly incorrect, but we
# have no control over that.
- file attr . -permissions 0o000
+ file attr . -permissions 0
pwd
} -returnCodes error -cleanup {
cd $cwd
@@ -162,7 +158,7 @@ test cmdMZ-return-2.11 {return option handling} {
} {3 {-code 3 -level 0}}
test cmdMZ-return-2.12 {return option handling} -body {
return -level 0 -code error -options {-code ok}
-} -returnCodes ok -result {}
+} -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}
@@ -239,7 +235,7 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrWin
} -returnCodes error -body {
- source a b
+ source a b c d e f
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
@@ -303,19 +299,19 @@ test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} {
} {]\n}
test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} {
apply {{} {
- set x ab\000c
+ set x ab\x00c
set y [split $x {}]
binary scan $y c* z
return $z
}}
} {97 32 98 32 0 32 99}
test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} {
- split "a0ab1b2bbb3\000c4" ab\000c
+ split "a0ab1b2bbb3\x00c4" ab\x00c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
- # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
- split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
-} "a b qw\u5e4eN wq"
+ # if not UTF-8 aware, result is "a {} {} b qwå {} N wq"
+ split "a乎b qw幎N wq" " 乎"
+} "a b qw幎N wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
@@ -483,6 +479,23 @@ test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self insi
list [lindex [timerate $m1 1000 5] 2] $x
} {5 20}
+test cmdMZ-try-1.0 {
+
+ fix for issue 45b9faf103f2
+
+ [try] interaction with local variable names produces segmentation violation
+
+} -body {
+ ::apply {{} {
+ set cmd try
+ $cmd {
+ lindex 5
+ } on ok res {}
+ set res
+ }}
+} -result 5
+
+
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index 826fbc6..40dea76 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -6,8 +6,8 @@
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,14 +17,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
+::tcltest::loadTestedCommands
+catch [list package require -exact tcl::test [info patchlevel]]
# Big test for correct ordering of data in [expr]
@@ -34,9 +29,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -46,19 +41,19 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -68,11 +63,11 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -84,8 +79,8 @@ proc testIEEE {} {
}
testConstraint ieeeFloatingPoint [testIEEE]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# procedures used below
@@ -285,10 +280,10 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
} -returnCodes error -match glob -result *
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
-} {1 {can't use floating-point value as operand of "^"}}
+} {1 {can't use floating-point value "24.0" as operand of "^"}}
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "^"}}
+} {1 {can't use non-numeric string "a" as operand of "^"}}
test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
@@ -309,10 +304,10 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
} -returnCodes error -match glob -result *
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
-} {1 {can't use floating-point value as operand of "&"}}
+} {1 {can't use floating-point value "24.0" as operand of "&"}}
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "&"}}
+} {1 {can't use non-numeric string "a" as operand of "&"}}
test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
@@ -337,16 +332,9 @@ test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
-
-# The following test is different for 32-bit versus 64-bit
-# architectures because LONG_MIN is different
-
-test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
+test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} {
expr {int(1<<63)}
-} -9223372036854775808
-test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
- expr {int(1<<31)}
-} -2147483648
+} 9223372036854775808
test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body {
expr x>>3
@@ -377,10 +365,10 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
} -returnCodes error -match glob -result *
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
-} {1 {can't use floating-point value as operand of ">>"}}
+} {1 {can't use floating-point value "24.0" as operand of ">>"}}
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "<<"}}
+} {1 {can't use non-numeric string "a" as operand of "<<"}}
test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
@@ -399,10 +387,10 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body {
} -returnCodes error -match glob -result *
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "xx" as operand of "+"}}
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "a" as operand of "-"}}
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
@@ -430,10 +418,10 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body
} -returnCodes error -match glob -result *
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "*"}}
+} {1 {can't use non-numeric string "xx" as operand of "*"}}
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "a" as operand of "/"}}
test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
@@ -451,10 +439,10 @@ test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
} -returnCodes error -match glob -result *
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "~"}}
+} {1 {can't use non-numeric string "xx" as operand of "~"}}
test compExpr-old-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
-} {1 {can't use floating-point value as operand of "~"}}
+} {1 {can't use floating-point value "4.0" as operand of "~"}}
test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
@@ -602,21 +590,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body {
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 2*T1()
-} 246
-test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
-test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21, 37)
-} 37
-test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21.2, 37)
-} 37.0
-test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(-21.2, -17.5)
-} -17.5
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 7257726..eaef772 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -2,8 +2,8 @@
# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -14,13 +14,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
+catch [list package require -exact tcl::test [info patchlevel]]
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
expr {do_it()}
} -returnCodes error -match glob -result {* "*do_it"}
-test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 3*T1()-1
-} 368
-test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {not enough arguments for math function*}
@@ -383,10 +371,46 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu
unset end i tmp
rename getbytes {}
} -result 0
+
+proc extract {opcodes descriptor} {
+ set instructions [dict values [dict get $descriptor instructions]]
+ return [lmap i $instructions {
+ if {[lindex $i 0] in $opcodes} {string cat $i} else continue
+ }]
+}
+
+test compExpr-8.1 {TIP 582: expression comments} -setup {} -body {
+ extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
+ $abc
+ # + $def
+ + $ghi
+ }}]
+} -result {loadStk loadStk add}
+test compExpr-8.2 {TIP 582: expression comments} -setup {} -body {
+ extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
+ $abc
+ # + $def
+ # + $ghi }}]
+} -result loadStk
+test compExpr-8.3 {TIP 582: expression comments} -setup {} -body {
+ extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
+ $abc
+ # + $def\
+ + $ghi
+ }}]
+} -result loadStk
+test compExpr-8.4 {TIP 582: expression comments} -setup {} -body {
+ extract {loadStk add} [tcl::unsupported::getbytecode script {expr {
+ $abc
+ # + $def\\
+ + $ghi
+ }}]
+} -result {loadStk loadStk add}
# cleanup
catch {unset a}
catch {unset b}
+catch {rename extract ""}
::tcltest::cleanupTests
return
diff --git a/tests/compile.test b/tests/compile.test
index ac95c25..36b4f3a 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -5,8 +5,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,8 +16,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint exec [llength [info commands exec]]
testConstraint memory [llength [info commands memory]]
@@ -285,10 +286,10 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
} {4}
test compile-8.1 {CollectArgInfo: binary data} {
- list [catch "string length \000foo" msg] $msg
+ list [catch "string length \x00foo" msg] $msg
} {0 4}
test compile-8.2 {CollectArgInfo: binary data} {
- list [catch "string length foo\000" msg] $msg
+ list [catch "string length foo\x00" msg] $msg
} {0 4}
test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
set x ]
@@ -499,7 +500,7 @@ test compile-13.2 {TclCompileScript: testing expected nested scripts compilation
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
# boxes or systems, please don't decrease it (either provide a constraint)
ti eval {foreach cmd {eval "if 1" try catch} {
- set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd]
+ set c [gencode [expr {[tcl::build-info debug] ? 1500 : 1000}] $cmd]
if 1 $c
}}
ti eval {set result}
@@ -562,7 +563,8 @@ test compile-15.5 {proper TCL_RETURN code from [return]} {
apply {{} {catch {set a 1}; return}}
} ""
-for {set noComp 0} {$noComp <= 1} {incr noComp} {
+# Do all tests once byte compiled and once with direct string evaluation
+foreach noComp {0 1} {
if {$noComp} {
interp alias {} run {} testevalex
@@ -650,26 +652,26 @@ test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
} -constraints [linsert $constraints 0 knownBug] -cleanup {
rename LongList {}
-} -returnCodes ok -result [expr {1<<20}]
+} -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 {}
-} -returnCodes ok -result [expr {1<<22}]
+} -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 {}
-} -returnCodes ok -result [expr {1<<24}]
+} -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 {}
-} -returnCodes ok -result [expr {wide(1)<<32}]
+} -result [expr {wide(1)<<32}]
test compile-16.22.$noComp {
Bug 845412: TclCompileScript: word expansion not mandatory
} -body {
@@ -678,7 +680,7 @@ test compile-16.22.$noComp {
run "ReturnResults [string repeat {x } 260]"
} -constraints $constraints -cleanup {
rename ReturnResults {}
-} -returnCodes ok -result [string trim [string repeat {x } 260]]
+} -result [string trim [string repeat {x } 260]]
test compile-16.23.$noComp {
Bug 1032805: defer parse error until run time
} -constraints $constraints -body {
@@ -690,7 +692,7 @@ test compile-16.23.$noComp {
}
} -cleanup {
namespace delete x
-} -returnCodes ok -result {syntax {}{}}
+} -result {syntax {}{}}
test compile-16.24.$noComp {
Bug 1638414: bad list constant as first expanded term
} -constraints $constraints -body {
diff --git a/tests/concat.test b/tests/concat.test
index 8ff5500..976591e 100644
--- a/tests/concat.test
+++ b/tests/concat.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/config.test b/tests/config.test
index 15be790..50f03ce 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -5,9 +5,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,9 +17,9 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-test pkgconfig-1.1 {query keys} {
+test pkgconfig-1.1 {query keys} -body {
lsort [::tcl::pkgconfig list]
-} {64bit bindir,install bindir,runtime compile_debug compile_stats debug docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded}
+} -match glob -result {*bindir,install bindir,runtime*docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime*scriptdir,install scriptdir,runtime*}
test pkgconfig-1.2 {query keys multiple times} {
string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list]
} 0
diff --git a/tests/coroutine.test b/tests/coroutine.test
index c60b568..c3023f7 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -4,7 +4,7 @@
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
-# Copyright (c) 2008 by Miguel Sofer.
+# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint memory [llength [info commands memory]]
@@ -755,6 +755,77 @@ test coroutine-7.12 {coro floor above street level #3008307} -body {
rename boom {}; rename cc {}; rename c {}
} -result {}
+
+test coroutine-7.13 {
+ issue f9800d52bd61f240
+
+ vwait is not NRE-enabled, and yieldto cannot find the right splicing spot
+} -body {
+ coroutine c0 apply [list {} {
+ variable done
+ yield
+ yieldto c1
+ after 0 c2
+ vwait [namespace current]::done
+ } [namespace current]]
+
+ coroutine c1 apply [list {} {
+ yield
+ tailcall c0
+ } [namespace current]]
+
+ coroutine c2 apply [list {} {
+ variable done
+ yield
+ yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]]
+ yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]]
+ set done 1
+ } [namespace current]]
+
+ after 0 [list [namespace which c0]]
+ vwait [namespace current]::done
+ return $done
+} -result 1
+
+
+test coroutine-7.14 {
+ issue 5106fddd4400e5b9
+
+ failure to yieldto is not the same thing as not calling yieldto in the
+ first place
+} -body {
+ variable done
+ variable done1
+
+ coroutine c0 ::apply [list {} {
+ yield
+ after 0 [list [namespace which c1]]
+ vwait [namespace current]::done1
+ } [namespace current]]
+
+ coroutine c1 ::apply [list {} {
+ variable done1
+ yield
+ yieldto try "yieldto [list [info coroutine]]" on error {} "
+ ::set [list [namespace current]]::done1 failure
+ ::set [list [namespace current]]::done0 failure
+ "
+ set done1 success
+
+ } [namespace current]]
+ after 1 [list [namespace which c0]]
+ vwait [namespace current]::done0
+ if {[namespace which [namespace current]::c1] ne {}} {
+ # prior to the fix for 5106fddd4400e5b9, the nested yieldto turned into a
+ # tailcall which was eventutally activated, causing control to return to
+ # c1. After the fix, that doesn't happen, so if c1 still exists call it
+ # one final time to allow it to finish and clean up
+ rename c1 {}
+ }
+ return [list $done0 $done1]
+} -result {failure failure}
+
+
test coroutine-8.0.0 {coro inject executed} -body {
coroutine demo apply {{} { foreach i {1 2} yield }}
demo
@@ -793,7 +864,152 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
set result
} -result {inject-executed}
-test coroutine-9.1 {coro type} {
+test coroutine-9.1 {coroprobe with yield} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo]
+} -cleanup {
+ catch {rename demo {}}
+} -result {1 {} 2 {}}
+test coroutine-9.2 {coroprobe with yieldto} -body {
+ coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
+ list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d]
+} -cleanup {
+ catch {rename demo {}}
+} -result {1 {} 2 {{a b} {c d}}}
+test coroutine-9.3 {coroprobe errors} -setup {
+ catch {rename demo {}}
+} -body {
+ coroprobe demo set i
+} -returnCodes error -result {can only inject a probe command into a coroutine}
+test coroutine-9.4 {coroprobe errors} -body {
+ proc demo {} { foreach i {1 2} yield }
+ coroprobe demo set i
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {can only inject a probe command into a coroutine}
+test coroutine-9.5 {coroprobe errors} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroprobe
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
+test coroutine-9.6 {coroprobe errors} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroprobe demo
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"}
+test coroutine-9.7 {coroprobe errors in probe command} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroprobe demo set
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {wrong # args: should be "set varName ?newValue?"}
+test coroutine-9.8 {coroprobe errors in probe command} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ list [catch {coroprobe demo set}] [demo] [coroprobe demo set i]
+} -cleanup {
+ catch {rename demo {}}
+} -result {1 {} 2}
+test coroutine-9.9 {coroprobe: advanced features} -setup {
+ set i [interp create]
+} -body {
+ $i eval {
+ coroutine demo apply {{} {
+ set f [info level],[info frame]
+ foreach i {1 2} yield
+ }}
+ coroprobe demo apply {{} {
+ upvar 1 f f
+ list [info coroutine] [info level] [info frame] $f
+ }}
+ }
+} -cleanup {
+ interp delete $i
+} -result {::demo 2 3 1,2}
+
+test coroutine-10.1 {coroinject with yield} -setup {
+ set result {}
+} -body {
+ coroutine demo apply {{} { lmap i {1 2} yield }}
+ coroinject demo apply {{op val} {lappend ::result $op $val}}
+ list $result [demo x] [demo y] $result
+} -cleanup {
+ catch {rename demo {}}
+} -result {{} {} {{yield x} y} {yield x}}
+test coroutine-10.2 {coroinject stacking} -setup {
+ set result {}
+} -body {
+ coroutine demo apply {{} { lmap i {1 2} yield }}
+ coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}}
+ coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}}
+ list $result [demo x] [demo y] $result
+} -cleanup {
+ catch {rename demo {}}
+} -result {{} {} {x y} {yield x B yield x A}}
+test coroutine-10.3 {coroinject with yieldto} -setup {
+ set result {}
+} -body {
+ coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }}
+ coroinject demo apply {{op val} {lappend ::result $op $val;return $val}}
+ list $result [demo x mp] [demo y le] $result
+} -cleanup {
+ catch {rename demo {}}
+} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}}
+test coroutine-10.4 {coroinject errors} -setup {
+ catch {rename demo {}}
+} -body {
+ coroinject demo set i
+} -returnCodes error -result {can only inject a command into a coroutine}
+test coroutine-10.5 {coroinject errors} -body {
+ proc demo {} { foreach i {1 2} yield }
+ coroinject demo set i
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {can only inject a command into a coroutine}
+test coroutine-10.6 {coroinject errors} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroinject
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
+test coroutine-10.7 {coroinject errors} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroinject demo
+} -returnCodes error -cleanup {
+ catch {rename demo {}}
+} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"}
+test coroutine-10.8 {coroinject errors in injected command} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ coroinject demo apply {args {error "ERR: $args"}}
+ list [catch demo msg] $msg [catch demo msg] $msg
+} -cleanup {
+ catch {rename demo {}}
+} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}}
+test coroutine-10.9 {coroinject: advanced features} -setup {
+ set i [interp create]
+} -body {
+ $i eval {
+ coroutine demo apply {{} {
+ set l [info level]
+ set f [info frame]
+ lmap i {1 2} yield
+ }}
+ coroinject demo apply {{arg op val} {
+ global result
+ upvar 1 f f l l
+ lappend result [info coroutine] $arg $op $val
+ lappend result [info level] $l [info frame] $f
+ lappend result [yield $arg]
+ return [string toupper $val]
+ }} grill
+ list [demo ABC] [demo pqr] [demo def] $result
+ }
+} -cleanup {
+ interp delete $i
+} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}}
+
+test coroutine-11.1 {coro type} {
coroutine demo eval {
yield
yield "PHASE 1"
@@ -803,19 +1019,19 @@ test coroutine-9.1 {coro type} {
list [demo] [::tcl::unsupported::corotype demo] \
[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
-test coroutine-9.2 {coro type} -setup {
+test coroutine-11.2 {coro type} -setup {
catch {rename nosuchcommand ""}
} -returnCodes error -body {
::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
-test coroutine-9.3 {coro type} -returnCodes error -body {
+test coroutine-11.3 {coro type} -returnCodes error -body {
proc notacoroutine {} {}
::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}
-test coroutine-10.1 {coroutine general introspection} -setup {
+test coroutine-12.1 {coroutine general introspection} -setup {
set i [interp create]
} -body {
$i eval {
diff --git a/tests/dcall.test b/tests/dcall.test
index 7d86135..e407e48 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -4,9 +4,9 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testdcall [llength [info commands testdcall]]
diff --git a/tests/dict.test b/tests/dict.test
index fe9ec33..1515675 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -5,7 +5,7 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 2003-2009 Donal K. Fellows
+# Copyright © 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} {
} {a e c d}
test dict-4.13 {dict replace command: type check is mandatory} -body {
dict replace { a b c d e }
-} -returnCodes error -result {missing value to go with key}
-test dict-4.13a {dict replace command: type check is mandatory} {
- catch {dict replace { a b c d e }} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY}
+} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key}
test dict-4.14 {dict replace command: type check is mandatory} -body {
dict replace { a b {}c d }
} -returnCodes error -result {dict element in braces followed by "c" instead of space}
@@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} {
} {TCL VALUE DICTIONARY QUOTE}
test dict-4.17 {dict replace command: type check is mandatory} -body {
dict replace " a b \{c d "
-} -returnCodes error -result {unmatched open brace in dict}
-test dict-4.17a {dict replace command: type check is mandatory} {
- catch {dict replace " a b \{c d "} -> opt
- dict get $opt -errorcode
-} {TCL VALUE DICTIONARY BRACE}
+} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict}
test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
set example { a b c d }
list $example [dict replace $example]
@@ -2055,6 +2047,111 @@ test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]}
dict update item item item two two {}
}}
} {}
+
+set dict dict; # Used to force interpretation, not compilation
+test dict-26.1 {dict getdef command} -body {
+ dict getdef {a b} a c
+} -result b
+test dict-26.2 {dict getdef command} -body {
+ dict getdef {a b} b c
+} -result c
+test dict-26.3 {dict getdef command} -body {
+ dict getdef {a {b c}} a b d
+} -result c
+test dict-26.4 {dict getdef command} -body {
+ dict getdef {a {b c}} a c d
+} -result d
+test dict-26.5 {dict getdef command} -body {
+ dict getdef {a {b c}} b c d
+} -result d
+test dict-26.6 {dict getdef command} -returnCodes error -body {
+ dict getdef {a {b c d}} a b d
+} -result {missing value to go with key}
+test dict-26.7 {dict getdef command} -returnCodes error -body {
+ dict getdef
+} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
+test dict-26.8 {dict getdef command} -returnCodes error -body {
+ dict getdef {}
+} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
+test dict-26.9 {dict getdef command} -returnCodes error -body {
+ dict getdef {} {}
+} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"}
+test dict-26.10 {dict getdef command} -returnCodes error -body {
+ dict getdef {a b c} d e
+} -result {missing value to go with key}
+test dict-26.11 {dict getdef command} -body {
+ $dict getdef {a b} a c
+} -result b
+test dict-26.12 {dict getdef command} -body {
+ $dict getdef {a b} b c
+} -result c
+test dict-26.13 {dict getdef command} -body {
+ $dict getdef {a {b c}} a b d
+} -result c
+test dict-26.14 {dict getdef command} -body {
+ $dict getdef {a {b c}} a c d
+} -result d
+test dict-26.15 {dict getdef command} -body {
+ $dict getdef {a {b c}} b c d
+} -result d
+test dict-26.16 {dict getdef command} -returnCodes error -body {
+ $dict getdef {a {b c d}} a b d
+} -result {missing value to go with key}
+test dict-26.17 {dict getdef command} -returnCodes error -body {
+ $dict getdef {a b c} d e
+} -result {missing value to go with key}
+
+test dict-27.1 {dict getwithdefault command} -body {
+ dict getwithdefault {a b} a c
+} -result b
+test dict-27.2 {dict getwithdefault command} -body {
+ dict getwithdefault {a b} b c
+} -result c
+test dict-27.3 {dict getwithdefault command} -body {
+ dict getwithdefault {a {b c}} a b d
+} -result c
+test dict-27.4 {dict getwithdefault command} -body {
+ dict getwithdefault {a {b c}} a c d
+} -result d
+test dict-27.5 {dict getwithdefault command} -body {
+ dict getwithdefault {a {b c}} b c d
+} -result d
+test dict-27.6 {dict getwithdefault command} -returnCodes error -body {
+ dict getwithdefault {a {b c d}} a b d
+} -result {missing value to go with key}
+test dict-27.7 {dict getwithdefault command} -returnCodes error -body {
+ dict getwithdefault
+} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
+test dict-27.8 {dict getwithdefault command} -returnCodes error -body {
+ dict getwithdefault {}
+} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
+test dict-27.9 {dict getwithdefault command} -returnCodes error -body {
+ dict getwithdefault {} {}
+} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"}
+test dict-27.10 {dict getdef command} -returnCodes error -body {
+ dict getwithdefault {a b c} d e
+} -result {missing value to go with key}
+test dict-27.11 {dict getwithdefault command} -body {
+ $dict getwithdefault {a b} a c
+} -result b
+test dict-27.12 {dict getwithdefault command} -body {
+ $dict getwithdefault {a b} b c
+} -result c
+test dict-27.13 {dict getwithdefault command} -body {
+ $dict getwithdefault {a {b c}} a b d
+} -result c
+test dict-27.14 {dict getwithdefault command} -body {
+ $dict getwithdefault {a {b c}} a c d
+} -result d
+test dict-27.15 {dict getwithdefault command} -body {
+ $dict getwithdefault {a {b c}} b c d
+} -result d
+test dict-27.16 {dict getwithdefault command} -returnCodes error -body {
+ $dict getwithdefault {a {b c d}} a b d
+} -result {missing value to go with key}
+test dict-27.17 {dict getdef command} -returnCodes error -body {
+ $dict getwithdefault {a b c} d e
+} -result {missing value to go with key}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/dstring.test b/tests/dstring.test
index cb1cc4f..7c9d9f6 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -4,9 +4,9 @@
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testdstring [llength [info commands testdstring]]
if {[testConstraint testdstring]} {
@@ -425,10 +425,13 @@ test dstring-4.3 {truncation} -constraints testdstring -setup {
# Pass a negative length to Tcl_DStringSetLength();
# if not caught, causing '\0' to be written out-of-bounds,
# try corrupting dsPtr->length which begins
- # 2*sizeof(int) bytes before dsPtr->staticSpace[],
+ # 2*sizeof(Tcl_Size) bytes before dsPtr->staticSpace[],
# so that the result is -256 (on little endian systems)
- # rather than e.g. -8.
- testdstring trunc -8
+ # rather than e.g. -8 or -16.
+ # (sizeof(Tcl_Size) does not seem to be available via Tcl,
+ # so assume sizeof(Tcl_Size) == sizeof(void*) for Tcl 9.)
+ testdstring trunc [expr {-2*([package vsatisfies $tcl_version 9.0-]
+ ? $tcl_platform(pointerSize) : 4)}]
list [testdstring get] [testdstring length]
} -cleanup {
testdstring free
@@ -520,6 +523,45 @@ test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body {
} -cleanup {
testdstring free
} -result {{} {This is a specially-allocated stringz}}
+
+test dstring-7.1 {copying to Tcl_Obj} -constraints testdstring -setup {
+ testdstring free
+} -body {
+ testdstring append xyz -1
+ list [testdstring toobj] [testdstring length]
+} -cleanup {
+ testdstring free
+} -result {xyz 0}
+test dstring-7.2 {copying to a Tcl_Obj} -constraints testdstring -setup {
+ testdstring free
+ unset -nocomplain a
+} -body {
+ foreach l {a b c d e f g h i j k l m n o p} {
+ testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
+ }
+ set a [testdstring toobj]
+ testdstring append abc -1
+ list $a [testdstring get]
+} -cleanup {
+ testdstring free
+} -result {{aaaaaaaaaaaaaaaaaaaaa
+bbbbbbbbbbbbbbbbbbbbb
+ccccccccccccccccccccc
+ddddddddddddddddddddd
+eeeeeeeeeeeeeeeeeeeee
+fffffffffffffffffffff
+ggggggggggggggggggggg
+hhhhhhhhhhhhhhhhhhhhh
+iiiiiiiiiiiiiiiiiiiii
+jjjjjjjjjjjjjjjjjjjjj
+kkkkkkkkkkkkkkkkkkkkk
+lllllllllllllllllllll
+mmmmmmmmmmmmmmmmmmmmm
+nnnnnnnnnnnnnnnnnnnnn
+ooooooooooooooooooooo
+ppppppppppppppppppppp
+} abc}
+
# cleanup
if {[testConstraint testdstring]} {
diff --git a/tests/encoding.test b/tests/encoding.test
index dc50f24..76b5306 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -2,8 +2,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -13,14 +13,17 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+
namespace eval ::tcl::test::encoding {
variable x
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
+ package require -exact tcl::test [info patchlevel]
}
+source [file join [file dirname [info script]] tcltests.tcl]
+
proc toutf {args} {
variable x
lappend x "toutf $args"
@@ -37,10 +40,8 @@ proc runtests {} {
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
-testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
-testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint exec [llength [info commands exec]]
-testConstraint testgetdefenc [llength [info commands testgetdefenc]]
+testConstraint testgetencpath [llength [info commands testgetencpath]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
@@ -65,12 +66,12 @@ test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
return $x
} {{fromutf }}
test encoding-1.3 {Tcl_GetEncoding: load encoding} {
- list [encoding convertto jis0208 \u4E4E] \
+ list [encoding convertto jis0208 乎] \
[encoding convertfrom jis0208 8C]
-} "8C \u4E4E"
+} "8C 乎"
test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
- encoding convertto jis0208 \u4E4E
+ encoding convertto jis0208 乎
} {8C}
test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
set system [encoding system]
@@ -78,10 +79,10 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
} -constraints {testencoding} -body {
encoding system shiftjis ;# incr ref count
encoding dirs [list [pwd]]
- set x [encoding convertto shiftjis \u4E4E] ;# old one found
+ set x [encoding convertto shiftjis 乎] ;# old one found
encoding system iso8859-1
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
- lappend x [catch {encoding convertto shiftjis \u4E4E} msg] $msg
+ lappend x [catch {encoding convertto shiftjis 乎} msg] $msg
} -cleanup {
encoding system iso8859-1
encoding dirs $path
@@ -104,6 +105,14 @@ test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup {
} -cleanup {
fconfigure stdout -encoding $old
} -result {jis0208}
+test encoding-3.3 {fconfigure -profile} -setup {
+ set old [fconfigure stdout -profile]
+} -body {
+ fconfigure stdout -profile replace
+ fconfigure stdout -profile
+} -cleanup {
+ fconfigure stdout -profile $old
+} -result replace
test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup {
cd [makeDirectory tmp]
@@ -138,7 +147,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
set old [encoding system]
} -body {
encoding system jis0208
- encoding convertto \u4E4E
+ encoding convertto 乎
} -cleanup {
encoding system iso8859-1
encoding system $old
@@ -170,7 +179,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
encoding convertfrom jis0208 8c8c8c8c
-} "\u543E\u543E\u543E\u543E"
+} 吾吾吾吾
test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C
append a $a
@@ -179,7 +188,7 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
-} "512 \u4E4E"
+} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
@@ -192,13 +201,13 @@ test encoding-8.1 {Tcl_ExternalToUtf} {
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
-} "ab\u4E4Eg"
+} ab乎g
test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
- encoding convertto jis0208 "\u543E\u543E\u543E\u543E"
+ encoding convertto jis0208 "吾吾吾吾"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
- set a \u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E
+ set a 乎乎乎乎乎乎乎乎
append a $a
append a $a
append a $a
@@ -212,7 +221,7 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding shiftjis
- puts -nonewline $f "ab\u4E4Eg"
+ puts -nonewline $f ab乎g
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding iso8859-1
@@ -222,44 +231,32 @@ test encoding-10.1 {Tcl_UtfToExternal} {
return $x
} "ab\x8C\xC1g"
-proc viewable {str} {
- set res ""
- foreach c [split $str {}] {
- if {[string is print $c] && [string is ascii $c]} {
- append res $c
- } else {
- append res "\\u[format %4.4X [scan $c %c]]"
- }
- }
- return "$str ($res)"
-}
-
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
encoding dirs {}
llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal
- set x [list [catch {encoding convertto jis0208 \u4E4E} msg] $msg]
+ set x [list [catch {encoding convertto jis0208 乎} msg] $msg]
encoding dirs $path
encoding system $system
- lappend x [encoding convertto jis0208 \u4E4E]
+ lappend x [encoding convertto jis0208 乎]
} {1 {unknown encoding "jis0208"} 8C}
test encoding-11.2 {LoadEncodingFile: single-byte} {
encoding convertfrom jis0201 \xA1
-} \uFF61
+} 。
test encoding-11.3 {LoadEncodingFile: double-byte} {
encoding convertfrom jis0208 8C
-} \u4E4E
+} 乎
test encoding-11.4 {LoadEncodingFile: multi-byte} {
encoding convertfrom shiftjis \x8C\xC1
-} \u4E4E
+} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
- viewable [encoding convertto iso2022 \u4E4E]
-} [viewable "\x1B\$B8C\x1B(B"]
+ encoding convertto iso2022 乎
+} \x1B\$B8C\x1B(B
test encoding-11.5.1 {LoadEncodingFile: escape file} {
- viewable [encoding convertto iso2022-jp \u4E4E]
-} [viewable "\x1B\$B8C\x1B(B"]
+ encoding convertto iso2022-jp 乎
+} \x1B\$B8C\x1B(B
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
set path [encoding dirs]
@@ -273,7 +270,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding}
fconfigure $f -translation binary
puts $f "abcdefghijklmnop"
close $f
- encoding convertto splat \u4E4E
+ encoding convertto splat 乎
} -returnCodes error -cleanup {
file delete [file join [temporaryDirectory] tmp encoding splat.enc]
removeDirectory [file join tmp encoding]
@@ -282,45 +279,49 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding}
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
-
+test encoding-11.8 {encoding: extended Unicode UTF-16} {
+ encoding convertto utf-16le 😹
+} =Ø9Þ
+test encoding-11.9 {encoding: extended Unicode UTF-16} {
+ encoding convertto utf-16be 😹
+} Ø=Þ9
+test encoding-11.10 {encoding: extended Unicode UTF-32} {
+ encoding convertto utf-32le 😹
+} 9\xF6\x01\x00
+test encoding-11.11 {encoding: extended Unicode UTF-32} {
+ encoding convertto utf-32be 😹
+} \x00\x01\xF69
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
- set x [encoding convertto iso8859-3 \u0120]
- append x [encoding convertto iso8859-3 \xD5]
- append x [encoding convertfrom iso8859-3 \xD5]
-} \xD5?\u0120
+ set x [encoding convertto iso8859-3 Ġ]
+ append x [encoding convertto -profile tcl8 iso8859-3 Õ]
+ append x [encoding convertfrom iso8859-3 Õ]
+} "Õ?Ġ"
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
- set x [encoding convertto iso8859-3 ab\u0120g]
- append x [encoding convertfrom iso8859-3 ab\xD5g]
-} ab\xD5gab\u0120g
+ set x [encoding convertto iso8859-3 abĠg]
+ append x [encoding convertfrom iso8859-3 abÕg]
+} "abÕgabĠg"
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
- set x [encoding convertto shiftjis ab\u4E4Eg]
+ set x [encoding convertto shiftjis ab乎g]
append x [encoding convertfrom shiftjis ab\x8C\xC1g]
-} ab\x8C\xC1gab\u4E4Eg
+} "ab\x8C\xC1gab乎g"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
- set x [encoding convertto jis0208 \u4E4E\u03B1]
+ set x [encoding convertto jis0208 乎α]
append x [encoding convertfrom jis0208 8C&A]
-} 8C&A\u4E4E\u03B1
+} "8C&A乎α"
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
- set x [encoding convertto symbol \u03B3]
+ set x [encoding convertto symbol γ]
append x [encoding convertto symbol g]
append x [encoding convertfrom symbol g]
-} gg\u03B3
-test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 {
- encoding convertto iso8859-3 \U010000
-} ?
+} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
- viewable [set x [encoding convertto iso2022 ab\u4E4E\u68D9g]]
-} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"]
-
-test encoding-14.1 {BinaryProc} {
- encoding convertto identity \x12\x34\x56\xff\x69
-} "\x12\x34\x56\xc3\xbf\x69"
+ encoding convertto iso2022 ab乎棙g
+} ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg
test encoding-15.1 {UtfToUtfProc} {
- encoding convertto utf-8 \xA3
+ encoding convertto utf-8 £
} "\xC2\xA3"
test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z
@@ -333,115 +334,329 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
} c080
test encoding-15.4 {UtfToUtfProc emoji character input} -body {
set x \xED\xA0\xBD\xED\xB8\x82
- set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82]
+ set y [encoding convertfrom -profile tcl8 utf-8 \xED\xA0\xBD\xED\xB8\x82]
list [string length $x] $y
-} -result "6 \uD83D\uDE02"
+} -result "6 😂"
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 \uD83D\uDE02"
+} "4 😂"
test encoding-15.6 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\uDE02\uD83D
- set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D]
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uDE02\uD83D]
binary scan $y H* z
list [string length $y] $z
} {10 edb882f09f9882eda0bd}
test encoding-15.7 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\uD83D
- set y [encoding convertto utf-8 \uDE02\uD83D\uD83D]
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uD83D]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 9 edb882eda0bdeda0bd}
test encoding-15.8 {UtfToUtfProc emoji character output} {
- set x \uDE02\uD83D\xE9
- set y [encoding convertto utf-8 \uDE02\uD83D\xE9]
+ set x \uDE02\uD83Dé
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83Dé]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 8 edb882eda0bdc3a9}
test encoding-15.9 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83DX
- set y [encoding convertto utf-8 \uDE02\uD83DX]
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83DX]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 7 edb882eda0bd58}
test encoding-15.10 {UtfToUtfProc high surrogate character output} {
- set x \uDE02\xE9
- set y [encoding convertto utf-8 \uDE02\xE9]
+ set x \uDE02é
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 edb882c3a9}
test encoding-15.11 {UtfToUtfProc low surrogate character output} {
- set x \uDA02\xE9
- set y [encoding convertto utf-8 \uDA02\xE9]
+ set x \uDA02é
+ set y [encoding convertto -profile tcl8 utf-8 \uDA02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 eda882c3a9}
test encoding-15.12 {UtfToUtfProc high surrogate character output} {
set x \uDE02Y
- set y [encoding convertto utf-8 \uDE02Y]
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 edb88259}
test encoding-15.13 {UtfToUtfProc low surrogate character output} {
set x \uDA02Y
- set y [encoding convertto utf-8 \uDA02Y]
+ set y [encoding convertto -profile tcl8 utf-8 \uDA02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 eda88259}
test encoding-15.14 {UtfToUtfProc high surrogate character output} {
set x \uDE02
- set y [encoding convertto utf-8 \uDE02]
+ set y [encoding convertto -profile tcl8 utf-8 \uDE02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
- set y [encoding convertto utf-8 \uDA02]
+ set y [encoding convertto -profile tcl8 utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
- set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2]
+ set y [encoding convertfrom -profile tcl8 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 😂
+ set y [encoding convertto utf-8 😂]
+ binary scan $y H* z
+ list [string length $y] $z
+} {4 f09f9882}
+test encoding-15.18 {UtfToUtfProc CESU-8 6-byte sequence} {
+ set y [encoding convertto cesu-8 \U10000]
+ binary scan $y H* z
+ list [string length $y] $z
+} {6 eda080edb080}
+test encoding-15.19 {UtfToUtfProc CESU-8 upper surrogate} {
+ set y [encoding convertto cesu-8 \uD800]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 eda080}
+test encoding-15.20 {UtfToUtfProc CESU-8 lower surrogate} {
+ set y [encoding convertto cesu-8 \uDC00]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 edb080}
+test encoding-15.21 {UtfToUtfProc CESU-8 noncharacter} {
+ set y [encoding convertto cesu-8 \uFFFF]
+ binary scan $y H* z
+ list [string length $y] $z
+} {3 efbfbf}
+test encoding-15.22 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
+ set y [encoding convertto cesu-8 \x80]
+ binary scan $y H* z
+ list [string length $y] $z
+} {2 c280}
+test encoding-15.23 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
+ set y [encoding convertto cesu-8 \u100]
+ binary scan $y H* z
+ list [string length $y] $z
+} {2 c480}
+test encoding-15.24 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
+ set y [encoding convertto cesu-8 \u3FF]
+ binary scan $y H* z
+ list [string length $y] $z
+} {2 cfbf}
+test encoding-15.25 {UtfToUtfProc CESU-8} {
+ encoding convertfrom cesu-8 \x00
+} \x00
+test encoding-15.26 {UtfToUtfProc CESU-8} {
+ encoding convertfrom -profile tcl8 cesu-8 \xC0\x80
+} \x00
+test encoding-15.27 {UtfToUtfProc -profile strict CESU-8} {
+ encoding convertfrom -profile strict cesu-8 \x00
+} \x00
+test encoding-15.28 {UtfToUtfProc -profile strict CESU-8} -body {
+ encoding convertfrom -profile strict cesu-8 \xC0\x80
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
+test encoding-15.29 {UtfToUtfProc CESU-8} {
+ encoding convertto cesu-8 \x00
+} \x00
+test encoding-15.30 {UtfToUtfProc -profile strict CESU-8} {
+ encoding convertto -profile strict cesu-8 \x00
+} \x00
+test encoding-15.31 {UtfToUtfProc -profile strict CESU-8 (bytes F0-F4 are invalid)} -body {
+ encoding convertfrom -profile strict cesu-8 \xF1\x86\x83\x9C
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'}
-test encoding-16.1 {UnicodeToUtfProc} -body {
- set val [encoding convertfrom unicode NN]
- list $val [format %X [scan $val %c]]
-} -result "\u4E4E 4E4E"
-test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
- set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"]
+test encoding-16.1 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom utf-16 NN]
+ list $val [format %x [scan $val %c]]
+} -result "乎 4e4e"
+test encoding-16.2 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
-test encoding-16.3 {UnicodeToUtfProc} -body {
- set val [encoding convertfrom unicode "\xDC\xDC"]
- list $val [format %X [scan $val %c]]
-} -result "\uDCDC DCDC"
-test encoding-16.4 {UnicodeToUtfProc, bug [d19fe0a5b]} -body {
- encoding convertfrom unicode "\x41\x41\x41"
+test encoding-16.3 {Utf16ToUtfProc} -body {
+ set val [encoding convertfrom -profile tcl8 utf-16 "\xDC\xDC"]
+ list $val [format %x [scan $val %c]]
+} -result "\uDCDC dcdc"
+test encoding-16.4 {Ucs2ToUtfProc} -body {
+ set val [encoding convertfrom ucs-2 NN]
+ list $val [format %x [scan $val %c]]
+} -result "乎 4e4e"
+test encoding-16.5 {Ucs2ToUtfProc} -body {
+ set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"]
+ list $val [format %x [scan $val %c]]
+} -result "\U460DC 460dc"
+test encoding-16.6 {Utf32ToUtfProc} -body {
+ set val [encoding convertfrom utf-32le NN\0\0]
+ list $val [format %x [scan $val %c]]
+} -result "乎 4e4e"
+test encoding-16.7 {Utf32ToUtfProc} -body {
+ set val [encoding convertfrom utf-32be \0\0NN]
+ list $val [format %x [scan $val %c]]
+} -result "乎 4e4e"
+test encoding-16.8 {Utf32ToUtfProc} -body {
+ set val [encoding convertfrom -profile tcl8 utf-32 \x41\x00\x00\x41]
+ list $val [format %x [scan $val %c]]
+} -result "\uFFFD fffd"
+test encoding-16.9 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32le \x00\xD8\x00\x00
+} -result \uD800
+test encoding-16.10 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32le \x00\xDC\x00\x00
+} -result \uDC00
+test encoding-16.11 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00
+} -result \uD800\uDC00
+test encoding-16.12 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00
+} -result \uDC00\uD800
+test encoding-16.13 {Utf16ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-16le \x00\xD8
+} -result \uD800
+test encoding-16.14 {Utf16ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-16le \x00\xDC
+} -result \uDC00
+test encoding-16.15 {Utf16ToUtfProc} -body {
+ encoding convertfrom utf-16le \x00\xD8\x00\xDC
+} -result \uD800\uDC00
+test encoding-16.16 {Utf16ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-16le \x00\xDC\x00\xD8
+} -result \uDC00\uD800
+test encoding-16.17 {Utf32ToUtfProc} -body {
+ list [encoding convertfrom -profile strict -failindex idx utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00] [set idx]
+} -result {A 4}
+
+test encoding-16.18 {
+ Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16
+} -body {
+ apply [list {} {
+ for {set i 0xD800} {$i < 0xDBFF} {incr i} {
+ for {set j 0xDC00} {$j < 0xDFFF} {incr j} {
+ set string [binary format S2 [list $i $j]]
+ set status [catch {
+ set decoded [encoding convertfrom utf-16be $string]
+ set encoded [encoding convertto utf-16be $decoded]
+ }]
+ if {$status || ( $encoded ne $string )} {
+ return [list [format %x $i] [format %x $j]]
+ }
+ }
+ }
+ return done
+ } [namespace current]]
+} -result done
+test encoding-16.19.strict {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
+test encoding-16.19.tcl8 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile tcl8 utf-16 "\x41\x41\x41"
} -result \u4141\uFFFD
-test encoding-16.5 {UnicodeToUtfProc, bug [d19fe0a5b]} -constraints ucs2 -body {
- encoding convertfrom unicode "\xD8\xD8"
+test encoding-16.20.tcl8 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile tcl8 utf-16 "\xD8\xD8"
} -result \uD8D8
+test encoding-16.20.strict {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile strict utf-16 "\xD8\xD8"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xD8'}
+test encoding-16.21.tcl8 {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile tcl8 utf-32 "\x00\x00\x00\x00\x41\x41"
+} -result \x00\uFFFD
+test encoding-16.21.strict {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
+ encoding convertfrom -profile strict utf-32 "\x00\x00\x00\x00\x41\x41"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 4: '\x41'}
+test encoding-16.22 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
+ encoding convertfrom -profile strict utf-16le \x00\xD8
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
+test encoding-16.23 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
+ encoding convertfrom -profile strict utf-16le \x00\xDC
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
+test encoding-16.24 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF"
+} -result \uFFFD
+test encoding-16.25.strict {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile strict utf-32 "\x01\x00\x00\x01"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x01'}
+test encoding-16.25.tcl8 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32 "\x01\x00\x00\x01"
+} -result \uFFFD
-test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body {
- encoding convertto unicode "\U460DC"
+test encoding-17.1 {UtfToUtf16Proc} -body {
+ encoding convertto utf-16 "\U460DC"
} -result "\xD8\xD8\xDC\xDC"
-test encoding-17.2 {UtfToUnicodeProc} -body {
- encoding convertto unicode "\uDCDC"
+test encoding-17.2 {UtfToUcs2Proc, invalid testcase, see [5607d6482c]} -constraints deprecated -body {
+ encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"]
+} -result "\uFFFD"
+test encoding-17.3 {UtfToUtf16Proc} -body {
+ encoding convertto -profile tcl8 utf-16be "\uDCDC"
} -result "\xDC\xDC"
-test encoding-17.3 {UtfToUnicodeProc} -body {
- encoding convertto unicode "\uD8D8"
+test encoding-17.4 {UtfToUtf16Proc} -body {
+ encoding convertto -profile tcl8 utf-16le "\uD8D8"
} -result "\xD8\xD8"
+test encoding-17.5 {UtfToUtf32Proc} -body {
+ encoding convertto utf-32le "\U460DC"
+} -result "\xDC\x60\x04\x00"
+test encoding-17.6 {UtfToUtf32Proc} -body {
+ encoding convertto utf-32be "\U460DC"
+} -result "\x00\x04\x60\xDC"
+test encoding-17.7 {UtfToUtf16Proc} -body {
+ encoding convertto -profile strict utf-16be "\uDCDC"
+} -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'}
+test encoding-17.8 {UtfToUtf16Proc} -body {
+ encoding convertto -profile strict utf-16le "\uD8D8"
+} -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'}
+test encoding-17.9 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile strict utf-32 "\xFF\xFF\xFF\xFF"
+} -returnCodes error -result {unexpected byte sequence starting at index 0: '\xFF'}
+test encoding-17.10 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF"
+} -result \uFFFD
+test encoding-17.11 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile strict utf-32le "\x00\xD8\x00\x00"
+} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
+test encoding-17.12 {Utf32ToUtfProc} -body {
+ encoding convertfrom -profile strict utf-32le "\x00\xDC\x00\x00"
+} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-18.1 {TableToUtfProc on invalid input} -body {
- list [catch {encoding convertto jis0208 \\} res] $res
+ list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res
+} -result {0 !)}
+test encoding-18.2 {TableToUtfProc on invalid input with -profile strict} -body {
+ list [catch {encoding convertto -profile strict jis0208 \\} res] $res
+} -result {1 {unexpected character at index 0: 'U+00005C'}}
+test encoding-18.3 {TableToUtfProc on invalid input with -profile strict -failindex} -body {
+ list [catch {encoding convertto -profile strict -failindex pos jis0208 \\} res] $res $pos
+} -result {0 {} 0}
+test encoding-18.4 {TableToUtfProc on invalid input with -failindex -profile strict} -body {
+ list [catch {encoding convertto -failindex pos -profile strict jis0208 \\} res] $res $pos
+} -result {0 {} 0}
+test encoding-18.5 {TableToUtfProc on invalid input with -failindex} -body {
+ list [catch {encoding convertto -profile tcl8 -failindex pos jis0208 \\} res] $res $pos
+} -result {0 !) -1}
+test encoding-18.6 {TableToUtfProc on invalid input with -profile tcl8} -body {
+ list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res
} -result {0 !)}
-test encoding-19.1 {TableFromUtfProc} {
-} {}
+test encoding-19.1 {TableFromUtfProc} -body {
+ encoding convertfrom -profile tcl8 ascii AÁ
+} -result AÁ
+test encoding-19.2 {TableFromUtfProc} -body {
+ encoding convertfrom -profile tcl8 ascii AÁ
+} -result AÁ
+test encoding-19.3 {TableFromUtfProc} -body {
+ encoding convertfrom -profile strict ascii AÁ
+} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xC1'}
+test encoding-19.4 {TableFromUtfProc} -body {
+ list [encoding convertfrom -profile tcl8 -failindex idx ascii AÁ] [set idx]
+} -result [list A\xC1 -1]
+test encoding-19.5 {TableFromUtfProc} -body {
+ list [encoding convertfrom -failindex idx -profile strict ascii A\xC1] [set idx]
+} -result {A 1}
+test encoding-19.6 {TableFromUtfProc} -body {
+ list [encoding convertfrom -failindex idx -profile strict ascii AÁB] [set idx]
+} -result {A 1}
test encoding-20.1 {TableFreefProc} {
} {}
@@ -459,11 +674,11 @@ casino_japanese@___.com \x1B\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\
\x1B\$B\$7\$g\$&\$+!)\x1B(B"
set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData]
-set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
-\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
-\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
-\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
-\u3057\u3087\u3046\u304b\uff1f"
+set iso2022uniData2 "私どもでは、チップご購入時にご登録いただいたご住所をキャッシュアウトの際の
+小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお
+お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部(
+casino_japanese@___.com )までご住所変更済の連絡をいただけないで
+しょうか?"
cd [temporaryDirectory]
set fid [open iso2022.txt w]
@@ -525,20 +740,20 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec {
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
- viewable [runInSubprocess {
+ runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
- puts ab\u4E4E\u68D9g
+ puts ab乎棙g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
- }]
-} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001B\$B8C\\u001B\$(DD%\\u001B(Bg)"
+ }
+} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
- set a \u4E4E\u4E5E\u4E5F; # 3 Japanese Kanji letters
+ set a "乎乞也"; # 3 Japanese Kanji letters
puts $a
} iso2022.tcl]
set f [open "|[list [interpreter] $file]"]
@@ -546,33 +761,153 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
set count [gets $f line]
close $f
removeFile iso2022.tcl
- list $count [viewable $line]
-} [list 3 "\u4E4E\u4E5E\u4E5F (\\u4E4E\\u4E5E\\u4E5F)"]
+ list $count $line
+} [list 3 乎乞也]
-test encoding-24.4 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xC0\x80"]
-} 1
+test encoding-24.4.strict {Parse invalid utf-8, strict} -body {
+ encoding convertfrom -profile strict utf-8 "\xC0\x80"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
+test encoding-24.4.tcl8 {UtfToUtfProc utf-8} {
+ encoding convertfrom -profile tcl8 utf-8 \xC0\x80
+} \x00
test encoding-24.5 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xC0\x81"]
+ string length [encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"]
} 2
test encoding-24.6 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xC1\xBF"]
+ string length [encoding convertfrom -profile tcl8 utf-8 "\xC1\xBF"]
} 2
test encoding-24.7 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xC2\x80"]
} 1
test encoding-24.8 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xE0\x80\x80"]
+ string length [encoding convertfrom -profile tcl8 utf-8 "\xE0\x80\x80"]
} 3
test encoding-24.9 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"]
+ string length [encoding convertfrom -profile tcl8 utf-8 "\xE0\x9F\xBF"]
} 3
test encoding-24.10 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xE0\xA0\x80"]
} 1
test encoding-24.11 {Parse valid or invalid utf-8} {
- string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"]
+ string length [encoding convertfrom -profile tcl8 utf-8 "\xEF\xBF\xBF"]
} 1
+test encoding-24.12 {Parse invalid utf-8} -body {
+ encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"
+} -result \xC0\x81
+test encoding-24.12.1 {Parse invalid utf-8} -body {
+ encoding convertfrom -profile strict utf-8 "\xC0\x81"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
+test encoding-24.13 {Parse invalid utf-8} -body {
+ encoding convertfrom -profile tcl8 utf-8 "\xC1\xBF"
+} -result \xC1\xBF
+test encoding-24.13.1 {Parse invalid utf-8} -body {
+ encoding convertfrom -profile strict utf-8 "\xC1\xBF"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'}
+test encoding-24.14 {Parse valid utf-8} {
+ encoding convertfrom utf-8 "\xC2\x80"
+} \x80
+test encoding-24.15.strict {Parse invalid utf-8, -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "Z\xE0\x80"
+} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'"
+test encoding-24.15.tcl8 {Parse invalid utf-8, -profile tcl8} -body {
+ encoding convertfrom -profile tcl8 utf-8 "Z\xE0\x80"
+} -result Z\xE0\u20AC
+test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body {
+ encoding convertto utf-8 [testbytestring "Z\u4343\x80"]
+} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)}
+test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body {
+ encoding convertto utf-8 [testbytestring "Z\xE0\x80"]
+} -result "Z\xC3\xA0\xE2\x82\xAC"
+test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body {
+ encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"]
+} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx"
+test encoding-24.19.1 {Parse valid or invalid utf-8} -body {
+ encoding convertto -profile tcl8 utf-8 "ZX\uD800"
+} -result ZX\xED\xA0\x80
+test encoding-24.19.2 {Parse valid or invalid utf-8} -body {
+ encoding convertto -profile strict utf-8 "ZX\uD800"
+} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'"
+test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -body {
+ encoding convertfrom -profile tcl8 "\x20"
+} -result {wrong # args: should be "::tcl::encoding::convertfrom ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertfrom data"} -returnCodes error
+test encoding-24.21 {Parse with -profile tcl8 but without providing encoding} -body {
+ string length [encoding convertto -profile tcl8 "\x20"]
+} -result {wrong # args: should be "::tcl::encoding::convertto ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertto data"} -returnCodes error
+test encoding-24.22 {Syntax error, two encodings} -body {
+ encoding convertfrom iso8859-1 utf-8 "ZX\uD800"
+} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error
+test encoding-24.23 {Syntax error, two encodings} -body {
+ encoding convertto iso8859-1 utf-8 "ZX\uD800"
+} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error
+test encoding-24.24 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "\xC0\x80\x00\x00"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
+test encoding-24.25 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "\x40\x80\x00\x00"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'}
+test encoding-24.26 {Parse valid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "\xF1\x80\x80\x80"
+} -result \U40000
+test encoding-24.27 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "\xF0\x80\x80\x80"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'}
+test encoding-24.28 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 "\xFF\x00\x00"
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'}
+test encoding-24.29 {Parse invalid utf-8} -body {
+ encoding convertfrom utf-8 \xEF\xBF\xBF
+} -result \uFFFF
+test encoding-24.30 {Parse noncharacter with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 \xEF\xBF\xBF
+} -result \uFFFF
+test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body {
+ encoding convertfrom -profile tcl8 utf-8 \xEF\xBF\xBF
+} -result \uFFFF
+test encoding-24.32 {Try to generate invalid utf-8} -body {
+ encoding convertto utf-8 \uFFFF
+} -result \xEF\xBF\xBF
+test encoding-24.33 {Try to generate invalid utf-8} -body {
+ encoding convertto -profile strict utf-8 \uFFFF
+} -result \xEF\xBF\xBF
+test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body {
+ encoding convertto -profile tcl8 utf-8 \uFFFF
+} -result \xEF\xBF\xBF
+test encoding-24.35 {Parse invalid utf-8} -body {
+ encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80
+} -result \uD800
+test encoding-24.36 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 \xED\xA0\x80
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'}
+test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body {
+ encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80
+} -result \uD800
+test encoding-24.38.1 {Try to generate invalid utf-8} -body {
+ encoding convertto -profile tcl8 utf-8 \uD800
+} -result \xED\xA0\x80
+test encoding-24.38.2 {Try to generate invalid utf-8} -body {
+ encoding convertto -profile strict utf-8 \uD800
+} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
+test encoding-24.39 {Try to generate invalid utf-8 with -profile strict} -body {
+ encoding convertto -profile strict utf-8 \uD800
+} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
+test encoding-24.40 {Try to generate invalid utf-8 with -profile tcl8} -body {
+ encoding convertto -profile tcl8 utf-8 \uD800
+} -result \xED\xA0\x80
+test encoding-24.41 {Parse invalid utf-8 with -profile strict} -body {
+ encoding convertfrom -profile strict utf-8 \xED\xA0\x80\xED\xB0\x80
+} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'}
+test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body {
+ encoding convertfrom -profile tcl8 utf-8 \xF0\x80\x80\x80
+} -result \xF0\u20AC\u20AC\u20AC
+test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body {
+ encoding convertfrom -profile tcl8 utf-8 \x80
+} -result \u20AC
+test encoding-24.44 {Try to generate invalid ucs-2 with -profile strict} -body {
+ encoding convertto -profile strict ucs-2 \uD800
+} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
+test encoding-24.45 {Try to generate invalid ucs-2 with -profile strict} -body {
+ encoding convertto -profile strict ucs-2 \U10000
+} -returnCodes 1 -result {unexpected character at index 0: 'U+010000'}
file delete [file join [temporaryDirectory] iso2022.txt]
@@ -696,15 +1031,15 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} {
}
}
-test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
- testgetdefenc
+test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints {
+ testgetencpath
} -setup {
- set origDir [testgetdefenc]
- testsetdefenc slappy
+ set origPath [testgetencpath]
+ testsetencpath slappy
} -body {
- testgetdefenc
+ testgetencpath
} -cleanup {
- testsetdefenc $origDir
+ testsetencpath $origPath
} -result slappy
file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
@@ -727,55 +1062,99 @@ test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
test encoding-28.0 {all encodings load} -body {
set string hello
foreach name [encoding names] {
- incr count
- encoding convertto $name $string
+ if {$name ne "unicode"} {
+ incr count
+ }
+ encoding convertto -profile tcl8 $name $string
# discard the cached internal representation of Tcl_Encoding
# Unfortunately, without this, encoding 2-1 fails.
llength $name
}
return $count
-} -result 83
+} -result 91
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 1} result] $result
-} -result [list 0 [list nospace {} \xff]]
+ # Note - buffers are initialized to \xFF
+ list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1} result] $result
+} -result [list 0 [list nospace {} \xFF]]
test encoding-bug-183a1adcc0-2 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 0} result] $result
+ # Note - buffers are initialized to \xFF
+ list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 0} result] $result
} -result [list 0 [list nospace {} {}]]
test encoding-bug-183a1adcc0-3 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 2} result] $result
+ # Note - buffers are initialized to \xFF
+ list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 2} result] $result
} -result [list 0 [list nospace {} \x00\x00]]
test encoding-bug-183a1adcc0-4 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 3} result] $result
-} -result [list 0 [list nospace {} \x00\x00\xff]]
+ # Note - buffers are initialized to \xFF
+ list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 3} result] $result
+} -result [list 0 [list nospace {} \x00\x00\xFF]]
test encoding-bug-183a1adcc0-5 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
- testencoding ucs2
+ testencoding
} -body {
- # Note - buffers are initialized to \xff
- list [catch {testencoding Tcl_UtfToExternal unicode A {start end} {} 4} result] $result
+ list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 4} result] $result
} -result [list 0 [list ok {} [expr {$::tcl_platform(byteOrder) eq "littleEndian" ? "\x41\x00" : "\x00\x41"}]\x00\x00]]
}
+test encoding-29.0 {get encoding nul terminator lengths} -constraints {
+ testencoding
+} -body {
+ list \
+ [testencoding nullength ascii] \
+ [testencoding nullength utf-16] \
+ [testencoding nullength utf-32] \
+ [testencoding nullength gb12345] \
+ [testencoding nullength ksc5601]
+} -result {1 2 4 2 2}
+
+test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
+ encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby
+} -result x\uFFFDy
+test encoding-bug-6a3e2cb0f0-2 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
+ encoding convertfrom -profile strict iso2022-jp x\x1B\x7Aaby
+} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x1B'}
+test encoding-bug-6a3e2cb0f0-3 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
+ encoding convertfrom -profile replace iso2022-jp x\x1B\x7Aaby
+} -result x\uFFFDy
+
+test encoding-bug-66ffafd309-1-tcl8 {Bug [66ffafd309] - truncated DBCS} -body {
+ encoding convertfrom -profile tcl8 gb12345 x
+} -result x
+test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body {
+ encoding convertfrom -profile strict gb12345 x
+} -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error
+test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body {
+ encoding convertfrom -profile replace gb12345 x
+} -result \uFFFD
+test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body {
+ # Not truncated but invalid
+ encoding convertfrom -profile tcl8 jis0208 \x78\x79
+} -result \x78\x79
+test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body {
+ # Not truncated but invalid
+ encoding convertfrom -profile strict jis0208 \x78\x79
+} -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error
+test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body {
+ # Not truncated but invalid
+ encoding convertfrom -profile replace jis0208 \x78\x79
+} -result \uFFFD\uFFFD
+
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl
new file mode 100644
index 0000000..3961917
--- /dev/null
+++ b/tests/encodingVectors.tcl
@@ -0,0 +1,655 @@
+# This file contains test vectors for verifying various encodings. They are
+# stored in a common file so that they can be sourced into the various test
+# modules that are dependent on encodings. This file contains statically defined
+# test vectors. In addition, it sources the ICU-generated test vectors from
+# icuUcmTests.tcl.
+#
+# Note that sourcing the file will reinitialize any existing encoding test
+# vectors.
+#
+
+# List of defined encoding profiles
+set encProfiles {tcl8 strict replace}
+set encDefaultProfile tcl8; # Should reflect the default from implementation
+
+# encValidStrings - Table of valid strings.
+#
+# Each row is <ENCODING STR BYTES CTRL COMMENT>
+# The pair <ENCODING,STR> should be unique for generated test ids to be unique.
+# STR is a string that can be encoded in the encoding ENCODING resulting
+# in the byte sequence BYTES. The CTRL field is a list that controls test
+# generation. It may contain zero or more of `solo`, `lead`, `tail` and
+# `middle` indicating that the generated tests should include the string
+# by itself, as the lead of a longer string, as the tail of a longer string
+# and in the middle of a longer string. If CTRL is empty, it is treated as
+# containing all four of the above. The CTRL field may also contain the
+# words knownBug or knownW3C which will cause the test generation for that
+# vector to be skipped.
+#
+# utf-16, utf-32 missing because they are automatically
+# generated based on le/be versions.
+set encValidStrings {}; # Reset the table
+
+lappend encValidStrings {*}{
+ ascii \u0000 00 {} {Lowest ASCII}
+ ascii \u007F 7F {} {Highest ASCII}
+ ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly}
+ ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly}
+
+ utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1}
+ utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1}
+ utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2}
+ utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2}
+ utf-8 \u0800 E0A080 {} {Unicode Table 3.7 Row 3}
+ utf-8 \u0FFF E0BFBF {} {Unicode Table 3.7 Row 3}
+ utf-8 \u1000 E18080 {} {Unicode Table 3.7 Row 4}
+ utf-8 \uCFFF ECBFBF {} {Unicode Table 3.7 Row 4}
+ utf-8 \uD000 ED8080 {} {Unicode Table 3.7 Row 5}
+ utf-8 \uD7FF ED9FBF {} {Unicode Table 3.7 Row 5}
+ utf-8 \uE000 EE8080 {} {Unicode Table 3.7 Row 6}
+ utf-8 \uFFFF EFBFBF {} {Unicode Table 3.7 Row 6}
+ utf-8 \U10000 F0908080 {} {Unicode Table 3.7 Row 7}
+ utf-8 \U3FFFF F0BFBFBF {} {Unicode Table 3.7 Row 7}
+ utf-8 \U40000 F1808080 {} {Unicode Table 3.7 Row 8}
+ utf-8 \UFFFFF F3BFBFBF {} {Unicode Table 3.7 Row 8}
+ utf-8 \U100000 F4808080 {} {Unicode Table 3.7 Row 9}
+ utf-8 \U10FFFF F48FBFBF {} {Unicode Table 3.7 Row 9}
+ utf-8 A\u03A9\u8A9E\U00010384 41CEA9E8AA9EF0908E84 {} {Unicode 2.5}
+
+ utf-16le \u0000 0000 {} {Lowest code unit}
+ utf-16le \uD7FF FFD7 {} {Below high surrogate range}
+ utf-16le \uE000 00E0 {} {Above low surrogate range}
+ utf-16le \uFFFF FFFF {} {Highest code unit}
+ utf-16le \U010000 00D800DC {} {First surrogate pair}
+ utf-16le \U10FFFF FFDBFFDF {} {First surrogate pair}
+ utf-16le A\u03A9\u8A9E\U00010384 4100A9039E8A00D884DF {} {Unicode 2.5}
+
+ utf-16be \u0000 0000 {} {Lowest code unit}
+ utf-16be \uD7FF D7FF {} {Below high surrogate range}
+ utf-16be \uE000 E000 {} {Above low surrogate range}
+ utf-16be \uFFFF FFFF {} {Highest code unit}
+ utf-16be \U010000 D800DC00 {} {First surrogate pair}
+ utf-16be \U10FFFF DBFFDFFF {} {First surrogate pair}
+ utf-16be A\u03A9\u8A9E\U00010384 004103A98A9ED800DF84 {} {Unicode 2.5}
+
+ utf-32le \u0000 00000000 {} {Lowest code unit}
+ utf-32le \uFFFF FFFF0000 {} {Highest BMP}
+ utf-32le \U010000 00000100 {} {First supplementary}
+ utf-32le \U10FFFF ffff1000 {} {Last supplementary}
+ utf-32le A\u03A9\u8A9E\U00010384 41000000A90300009E8A000084030100 {} {Unicode 2.5}
+
+ utf-32be \u0000 00000000 {} {Lowest code unit}
+ utf-32be \uFFFF 0000FFFF {} {Highest BMP}
+ utf-32be \U010000 00010000 {} {First supplementary}
+ utf-32be \U10FFFF 0010FFFF {} {Last supplementary}
+ utf-32be A\u03A9\u8A9E\U00010384 00000041000003A900008A9E00010384 {} {Unicode 2.5}
+}
+
+# encInvalidBytes - Table of invalid byte sequences
+# These are byte sequences that should appear for an encoding. Each row is
+# of the form
+# <ENCODING BYTES PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT>
+# The triple <ENCODING,BYTES,PROFILE> should be unique for test ids to be
+# unique. BYTES is a byte sequence that is invalid. EXPECTEDRESULT is the
+# expected string when the bytes are decoded using the PROFILE profile.
+# FAILINDEX gives the expected index of the invalid byte under that profile. The
+# CTRL field is a list that controls test generation. It may contain zero or
+# more of `solo`, `lead`, `tail` and `middle` indicating that the generated the
+# tail of a longer and in the middle of a longer string. If empty, it is treated
+# as containing all four of the above. The CTRL field may also contain the words
+# knownBug or knownW3C which will cause the test generation for that vector to
+# be skipped.
+#
+# utf-32 missing because they are automatically generated based on le/be
+# versions.
+set encInvalidBytes {}; # Reset the table
+
+# ascii - Any byte above 127 is invalid and is mapped
+# to the same numeric code point except for the range
+# 80-9F which is treated as cp1252.
+# This tests the TableToUtfProc code path.
+lappend encInvalidBytes {*}{
+ ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252}
+ ascii 80 replace \uFFFD -1 {} {Smallest invalid byte}
+ ascii 80 strict {} 0 {} {Smallest invalid byte}
+ ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252}
+ ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252}
+ ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252}
+ ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252}
+ ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252}
+ ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252}
+ ascii 87 tcl8 \u2021 -1 {knownBug} {map to cp1252}
+ ascii 88 tcl8 \u0276 -1 {knownBug} {map to cp1252}
+ ascii 89 tcl8 \u2030 -1 {knownBug} {map to cp1252}
+ ascii 8A tcl8 \u0160 -1 {knownBug} {map to cp1252}
+ ascii 8B tcl8 \u2039 -1 {knownBug} {map to cp1252}
+ ascii 8C tcl8 \u0152 -1 {knownBug} {map to cp1252}
+ ascii 8D tcl8 \u008D -1 {knownBug} {map to cp1252}
+ ascii 8E tcl8 \u017D -1 {knownBug} {map to cp1252}
+ ascii 8F tcl8 \u008F -1 {knownBug} {map to cp1252}
+ ascii 90 tcl8 \u0090 -1 {knownBug} {map to cp1252}
+ ascii 91 tcl8 \u2018 -1 {knownBug} {map to cp1252}
+ ascii 92 tcl8 \u2019 -1 {knownBug} {map to cp1252}
+ ascii 93 tcl8 \u201C -1 {knownBug} {map to cp1252}
+ ascii 94 tcl8 \u201D -1 {knownBug} {map to cp1252}
+ ascii 95 tcl8 \u2022 -1 {knownBug} {map to cp1252}
+ ascii 96 tcl8 \u2013 -1 {knownBug} {map to cp1252}
+ ascii 97 tcl8 \u2014 -1 {knownBug} {map to cp1252}
+ ascii 98 tcl8 \u02DC -1 {knownBug} {map to cp1252}
+ ascii 99 tcl8 \u2122 -1 {knownBug} {map to cp1252}
+ ascii 9A tcl8 \u0161 -1 {knownBug} {map to cp1252}
+ ascii 9B tcl8 \u203A -1 {knownBug} {map to cp1252}
+ ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252}
+ ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252}
+ ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252}
+ ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252}
+
+ ascii FF tcl8 \u00FF -1 {} {Largest invalid byte}
+ ascii FF replace \uFFFD -1 {} {Largest invalid byte}
+ ascii FF strict {} 0 {} {Largest invalid byte}
+}
+
+# utf-8 - valid sequences based on Table 3.7 in the Unicode
+# standard.
+#
+# Code Points First Second Third Fourth Byte
+# U+0000..U+007F 00..7F
+# U+0080..U+07FF C2..DF 80..BF
+# U+0800..U+0FFF E0 A0..BF 80..BF
+# U+1000..U+CFFF E1..EC 80..BF 80..BF
+# U+D000..U+D7FF ED 80..9F 80..BF
+# U+E000..U+FFFF EE..EF 80..BF 80..BF
+# U+10000..U+3FFFF F0 90..BF 80..BF 80..BF
+# U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF
+# U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
+#
+# Tests below are based on the "gaps" in the above table. Note ascii test
+# values are repeated because internally a different code path is used
+# (UtfToUtfProc).
+# Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080
+lappend encInvalidBytes {*}{
+ utf-8 80 tcl8 \u20AC -1 {} {map to cp1252}
+ utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte}
+ utf-8 80 strict {} 0 {} {Smallest invalid byte}
+ utf-8 81 tcl8 \u0081 -1 {} {map to cp1252}
+ utf-8 82 tcl8 \u201A -1 {} {map to cp1252}
+ utf-8 83 tcl8 \u0192 -1 {} {map to cp1252}
+ utf-8 84 tcl8 \u201E -1 {} {map to cp1252}
+ utf-8 85 tcl8 \u2026 -1 {} {map to cp1252}
+ utf-8 86 tcl8 \u2020 -1 {} {map to cp1252}
+ utf-8 87 tcl8 \u2021 -1 {} {map to cp1252}
+ utf-8 88 tcl8 \u02C6 -1 {} {map to cp1252}
+ utf-8 89 tcl8 \u2030 -1 {} {map to cp1252}
+ utf-8 8A tcl8 \u0160 -1 {} {map to cp1252}
+ utf-8 8B tcl8 \u2039 -1 {} {map to cp1252}
+ utf-8 8C tcl8 \u0152 -1 {} {map to cp1252}
+ utf-8 8D tcl8 \u008D -1 {} {map to cp1252}
+ utf-8 8E tcl8 \u017D -1 {} {map to cp1252}
+ utf-8 8F tcl8 \u008F -1 {} {map to cp1252}
+ utf-8 90 tcl8 \u0090 -1 {} {map to cp1252}
+ utf-8 91 tcl8 \u2018 -1 {} {map to cp1252}
+ utf-8 92 tcl8 \u2019 -1 {} {map to cp1252}
+ utf-8 93 tcl8 \u201C -1 {} {map to cp1252}
+ utf-8 94 tcl8 \u201D -1 {} {map to cp1252}
+ utf-8 95 tcl8 \u2022 -1 {} {map to cp1252}
+ utf-8 96 tcl8 \u2013 -1 {} {map to cp1252}
+ utf-8 97 tcl8 \u2014 -1 {} {map to cp1252}
+ utf-8 98 tcl8 \u02DC -1 {} {map to cp1252}
+ utf-8 99 tcl8 \u2122 -1 {} {map to cp1252}
+ utf-8 9A tcl8 \u0161 -1 {} {map to cp1252}
+ utf-8 9B tcl8 \u203A -1 {} {map to cp1252}
+ utf-8 9C tcl8 \u0153 -1 {} {map to cp1252}
+ utf-8 9D tcl8 \u009D -1 {} {map to cp1252}
+ utf-8 9E tcl8 \u017E -1 {} {map to cp1252}
+ utf-8 9F tcl8 \u0178 -1 {} {map to cp1252}
+
+ utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere}
+ utf-8 C0 strict {} 0 {} {C0 is invalid anywhere}
+ utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere}
+ utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8}
+ utf-8 C080 strict {} 0 {} {C080 -> invalid}
+ utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char}
+ utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A}
+ utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A}
+ utf-8 C0A2 strict {} 0 {} {websec.github.io - A}
+ utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote}
+ utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote}
+ utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote}
+ utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop}
+ utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop}
+ utf-8 C0AE strict {} 0 {} {websec.github.io - full stop}
+ utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus}
+ utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus}
+ utf-8 C0AF strict {} 0 {} {websec.github.io - solidus}
+
+ utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere}
+ utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere}
+ utf-8 C1 strict {} 0 {} {C1 is invalid everywhere}
+ utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)}
+ utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)}
+ utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)}
+ utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus}
+ utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus}
+ utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus}
+
+ utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte}
+ utf-8 C2 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 C2 strict {} 0 {} {Missing trail byte}
+ utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF}
+ utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte}
+ utf-8 DF replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 DF strict {} 0 {} {Missing trail byte}
+ utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF}
+ utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence}
+ utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence}
+ utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence}
+
+ utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte}
+ utf-8 E0 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 E0 strict {} 0 {} {Missing trail byte}
+ utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF}
+ utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF}
+ utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF}
+ utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus}
+ utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus}
+ utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus}
+ utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF}
+ utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF}
+ utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF}
+ utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte}
+ utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 E0A0 strict {} 0 {} {Missing second trail byte}
+ utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte}
+ utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 E0BF strict {} 0 {} {Missing second trail byte}
+ utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 E0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF}
+
+ utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte}
+ utf-8 E1 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 E1 strict {} 0 {} {Missing trail byte}
+ utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF}
+ utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte}
+ utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 E181 strict {} 0 {} {Missing second trail byte}
+ utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte}
+ utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 E1BF strict {} 0 {} {Missing second trail byte}
+ utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 E1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte}
+ utf-8 EC replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 EC strict {} 0 {} {Missing trail byte}
+ utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF}
+ utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF}
+ utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte}
+ utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EC81 strict {} 0 {} {Missing second trail byte}
+ utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte}
+ utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 ECBF strict {} 0 {} {Missing second trail byte}
+ utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF}
+
+ utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte}
+ utf-8 ED replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 ED strict {} 0 {} {Missing trail byte}
+ utf-8 ED7F tcl8 \u00ED\u7F -1 {} {First trail byte must be 80:9F}
+ utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F}
+ utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F}
+ utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F}
+ utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F}
+ utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F}
+ utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte}
+ utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 ED81 strict {} 0 {} {Missing second trail byte}
+ utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte}
+ utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EDBF strict {} 0 {} {Missing second trail byte}
+ utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate}
+ utf-8 EDA080 replace \uFFFD -1 {} {High surrogate}
+ utf-8 EDA080 strict {} 0 {} {High surrogate}
+ utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate}
+ utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate}
+ utf-8 EDAFBF strict {} 0 {} {High surrogate}
+ utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate}
+ utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate}
+ utf-8 EDB080 strict {} 0 {} {Low surrogate}
+ utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate}
+ utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate}
+ utf-8 EDBFBF strict {} 0 {} {Low surrogate}
+ utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair}
+ utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair}
+ utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair}
+ utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair}
+ utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair}
+ utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair}
+
+ utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte}
+ utf-8 EE replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 EE strict {} 0 {} {Missing trail byte}
+ utf-8 EE7F tcl8 \u00EE\u7F -1 {} {First trail byte must be 80:BF}
+ utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF}
+ utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF}
+ utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF}
+ utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte}
+ utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EE81 strict {} 0 {} {Missing second trail byte}
+ utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte}
+ utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EEBF strict {} 0 {} {Missing second trail byte}
+ utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 EEBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte}
+ utf-8 EF replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 EF strict {} 0 {} {Missing trail byte}
+ utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF}
+ utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF}
+ utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF}
+ utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF}
+ utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte}
+ utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EF81 strict {} 0 {} {Missing second trail byte}
+ utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte}
+ utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 EFBF strict {} 0 {} {Missing second trail byte}
+ utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 EFBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF}
+
+ utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte}
+ utf-8 F0 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 F0 strict {} 0 {} {Missing trail byte}
+ utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF}
+ utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF}
+ utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF}
+ utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF}
+ utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF}
+ utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF}
+ utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF}
+ utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF}
+ utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF}
+ utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte}
+ utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F090 strict {} 0 {} {Missing second trail byte}
+ utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte}
+ utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F0BF strict {} 0 {} {Missing second trail byte}
+ utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte}
+ utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F090BF strict {} 0 {} {Missing third trail byte}
+ utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte}
+ utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F0BF81 strict {} 0 {} {Missing third trail byte}
+ utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF}
+ utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF}
+ utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF}
+ utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF}
+
+ utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte}
+ utf-8 F1 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 F1 strict {} 0 {} {Missing trail byte}
+ utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF}
+ utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF}
+ utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF}
+ utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF}
+ utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte}
+ utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F180 strict {} 0 {} {Missing second trail byte}
+ utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte}
+ utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F1BF strict {} 0 {} {Missing second trail byte}
+ utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte}
+ utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F180BF strict {} 0 {} {Missing third trail byte}
+ utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte}
+ utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F1BF81 strict {} 0 {} {Missing third trail byte}
+ utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF}
+ utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF}
+ utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF}
+ utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF}
+ utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte}
+ utf-8 F3 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 F3 strict {} 0 {} {Missing trail byte}
+ utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF}
+ utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF}
+ utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF}
+ utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF}
+ utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF}
+ utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte}
+ utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F380 strict {} 0 {} {Missing second trail byte}
+ utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte}
+ utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F3BF strict {} 0 {} {Missing second trail byte}
+ utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte}
+ utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F380BF strict {} 0 {} {Missing third trail byte}
+ utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte}
+ utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F3BF81 strict {} 0 {} {Missing third trail byte}
+ utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF}
+ utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF}
+ utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF}
+ utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF}
+
+ utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte}
+ utf-8 F4 replace \uFFFD -1 {} {Missing trail byte}
+ utf-8 F4 strict {} 0 {} {Missing trail byte}
+ utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F}
+ utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F}
+ utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F}
+ utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F}
+ utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F}
+ utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F}
+ utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte}
+ utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F480 strict {} 0 {} {Missing second trail byte}
+ utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte}
+ utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte}
+ utf-8 F48F strict {} 0 {} {Missing second trail byte}
+ utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF}
+ utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF}
+ utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF}
+ utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte}
+ utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F48081 strict {} 0 {} {Missing third trail byte}
+ utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte}
+ utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte}
+ utf-8 F48F81 strict {} 0 {} {Missing third trail byte}
+ utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF}
+ utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF}
+ utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF}
+ utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF}
+ utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF}
+
+ utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere}
+ utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere}
+ utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere}
+ utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere}
+ utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere}
+ utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere}
+
+ utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8}
+ utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9}
+ utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10}
+ utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11}
+}
+
+# utf16-le and utf16-be test cases. Note utf16 cases are automatically generated
+# based on these depending on platform endianness. Note truncated tests can only
+# happen when the sequence is at the end (including by itself) Thus {solo tail}
+# in some cases.
+lappend encInvalidBytes {*}{
+ utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated}
+ utf-16le 41 strict {} 0 {solo tail} {Truncated}
+ utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate}
+ utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate}
+ utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate}
+ utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate}
+ utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate}
+ utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate}
+
+ utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated}
+ utf-16be 41 strict {} 0 {solo tail} {Truncated}
+ utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate}
+ utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate}
+ utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate}
+ utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate}
+ utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate}
+ utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate}
+}
+
+# utf32-le and utf32-be test cases. Note utf32 cases are automatically generated
+# based on these depending on platform endianness. Note truncated tests can only
+# happen when the sequence is at the end (including by itself) Thus {solo tail}
+# in some cases.
+lappend encInvalidBytes {*}{
+ utf-32le 41 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32le 41 replace \uFFFD -1 {solo} {Truncated}
+ utf-32le 41 strict {} 0 {solo tail} {Truncated}
+ utf-32le 4100 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32le 4100 replace \uFFFD -1 {solo} {Truncated}
+ utf-32le 4100 strict {} 0 {solo tail} {Truncated}
+ utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32le 410000 replace \uFFFD -1 {solo} {Truncated}
+ utf-32le 410000 strict {} 0 {solo tail} {Truncated}
+ utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate}
+ utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate}
+ utf-32le 00D80000 strict {} 0 {} {High-surrogate}
+ utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate}
+ utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate}
+ utf-32le 00DC0000 strict {} 0 {} {Low-surrogate}
+ utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair}
+ utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair}
+ utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair}
+ utf-32le 00001100 tcl8 \uFFFD -1 {} {Out of range}
+ utf-32le 00001100 replace \uFFFD -1 {} {Out of range}
+ utf-32le 00001100 strict {} 0 {} {Out of range}
+ utf-32le FFFFFFFF tcl8 \uFFFD -1 {} {Out of range}
+ utf-32le FFFFFFFF replace \uFFFD -1 {} {Out of range}
+ utf-32le FFFFFFFF strict {} 0 {} {Out of range}
+
+ utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated}
+ utf-32be 41 strict {} 0 {solo tail} {Truncated}
+ utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32be 0041 replace \uFFFD -1 {solo} {Truncated}
+ utf-32be 0041 strict {} 0 {solo tail} {Truncated}
+ utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated}
+ utf-32be 000041 replace \uFFFD -1 {solo} {Truncated}
+ utf-32be 000041 strict {} 0 {solo tail} {Truncated}
+ utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate}
+ utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate}
+ utf-32be 0000D800 strict {} 0 {} {High-surrogate}
+ utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate}
+ utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate}
+ utf-32be 0000DC00 strict {} 0 {} {Low-surrogate}
+ utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair}
+ utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair}
+ utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair}
+ utf-32be 00110000 tcl8 \uFFFD -1 {} {Out of range}
+ utf-32be 00110000 replace \uFFFD -1 {} {Out of range}
+ utf-32be 00110000 strict {} 0 {} {Out of range}
+ utf-32be FFFFFFFF tcl8 \uFFFD -1 {} {Out of range}
+ utf-32be FFFFFFFF replace \uFFFD -1 {} {Out of range}
+ utf-32be FFFFFFFF strict {} 0 {} {Out of range}
+}
+
+# Strings that cannot be encoded for specific encoding / profiles
+# <ENCODING STRING PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT>
+# <ENCODING,STRING,PROFILE> should be unique for test ids to be unique.
+# See earlier comments about CTRL field.
+#
+# Note utf-16, utf-32 missing because they are automatically
+# generated based on le/be versions.
+# TODO - out of range code point (note cannot be generated by \U notation)
+lappend encUnencodableStrings {*}{
+ ascii \u00e0 tcl8 3f -1 {} {unencodable}
+ ascii \u00e0 strict {} 0 {} {unencodable}
+
+ iso8859-1 \u0141 tcl8 3f -1 {} unencodable
+ iso8859-1 \u0141 strict {} 0 {} unencodable
+
+ utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate
+ utf-8 \uD800 strict {} 0 {} High-surrogate
+ utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate
+ utf-8 \uDC00 strict {} 0 {} High-surrogate
+}
+
+
+# The icuUcmTests.tcl is generated by the tools/ucm2tests.tcl script
+# and generates test vectors for the above tables for various encodings
+# based on ICU UCM files.
+# TODO - commented out for now as generating a lot of mismatches.
+# source [file join [file dirname [info script]] icuUcmTests.tcl]
diff --git a/tests/env.test b/tests/env.test
index fb0674d..5317897 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/error.test b/tests/error.test
index 7f7b534..5bed039 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/eval.test b/tests/eval.test
index 959dc87..9b8eccd 100644
--- a/tests/eval.test
+++ b/tests/eval.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/event.test b/tests/event.test
index 50d1088..d62d08e 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -3,21 +3,19 @@
# this file into Tcl runs the tests and generates output for errors. No
# output means no errors were found.
#
-# Copyright (c) 1995-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1997 Sun Microsystems, Inc.
+# Copyright © 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.
-if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.5
- namespace import -force ::tcltest::*
-}
+package require tcltest 2.5
+namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
- set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+ package require -exact tcl::test [info patchlevel]
+ set ::tcltestlib [info loaded {} Tcltest]
}
@@ -511,12 +509,9 @@ test event-10.1 {Tcl_Exit procedure} {stdio} {
[lindex $::errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}
-test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+test event-11.1 {Tcl_VwaitCmd procedure} -body {
vwait
-} -result {wrong # args: should be "vwait name"}
-test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
- vwait a b
-} -result {wrong # args: should be "vwait name"}
+} -result {}
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
catch {unset x}
} -body {
diff --git a/tests/exec.test b/tests/exec.test
index e77a0ac..4058ae9 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -163,19 +163,19 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
- regsub -all "\[\u007f-\uffff\]" $s \
- {[apply {c {format {\u%04x} [scan $c %c]}} &]} s
+ regsub -all "\[\x7F-\xFF\]" $s \
+ {[apply {c {format {\x%02X} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
} -constraints {exec} -body {
- # If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
+ # If this fails, it may give back: "\xC3\xA9\xC3\xA0\xC3\xBC\xC3\xB1"
# If it does, this means that the UTF -> external conversion did not occur
# before writing out the temp file.
- quotenonascii [exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"]
+ quotenonascii [exec [interpreter] $path(cat) << "\xE9\xE0\xFC\xF1"]
} -cleanup {
encoding system $sysenc
rename quotenonascii {}
-} -result {\u00e9\u00e0\u00fc\u00f1}
+} -result {\xE9\xE0\xFC\xF1}
# I/O redirection: output to file.
diff --git a/tests/execute.test b/tests/execute.test
index 4b0f87f..8702de6 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -8,8 +8,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
@@ -34,7 +34,7 @@ testConstraint testobj [expr {
&& [llength [info commands teststringobj]]
}]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
@@ -179,7 +179,7 @@ test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj}
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "foo" as operand of "+"}}
test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 + $x}
@@ -204,7 +204,7 @@ test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj}
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "foo" as operand of "+"}}
# INST_SUB is partially tested:
test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
@@ -231,7 +231,7 @@ test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj}
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "foo" as operand of "-"}}
test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 - $x}
@@ -256,7 +256,7 @@ test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj}
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "foo" as operand of "-"}}
# INST_MULT is partially tested:
test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
@@ -283,7 +283,7 @@ test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "*"}}
+} {1 {can't use non-numeric string "foo" as operand of "*"}}
test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {1 * $x}
@@ -308,7 +308,7 @@ test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "*"}}
+} {1 {can't use non-numeric string "foo" as operand of "*"}}
# INST_DIV is partially tested:
test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
@@ -335,7 +335,7 @@ test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj}
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "foo" as operand of "/"}}
test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {2 / $x}
@@ -360,7 +360,7 @@ test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj}
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "foo" as operand of "/"}}
# INST_UPLUS is partially tested:
test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
@@ -387,7 +387,7 @@ test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "foo" as operand of "+"}}
# INST_UMINUS is partially tested:
test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
@@ -414,7 +414,7 @@ test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testob
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "foo" as operand of "-"}}
# INST_LNOT is partially tested:
test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
@@ -462,7 +462,7 @@ test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj}
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "foo" as operand of "!"}}
# INST_BITNOT not tested
# INST_CALL_BUILTIN_FUNC1 not tested
@@ -810,9 +810,9 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} {
set y [expr {$x+1}]
expr {double($x) == double($y)}
} 1
-test execute-7.8 {Wide int conversions can change sign} longIs32bit {
- set x 0x80000000
- expr {int($x) < wide($x)}
+test execute-7.8 {Wide int conversions can change sign} {
+ set x 0x8000000000000000
+ expr {wide($x) < 0}
} 1
test execute-7.9 {Wide int handling in INST_MOD} {
expr {(wide(1)<<60) % ((wide(47)<<45)-1)}
@@ -892,12 +892,12 @@ test execute-7.31 {Wide int handling in abs()} {
set y 0x123456871234568
concat [expr {abs($x)}] [expr {abs($y)}]
} {730503879441204585 81985533099853160}
-test execute-7.32 {Wide int handling} longIs32bit {
+test execute-7.32 {Wide int handling} {
expr {int(1024 * 1024 * 1024 * 1024)}
-} 0
-test execute-7.33 {Wide int handling} longIs32bit {
+} 1099511627776
+test execute-7.33 {Wide int handling} {
expr {int(0x1 * 1024 * 1024 * 1024 * 1024)}
-} 0
+} 1099511627776
test execute-7.34 {Wide int handling} {
expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
} 1099511627776
@@ -985,7 +985,7 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup
interp create child
child eval {
package require tcltest 2.5
- catch [list package require -exact Tcltest [info patchlevel]]
+ catch [list package require -exact tcl::test [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
@@ -1018,7 +1018,7 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti
interp create child
child eval {
package require tcltest 2.5
- catch [list package require -exact Tcltest [info patchlevel]]
+ catch [list package require -exact tcl::test [info patchlevel]]
::tcltest::loadTestedCommands
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
@@ -1066,7 +1066,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} {
} SUCCESS
test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
- apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
+ apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ
} {48 {304 304}}
test execute-10.2 {Bug 2802881} -setup {
interp create child
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 6f85748..2401bd4 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -6,29 +6,26 @@
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 by Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require tcltest 2.1
-namespace import ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# Big test for correct ordering of data in [expr]
@@ -38,9 +35,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -50,19 +47,19 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -72,11 +69,11 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -197,34 +194,34 @@ test expr-old-2.38 {floating-point operators} {
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
-} {1 {can't use floating-point value as operand of "~"}}
+} {1 {can't use floating-point value "4.0" as operand of "~"}}
test expr-old-3.2 {illegal floating-point operations} {
list [catch {expr 27%4.0} msg] $msg
-} {1 {can't use floating-point value as operand of "%"}}
+} {1 {can't use floating-point value "4.0" as operand of "%"}}
test expr-old-3.3 {illegal floating-point operations} {
list [catch {expr 27.0%4} msg] $msg
-} {1 {can't use floating-point value as operand of "%"}}
+} {1 {can't use floating-point value "27.0" as operand of "%"}}
test expr-old-3.4 {illegal floating-point operations} {
list [catch {expr 1.0<<3} msg] $msg
-} {1 {can't use floating-point value as operand of "<<"}}
+} {1 {can't use floating-point value "1.0" as operand of "<<"}}
test expr-old-3.5 {illegal floating-point operations} {
list [catch {expr 3<<1.0} msg] $msg
-} {1 {can't use floating-point value as operand of "<<"}}
+} {1 {can't use floating-point value "1.0" as operand of "<<"}}
test expr-old-3.6 {illegal floating-point operations} {
list [catch {expr 24.0>>3} msg] $msg
-} {1 {can't use floating-point value as operand of ">>"}}
+} {1 {can't use floating-point value "24.0" as operand of ">>"}}
test expr-old-3.7 {illegal floating-point operations} {
list [catch {expr 24>>3.0} msg] $msg
-} {1 {can't use floating-point value as operand of ">>"}}
+} {1 {can't use floating-point value "3.0" as operand of ">>"}}
test expr-old-3.8 {illegal floating-point operations} {
list [catch {expr 24&3.0} msg] $msg
-} {1 {can't use floating-point value as operand of "&"}}
+} {1 {can't use floating-point value "3.0" as operand of "&"}}
test expr-old-3.9 {illegal floating-point operations} {
list [catch {expr 24.0|3} msg] $msg
-} {1 {can't use floating-point value as operand of "|"}}
+} {1 {can't use floating-point value "24.0" as operand of "|"}}
test expr-old-3.10 {illegal floating-point operations} {
list [catch {expr 24.0^3} msg] $msg
-} {1 {can't use floating-point value as operand of "^"}}
+} {1 {can't use floating-point value "24.0" as operand of "^"}}
# Check the string operators individually.
@@ -265,46 +262,46 @@ test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "a" as operand of "-"}}
test expr-old-5.2 {illegal string operations} {
list [catch {expr {+"a"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "a" as operand of "+"}}
test expr-old-5.3 {illegal string operations} {
list [catch {expr {~"a"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "~"}}
+} {1 {can't use non-numeric string "a" as operand of "~"}}
test expr-old-5.4 {illegal string operations} {
list [catch {expr {!"a"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "a" as operand of "!"}}
test expr-old-5.5 {illegal string operations} {
list [catch {expr {"a"*"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "*"}}
+} {1 {can't use non-numeric string "a" as operand of "*"}}
test expr-old-5.6 {illegal string operations} {
list [catch {expr {"a"/"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "a" as operand of "/"}}
test expr-old-5.7 {illegal string operations} {
list [catch {expr {"a"%"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "%"}}
+} {1 {can't use non-numeric string "a" as operand of "%"}}
test expr-old-5.8 {illegal string operations} {
list [catch {expr {"a"+"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "a" as operand of "+"}}
test expr-old-5.9 {illegal string operations} {
list [catch {expr {"a"-"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "a" as operand of "-"}}
test expr-old-5.10 {illegal string operations} {
list [catch {expr {"a"<<"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "<<"}}
+} {1 {can't use non-numeric string "a" as operand of "<<"}}
test expr-old-5.11 {illegal string operations} {
list [catch {expr {"a">>"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of ">>"}}
+} {1 {can't use non-numeric string "a" as operand of ">>"}}
test expr-old-5.12 {illegal string operations} {
list [catch {expr {"a"&"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "&"}}
+} {1 {can't use non-numeric string "a" as operand of "&"}}
test expr-old-5.13 {illegal string operations} {
list [catch {expr {"a"^"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "^"}}
+} {1 {can't use non-numeric string "a" as operand of "^"}}
test expr-old-5.14 {illegal string operations} {
list [catch {expr {"a"|"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "|"}}
+} {1 {can't use non-numeric string "a" as operand of "|"}}
test expr-old-5.15 {illegal string operations} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
@@ -493,7 +490,7 @@ test expr-old-25.20 {type conversions} {expr 10.0} 10.0
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "a" as operand of "+"}}
test expr-old-26.2 {error conditions} -body {
expr 2+4*
} -returnCodes error -match glob -result *
@@ -507,10 +504,10 @@ test expr-old-26.4 {error conditions} {
set a xx
test expr-old-26.5 {error conditions} {
list [catch {expr {2+$a}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "xx" as operand of "+"}}
test expr-old-26.6 {error conditions} {
list [catch {expr {2+[set a]}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "xx" as operand of "+"}}
test expr-old-26.7 {error conditions} -body {
expr {2+(4}
} -returnCodes error -match glob -result *
@@ -527,14 +524,14 @@ test expr-old-26.10b {error conditions} ieeeFloatingPoint {
list [catch {expr 2.0/0.0} msg] $msg
} {0 Inf}
test expr-old-26.11 {error conditions} -body {
- expr 2#
+ expr 2`
} -returnCodes error -match glob -result *
test expr-old-26.12 {error conditions} -body {
expr a.b
} -returnCodes error -match glob -result *
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "a" as operand of "/"}}
test expr-old-26.14 {error conditions} -body {
expr 2:3
} -returnCodes error -match glob -result *
@@ -819,10 +816,10 @@ test expr-old-32.32 {math functions in expressions} {
} {-1}
test expr-old-32.33 {math functions in expressions} {
expr int(1e60)
-} 0
+} 999999999999999949387135297074018866963645011013410073083904
test expr-old-32.34 {math functions in expressions} {
expr int(-1e60)
-} 0
+} -999999999999999949387135297074018866963645011013410073083904
test expr-old-32.35 {math functions in expressions} {
expr round(1.49)
} {1}
@@ -847,12 +844,6 @@ test expr-old-32.41 {math functions in expressions} {
test expr-old-32.42 {math functions in expressions} {
list [catch {expr hypot(5*.8,3)} msg] $msg
} {0 5.0}
-test expr-old-32.43 {math functions in expressions} testmathfunctions {
- expr 2*T1()
-} 246
-test expr-old-32.44 {math functions in expressions} testmathfunctions {
- expr T2()*3
-} 1035
test expr-old-32.45 {math functions in expressions} {
expr (0 <= rand()) && (rand() < 1)
} {1}
@@ -952,10 +943,6 @@ test expr-old-34.15 {errors in math functions} {
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
-test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \
- -body {
- list [catch {expr T1(4)} msg] $msg
- } -match glob -result {1 {too many arguments for math function*}}
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
@@ -963,7 +950,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0o289
list [catch {expr {$x+1}} msg] $msg
-} {1 {can't use invalid octal number as operand of "+"}}
+} {1 {can't use invalid octal number "0o289" as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
@@ -1003,11 +990,11 @@ test expr-old-36.11 {ExprLooksLikeInt procedure} {
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "10;" as operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
set x " +"
list [catch {expr {$x+1}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string " +" as operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
set x "123456789012345678901234567890 "
expr {$x+1}
@@ -1015,7 +1002,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} {
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "0o99 "
list [catch {expr {$x+1}} msg] $msg
-} {1 {can't use invalid octal number as operand of "+"}}
+} {1 {can't use invalid octal number "0o99 " as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
expr {$x+1}
@@ -1052,8 +1039,8 @@ test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -0x80000000
} {This is a result: -2147483648}
test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
- testexprlong -0xffffffff
-} {This is a result: 1}
+ testexprlong -0x7fffffff
+} {This is a result: -2147483647}
test expr-old-37.10 {Tcl_ExprLong handles overflows} \
-constraints {testexprlong longIs32bit} \
-match glob \
@@ -1077,9 +1064,13 @@ test expr-old-37.13 {Tcl_ExprLong handles overflows} \
test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong {
testexprlong -2147483648.
} {This is a result: -2147483648}
-test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} {
- testexprlong -4294967295.
-} {This is a result: 1}
+test expr-old-37.15 {Tcl_ExprLong handles overflows} \
+ -constraints {testexprlong longIs32bit} \
+ -match glob \
+ -body {
+ list [catch {testexprlong -2147483649.} result] $result
+ } \
+ -result {1 {integer value too large to represent*}}
test expr-old-37.16 {Tcl_ExprLong handles overflows} \
-constraints {testexprlong longIs32bit} \
-match glob \
@@ -1159,8 +1150,8 @@ test expr-old-40.2 {min math function} -body {
expr {min(0.0)}
} -result 0.0
test expr-old-40.3 {min math function} -body {
- list [catch {expr {min()}} msg] $msg
-} -result {1 {not enough arguments to math function "min"}}
+ expr {min()}
+} -returnCodes error -result {not enough arguments for math function "min"}
test expr-old-40.4 {min math function} -body {
expr {min(wide(-1) << 30, 4.5, -10)}
} -result [expr {wide(-1) << 30}]
@@ -1170,6 +1161,12 @@ test expr-old-40.5 {min math function} -body {
test expr-old-40.6 {min math function} -body {
expr {min(300, "0xFF")}
} -result 255
+test expr-old-40.7 {min math function} -body {
+ expr min(1[string repeat 0 10000], 1e300)
+} -result 1e+300
+test expr-old-40.8 {min math function} -body {
+ expr {min(0, "a")}
+} -returnCodes error -match glob -result *
test expr-old-41.1 {max math function} -body {
expr {max(0)}
@@ -1178,8 +1175,8 @@ test expr-old-41.2 {max math function} -body {
expr {max(0.0)}
} -result 0.0
test expr-old-41.3 {max math function} -body {
- list [catch {expr {max()}} msg] $msg
-} -result {1 {not enough arguments to math function "max"}}
+ expr {max()}
+} -returnCodes error -result {not enough arguments for math function "max"}
test expr-old-41.4 {max math function} -body {
expr {max(wide(1) << 30, 4.5, -10)}
} -result [expr {wide(1) << 30}]
@@ -1189,6 +1186,12 @@ test expr-old-41.5 {max math function} -body {
test expr-old-41.6 {max math function} -body {
expr {max(200, "0xFF")}
} -result 255
+test expr-old-41.7 {max math function} -body {
+ expr max(1[string repeat 0 10000], 1e300)
+} -result 1[string repeat 0 10000]
+test expr-old-41.8 {max math function} -body {
+ expr {max(0, "a")}
+} -returnCodes error -match glob -result *
# Special test for Pentium arithmetic bug of 1994:
diff --git a/tests/expr.test b/tests/expr.test
index b8d3ff6..2c1dc21 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 Scriptics Corporation.
+# Copyright © 1996-1997 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,19 +16,14 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-
-testConstraint testmathfunctions [expr {
- ([catch {expr {T1()}} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
-}]
+catch [list package require -exact tcl::test [info patchlevel]]
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
-testConstraint wideIs64bit \
- [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
# Big test for correct ordering of data in [expr]
@@ -38,9 +33,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -50,21 +45,21 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \
ieeeValues(-NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -74,13 +69,13 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
- binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -143,9 +138,9 @@ proc do_twelve_days {} {
catch {unset a b i x}
-test expr-1.1 {TclCompileExprCmd: no expression} {
- list [catch {expr } msg] $msg
-} {1 {wrong # args: should be "expr arg ?arg ...?"}}
+test expr-1.1 {TclCompileExprCmd: no expression} -body {
+ expr
+} -returnCodes error -result {wrong # args: should be "expr arg ?arg ...?"}
test expr-1.2 {TclCompileExprCmd: one expression word} {
expr -25
} -25
@@ -192,12 +187,12 @@ test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in
} foo
test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
- set x 2; set b {$x}; set a [expr $b == 2]
+ set x 2; set b {$x}; set a [expr $b==2]
set a
} 1
test expr-1.15 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
- set x 2; set b {$x}; set a [expr $b eq 2]
+ set x 2; set b {$x}; set a [expr "$b eq 2"]
set a
} 1
@@ -257,7 +252,7 @@ test expr-4.9 {CompileLorExpr: long lor arm} {
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
list [catch {expr {!"a"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "a" as operand of "!"}}
test expr-4.11 {CompileLorExpr: error compiling land arms} {
list [catch {expr {"a"||0}} msg] $msg
} {1 {expected boolean value but got "a"}}
@@ -304,10 +299,10 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
} -returnCodes error -match glob -result *
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
-} {1 {can't use floating-point value as operand of "^"}}
+} {1 {can't use floating-point value "24.0" as operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "^"}}
+} {1 {can't use non-numeric string "a" as operand of "^"}}
test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
@@ -328,10 +323,10 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
} -returnCodes error -match glob -result *
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
-} {1 {can't use floating-point value as operand of "&"}}
+} {1 {can't use floating-point value "24.0" as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "&"}}
+} {1 {can't use non-numeric string "a" as operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} -body {
@@ -416,17 +411,34 @@ test expr-8.34 {expr edge cases} -body {
test expr-8.35 {expr edge cases} -body {
expr {1ea}
} -returnCodes error -match glob -result *
+test expr-8.36 {CompileEqualtyExpr: string comparison ops} {
+ set x 012
+ set y 0x0
+ list [expr {$x < $y}] [expr {$x lt $y}] [expr {$x lt $x}]
+} {0 1 0}
+test expr-8.37 {CompileEqualtyExpr: string comparison ops} {
+ set x 012
+ set y 0x0
+ list [expr {$x <= $y}] [expr {$x le $y}] [expr {$x le $x}]
+} {0 1 1}
+test expr-8.38 {CompileEqualtyExpr: string comparison ops} {
+ set x 012
+ set y 0x0
+ list [expr {$x > $y}] [expr {$x gt $y}] [expr {$x gt $x}]
+} {1 0 0}
+test expr-8.39 {CompileEqualtyExpr: string comparison ops} {
+ set x 012
+ set y 0x0
+ list [expr {$x >= $y}] [expr {$x ge $y}] [expr {$x ge $x}]
+} {1 0 1}
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
-test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit {
+test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {
expr {int(1<<63)}
-} -9223372036854775808
-test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit {
- expr {int(1<<31)}
-} -2147483648
+} 9223372036854775808
test expr-9.6 {CompileRelationalExpr: error in shift expr} -body {
expr x>>3
} -returnCodes error -match glob -result *
@@ -456,10 +468,10 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
} -returnCodes error -match glob -result *
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
-} {1 {can't use floating-point value as operand of ">>"}}
+} {1 {can't use floating-point value "24.0" as operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "<<"}}
+} {1 {can't use non-numeric string "a" as operand of "<<"}}
test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
@@ -478,10 +490,10 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body {
} -returnCodes error -match glob -result *
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "xx" as operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "-"}}
+} {1 {can't use non-numeric string "a" as operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
@@ -509,10 +521,10 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
} -returnCodes error -match glob -result *
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "*"}}
+} {1 {can't use non-numeric string "xx" as operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "/"}}
+} {1 {can't use non-numeric string "a" as operand of "/"}}
test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
@@ -529,10 +541,10 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
} -returnCodes error -match glob -result *
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "~"}}
+} {1 {can't use non-numeric string "xx" as operand of "~"}}
test expr-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
-} {1 {can't use floating-point value as operand of "~"}}
+} {1 {can't use floating-point value "4.0" as operand of "~"}}
test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test expr-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
@@ -685,41 +697,6 @@ test expr-15.5 {CompileMathFuncCall: not enough arguments} -body {
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr 2*T1()
-} 246
-test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T2()*3
-} 1035
-test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21, 37)
-} 37
-test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21.2, 37)
-} 37.0
-test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(-21.2, -17.5)
-} -17.5
-test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21, wide(37))
-} 37
-test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37)
-} 37
-test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), wide(37))
-} 37
-test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21.0, wide(37))
-} 37.0
-test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37.0)
-} 37.0
-test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints {
- testmathfunctions
-} -body {
- expr T3(0,"a")
-} -returnCodes error -result {argument to math function didn't have numeric value}
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
@@ -752,7 +729,7 @@ test expr-18.1 {expr and conversion of operands to numbers} {
catch {expr int($x)}
expr {$x}
} 11
-test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} {
+test expr-18.2 {whitespace strings should not be == 0 (buggy strtol/strtoul)} {
expr {" "}
} { }
@@ -844,15 +821,15 @@ test expr-21.13 {non-numeric boolean literals} -body {
} -returnCodes error -match glob -result *
test expr-21.14 {non-numeric boolean literals} {
list [catch {expr !"truef"} err] $err
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "truef" as operand of "!"}}
test expr-21.15 {non-numeric boolean variables} {
set v truef
list [catch {expr {!$v}} err] $err
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "truef" as operand of "!"}}
test expr-21.16 {non-numeric boolean variables} {
set v "true "
list [catch {expr {!$v}} err] $err
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "true " as operand of "!"}}
test expr-21.17 {non-numeric boolean variables} {
set v "tru"
list [catch {expr {!$v}} err] $err
@@ -872,23 +849,23 @@ test expr-21.20 {non-numeric boolean variables} {
test expr-21.21 {non-numeric boolean variables} {
set v "o"
list [catch {expr {!$v}} err] $err
-} {1 {can't use non-numeric string as operand of "!"}}
+} {1 {can't use non-numeric string "o" as operand of "!"}}
test expr-21.22 {non-numeric boolean variables} {
set v ""
list [catch {expr {!$v}} err] $err
-} {1 {can't use empty string as operand of "!"}}
+} {1 {can't use empty string "" as operand of "!"}}
# Test for non-numeric float handling.
test expr-22.1 {non-numeric floats} {
list [catch {expr {NaN + 1}} msg] $msg
-} {1 {can't use non-numeric floating-point value as operand of "+"}}
+} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}}
test expr-22.2 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} {
set nan NaN
list [catch {expr {$nan + 1}} msg] $msg
-} {1 {can't use non-numeric floating-point value as operand of "+"}}
+} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}}
test expr-22.4 {non-numeric floats} !ieeeFloatingPoint {
set inf Inf
list [catch {expr {$inf + 1}} msg] $msg
@@ -901,7 +878,7 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint {
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} {
list [catch {expr {1 / NaN}} msg] $msg
-} {1 {can't use non-numeric floating-point value as operand of "/"}}
+} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}}
test expr-22.8 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
@@ -937,10 +914,10 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
} -returnCodes error -match glob -result *
test expr-23.9 {CompileExponentialExpr: runtime error} {
list [catch {expr {24.0**"xx"}} msg] $msg
-} {1 {can't use non-numeric string as operand of "**"}}
+} {1 {can't use non-numeric string "xx" as operand of "**"}}
test expr-23.10 {CompileExponentialExpr: runtime error} {
list [catch {expr {"a"**2}} msg] $msg
-} {1 {can't use non-numeric string as operand of "**"}}
+} {1 {can't use non-numeric string "a" as operand of "**"}}
test expr-23.11 {CompileExponentialExpr: runtime error} {
list [catch {expr {0**-1}} msg] $msg
} {1 {exponentiation of zero by negative power}}
@@ -1444,14 +1421,15 @@ test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
-test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5<<32)} 0
-test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5<<63)} 0
+test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480
+test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480
test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0
test expr-24.10 {INST_LSHIFT: Bug 1567222} {expr 500000000000000<<28} 134217728000000000000000
test expr-24.11 {INST_LSHIFT: Bug 84a5355235} {expr -549755813888>>32} -128
+test expr-24.12 {INST_LSHIFT: Bug 920e393634} {expr 7244019458077122840<<1} 14488038916154245680
# List membership tests
test expr-25.1 {'in' operator} {expr {"a" in "a b c"}} 1
@@ -5849,7 +5827,7 @@ test expr-32.9 {bignum regression} {
expr {0%-(1+(1<<63))}
} 0
-test expr-33.1 {parse largest long value} longIs32bit {
+test expr-33.1 {parse largest long value} {
set max_long_str 2147483647
set max_long_hex "0x7FFFFFFF "
@@ -5863,7 +5841,7 @@ test expr-33.1 {parse largest long value} longIs32bit {
[expr {$max_long + 0}] \
[expr {2147483647 + 0}] \
[expr {$max_long == $max_long_hex}] \
- [expr {int(2147483647 + 1) < 0}] \
+ [expr {int(2147483647 + 1) > 0}] \
} {2147483647 2147483647 2147483647 2147483647 1 1}
test expr-33.2 {parse smallest long value} longIs32bit {
@@ -5883,7 +5861,7 @@ test expr-33.2 {parse smallest long value} longIs32bit {
[expr {$min_long + 0}] \
[expr {-2147483648 + 0}] \
[expr {$min_long == $min_long_hex}] \
- [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \
+ [expr {int(-2147483648 - 1) == -0x80000001}] \
} {-2147483648 -2147483648 -2147483648 -2147483648 1 1}
test expr-33.3 {parse largest wide value} wideIs64bit {
@@ -5963,17 +5941,17 @@ test expr-34.11 {expr edge cases} {
test expr-34.12 {expr edge cases} {
expr {$min % -2}
} {0}
-test expr-34.13 {expr edge cases} longIs32bit {
+test expr-34.13 {expr edge cases} {
expr {int($min / -1)}
-} {-2147483648}
+} {2147483648}
test expr-34.14 {expr edge cases} {
expr {$min % -1}
} {0}
-test expr-34.15 {expr edge cases} longIs32bit {
- expr {int($min * -1)}
+test expr-34.15 {expr edge cases} {
+ expr {-int($min * -1)}
} $min
-test expr-34.16 {expr edge cases} longIs32bit {
- expr {int(-$min)}
+test expr-34.16 {expr edge cases} {
+ expr {-int(-$min)}
} $min
test expr-34.17 {expr edge cases} {
expr {$min / 1}
@@ -6766,8 +6744,8 @@ test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -0x80000000
} {This is a result: -2147483648}
test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
- testexprlongobj -0xffffffff
-} {This is a result: 1}
+ testexprlongobj -0x7fffffff
+} {This is a result: -2147483647}
test expr-39.10 {Tcl_ExprLongObj handles overflows} \
-constraints {testexprlongobj longIs32bit} \
-match glob \
@@ -6792,8 +6770,8 @@ test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj {
testexprlongobj -2147483648.
} {This is a result: -2147483648}
test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} {
- testexprlongobj -4294967295.
-} {This is a result: 1}
+ testexprlongobj -2147483648.
+} {This is a result: -2147483648}
test expr-39.16 {Tcl_ExprLongObj handles overflows} \
-constraints {testexprlongobj longIs32bit} \
-match glob \
@@ -7278,6 +7256,204 @@ test expr-52.1 {
::tcl::unsupported::representation $a]]
} {0 0 1 1}
+foreach func {isfinite isinf isnan isnormal issubnormal} {
+ test expr-53.1.$func {float classification: basic arg handling} -body {
+ expr ${func}()
+ } -returnCodes error -result "not enough arguments for math function \"$func\""
+ test expr-53.2.$func {float classification: basic arg handling} -body {
+ expr ${func}(1,2)
+ } -returnCodes error -result "too many arguments for math function \"$func\""
+ test expr-53.3.$func {float classification: basic arg handling} -body {
+ expr ${func}(true)
+ } -returnCodes error -result {expected number but got "true"}
+ test expr-53.4.$func {float classification: basic arg handling} -body {
+ expr ${func}("gorp")
+ } -returnCodes error -result {expected number but got "gorp"}
+ test expr-53.5.$func {float classification: basic arg handling} -body {
+ expr ${func}(1.0)
+ } -match glob -result *
+ test expr-53.6.$func {float classification: basic arg handling} -body {
+ expr ${func}(0x123)
+ } -match glob -result *
+}
+
+test expr-54.0 {float classification: isfinite} {expr {isfinite(1.0)}} 1
+test expr-54.1 {float classification: isfinite} {expr {isfinite(-1.0)}} 1
+test expr-54.2 {float classification: isfinite} {expr {isfinite(0.0)}} 1
+test expr-54.3 {float classification: isfinite} {expr {isfinite(-0.0)}} 1
+test expr-54.4 {float classification: isfinite} {expr {isfinite(1/Inf)}} 1
+test expr-54.5 {float classification: isfinite} {expr {isfinite(-1/Inf)}} 1
+test expr-54.6 {float classification: isfinite} {expr {isfinite(1e-314)}} 1
+test expr-54.7 {float classification: isfinite} {expr {isfinite(inf)}} 0
+test expr-54.8 {float classification: isfinite} {expr {isfinite(-inf)}} 0
+test expr-54.9 {float classification: isfinite} {expr {isfinite(NaN)}} 0
+
+test expr-55.0 {float classification: isinf} {expr {isinf(1.0)}} 0
+test expr-55.1 {float classification: isinf} {expr {isinf(-1.0)}} 0
+test expr-55.2 {float classification: isinf} {expr {isinf(0.0)}} 0
+test expr-55.3 {float classification: isinf} {expr {isinf(-0.0)}} 0
+test expr-55.4 {float classification: isinf} {expr {isinf(1/Inf)}} 0
+test expr-55.5 {float classification: isinf} {expr {isinf(-1/Inf)}} 0
+test expr-55.6 {float classification: isinf} {expr {isinf(1e-314)}} 0
+test expr-55.7 {float classification: isinf} {expr {isinf(inf)}} 1
+test expr-55.8 {float classification: isinf} {expr {isinf(-inf)}} 1
+test expr-55.9 {float classification: isinf} {expr {isinf(NaN)}} 0
+
+test expr-56.0 {float classification: isnan} {expr {isnan(1.0)}} 0
+test expr-56.1 {float classification: isnan} {expr {isnan(-1.0)}} 0
+test expr-56.2 {float classification: isnan} {expr {isnan(0.0)}} 0
+test expr-56.3 {float classification: isnan} {expr {isnan(-0.0)}} 0
+test expr-56.4 {float classification: isnan} {expr {isnan(1/Inf)}} 0
+test expr-56.5 {float classification: isnan} {expr {isnan(-1/Inf)}} 0
+test expr-56.6 {float classification: isnan} {expr {isnan(1e-314)}} 0
+test expr-56.7 {float classification: isnan} {expr {isnan(inf)}} 0
+test expr-56.8 {float classification: isnan} {expr {isnan(-inf)}} 0
+test expr-56.9 {float classification: isnan} {expr {isnan(NaN)}} 1
+
+test expr-57.0 {float classification: isnormal} {expr {isnormal(1.0)}} 1
+test expr-57.1 {float classification: isnormal} {expr {isnormal(-1.0)}} 1
+test expr-57.2 {float classification: isnormal} {expr {isnormal(0.0)}} 0
+test expr-57.3 {float classification: isnormal} {expr {isnormal(-0.0)}} 0
+test expr-57.4 {float classification: isnormal} {expr {isnormal(1/Inf)}} 0
+test expr-57.5 {float classification: isnormal} {expr {isnormal(-1/Inf)}} 0
+test expr-57.6 {float classification: isnormal} {expr {isnormal(1e-314)}} 0
+test expr-57.7 {float classification: isnormal} {expr {isnormal(inf)}} 0
+test expr-57.8 {float classification: isnormal} {expr {isnormal(-inf)}} 0
+test expr-57.9 {float classification: isnormal} {expr {isnormal(NaN)}} 0
+
+test expr-58.0 {float classification: issubnormal} {expr {issubnormal(1.0)}} 0
+test expr-58.1 {float classification: issubnormal} {expr {issubnormal(-1.0)}} 0
+test expr-58.2 {float classification: issubnormal} {expr {issubnormal(0.0)}} 0
+test expr-58.3 {float classification: issubnormal} {expr {issubnormal(-0.0)}} 0
+test expr-58.4 {float classification: issubnormal} {expr {issubnormal(1/Inf)}} 0
+test expr-58.5 {float classification: issubnormal} {expr {issubnormal(-1/Inf)}} 0
+test expr-58.6 {float classification: issubnormal} {expr {issubnormal(1e-314)}} 1
+test expr-58.7 {float classification: issubnormal} {expr {issubnormal(inf)}} 0
+test expr-58.8 {float classification: issubnormal} {expr {issubnormal(-inf)}} 0
+test expr-58.9 {float classification: issubnormal} {expr {issubnormal(NaN)}} 0
+
+test expr-59.0 {float classification: fpclassify} {fpclassify 1.0} normal
+test expr-59.1 {float classification: fpclassify} {fpclassify -1.0} normal
+test expr-59.2 {float classification: fpclassify} {fpclassify 0.0} zero
+test expr-59.3 {float classification: fpclassify} {fpclassify -0.0} zero
+test expr-59.4 {float classification: fpclassify} {fpclassify [expr 1/Inf]} zero
+test expr-59.5 {float classification: fpclassify} {fpclassify [expr -1/Inf]} zero
+test expr-59.6 {float classification: fpclassify} {fpclassify 1e-314} subnormal
+test expr-59.7 {float classification: fpclassify} {fpclassify inf} infinite
+test expr-59.8 {float classification: fpclassify} {fpclassify -inf} infinite
+test expr-59.9 {float classification: fpclassify} {fpclassify NaN} nan
+test expr-59.10 {float classification: fpclassify} -returnCodes error -body {
+ fpclassify
+} -result {wrong # args: should be "fpclassify floatValue"}
+test expr-59.11 {float classification: fpclassify} -returnCodes error -body {
+ fpclassify a b
+} -result {wrong # args: should be "fpclassify floatValue"}
+test expr-59.12 {float classification: fpclassify} -returnCodes error -body {
+ fpclassify gorp
+} -result {expected number but got "gorp"}
+
+test expr-60.1 {float classification: basic arg handling} -body {
+ expr isunordered()
+} -returnCodes error -result {not enough arguments for math function "isunordered"}
+test expr-60.2 {float classification: basic arg handling} -body {
+ expr isunordered(1)
+} -returnCodes error -result {not enough arguments for math function "isunordered"}
+test expr-60.3 {float classification: basic arg handling} -body {
+ expr {isunordered(1, 2, 3)}
+} -returnCodes error -result {too many arguments for math function "isunordered"}
+test expr-60.4 {float classification: basic arg handling} -body {
+ expr {isunordered(true, 1.0)}
+} -returnCodes error -result {expected number but got "true"}
+test expr-60.5 {float classification: basic arg handling} -body {
+ expr {isunordered("gorp", 1.0)}
+} -returnCodes error -result {expected number but got "gorp"}
+test expr-60.6 {float classification: basic arg handling} -body {
+ expr {isunordered(0x123, 1.0)}
+} -match glob -result *
+test expr-60.7 {float classification: basic arg handling} -body {
+ expr {isunordered(1.0, true)}
+} -returnCodes error -result {expected number but got "true"}
+test expr-60.8 {float classification: basic arg handling} -body {
+ expr {isunordered(1.0, "gorp")}
+} -returnCodes error -result {expected number but got "gorp"}
+test expr-60.9 {float classification: basic arg handling} -body {
+ expr {isunordered(1.0, 0x123)}
+} -match glob -result *
+
+# Big matrix of comparisons, but it's just a binary isinf()
+set values {1.0 -1.0 0.0 -0.0 1e-314 Inf -Inf NaN}
+set results {0 0 0 0 0 0 0 1}
+set ctr 0
+foreach v1 $values r1 $results {
+ foreach v2 $values r2 $results {
+ test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" {
+ expr {isunordered($v1, $v2)}
+ } [expr {$r1 || $r2}]
+ }
+}
+unset -nocomplain values results ctr
+
+test expr-62.1 {TIP 582: comments} -body {
+ expr {1 # + 2}
+} -result 1
+test expr-62.2 {TIP 582: comments} -body {
+ expr "1 #\n+ 2"
+} -result 3
+test expr-62.3 {TIP 582: comments} -setup {
+ set ctr 0
+} -body {
+ expr {
+ # This is a demonstration of a comment
+ 1 + 2 + 3
+ # and another comment
+ + 4 + 5
+ # + [incr ctr]
+ + [incr ctr]
+ }
+} -result 16
+# Buggy because line breaks aren't tracked inside expressions at all
+test expr-62.4 {TIP 582: comments don't hide line breaks} -setup {
+ proc getline {} {
+ dict get [info frame -1] line
+ }
+ set base [getline]
+} -constraints knownBug -body {
+ expr {
+ 0
+ # a comment
+ + [getline] - $base
+ }
+} -cleanup {
+ rename getline ""
+} -result 5
+test expr-62.5 {TIP 582: comments don't splice tokens} {
+ set a False
+ expr {$a#don't splice
+ne#don't splice
+false}
+} 1
+test expr-62.6 {TIP 582: comments don't splice tokens} {
+ expr {0x2#don't splice
+ne#don't splice
+2}
+} 1
+test expr-62.7 {TIP 582: comments can go inside function calls} {
+ expr {max(1,# comment
+ 2)}
+} 2
+test expr-62.8 {TIP 582: comments can go inside function calls} {
+ expr {max(1# comment
+ ,2)}
+} 2
+test expr-62.9 {TIP 582: comments can go inside function calls} {
+ expr {max(# comment
+ 1,2)}
+} 2
+test expr-62.10 {TIP 582: comments can go inside function calls} {
+ expr {max# comment
+ (1,2)}
+} 2
+
# Bug e3dcab1d14
proc do-one-test-expr-63 {e p float athreshold} {
# e - power of 2 to test
@@ -7315,14 +7491,12 @@ proc run-test-expr-63 {} {
rename run-test-expr-63 {}
}
run-test-expr-63
-
-
+
# cleanup
-if {[info exists a]} {
- unset a
-}
-catch {unset min}
-catch {unset max}
+unset -nocomplain a
+unset -nocomplain min
+unset -nocomplain max
+
::tcltest::cleanupTests
return
diff --git a/tests/fCmd.test b/tests/fCmd.test
index d711138..2469762 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-# Copyright (c) 1999 Scriptics Corporation.
+# Copyright © 1996-1997 Sun Microsystems, Inc.
+# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,14 +16,12 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
cd [temporaryDirectory]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
-testConstraint winVista 0
-testConstraint win2000orXP 0
testConstraint winLessThan10 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
@@ -45,6 +43,8 @@ if {[testConstraint win]} {
}
}
+testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}]
+
# File permissions broken on wsl without some "exotic" wsl configuration
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]
@@ -70,17 +70,8 @@ if {[testConstraint unix]} {
}
# Also used in winFCmd...
-if {[testConstraint win] && [testConstraint nt]} {
- if {$::tcl_platform(osVersion) >= 5.0} {
- if {$::tcl_platform(osVersion) < 10.0} {
- testConstraint winLessThan10 1
- }
- if {$::tcl_platform(osVersion) >= 6.0} {
- testConstraint winVista 1
- } else {
- testConstraint win2000orXP 1
- }
- }
+if {[testConstraint win] && $::tcl_platform(osVersion) < 10.0} {
+ testConstraint winLessThan10 1
}
testConstraint darwin9 [expr {
@@ -112,6 +103,45 @@ if {[testConstraint unix]} {
}
}
+# Try getting a lower case glob pattern that will match the home directory of
+# a given user to test ~user and [file tildeexpand ~user]. Note this may not
+# be the same as ~ even when "user" is current user. For example, on Unix
+# platforms ~ will return HOME envvar, but ~user will lookup password file
+# bypassing HOME. If home directory not found, returns *$user* so caller can
+# succeed by using glob matching under the hope that the path contains
+# the user name.
+proc gethomedirglob {user} {
+ if {[testConstraint unix]} {
+ if {![catch {
+ exec {*}[auto_execok sh] -c "echo ~$user"
+ } home]} {
+ set home [string trim $home]
+ if {$home ne ""} {
+ # Expect exact match (except case), no glob * added
+ return [string tolower $home]
+ }
+ }
+ } elseif {[testConstraint reg]} {
+ # Windows with registry extension loaded
+ if {![catch {
+ set sid [exec {*}[auto_execok powershell] -Command "(Get-LocalUser -Name '$user')\[0\].sid.Value"]
+ set sid [string trim $sid]
+ # Get path from the Windows registry
+ set home [registry get "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\ProfileList\\$sid" ProfileImagePath]
+ set home [string trim [string tolower $home]]
+ } result]} {
+ if {$home ne ""} {
+ # file join for \ -> /
+ return [file join [string tolower $home]]
+ }
+ }
+ }
+
+ # Caller will need to use glob matching and hope user
+ # name is in the home directory path
+ return *[string tolower $user]*
+}
+
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
@@ -291,7 +321,7 @@ test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup {
} -constraints {notRoot unixOrWin} -returnCodes error -body {
file mkdir td1
file rename / td1
-} -result {error renaming "/" to "td1": file already exists}
+} -result {error renaming "/" to "td1": file exists}
test fCmd-3.16 {FileCopyRename: break on first error} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
@@ -302,7 +332,7 @@ test fCmd-3.16 {FileCopyRename: break on first error} -setup {
file mkdir td1
createfile [file join td1 tf3]
file rename tf1 tf2 tf3 tf4 td1
-} -result [subst {error renaming "tf3" to "[file join td1 tf3]": file already exists}]
+} -result [subst {error renaming "tf3" to "[file join td1 tf3]": file exists}]
test fCmd-4.1 {TclFileMakeDirsCmd: make each dir: 1 dir} -setup {
cleanup
@@ -358,7 +388,7 @@ test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} -setup {
} -constraints {notRoot} -returnCodes error -body {
createfile tf1
file mkdir tf1
-} -result [subst {can't create directory "[file join tf1]": file already exists}]
+} -result [subst {can't create directory "[file join tf1]": file exists}]
test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} -setup {
cleanup
} -constraints {notRoot} -body {
@@ -428,7 +458,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup {
} -cleanup {cleanup} -result {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
cleanup
-} -constraints {notRoot unixOrWin} -body {
+} -constraints {notRoot unixOrWin notWine} -body {
createfile tf1
createfile tf2
file mkdir td1
@@ -533,14 +563,14 @@ test fCmd-6.10 {CopyRenameOneFile: lstat(target) == 0} -setup {
createfile tf1
createfile tf2
file rename tf1 tf2
-} -result {error renaming "tf1" to "tf2": file already exists}
+} -result {error renaming "tf1" to "tf2": file exists}
test fCmd-6.11 {CopyRenameOneFile: force == 0} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
createfile tf1
createfile tf2
file rename tf1 tf2
-} -result {error renaming "tf1" to "tf2": file already exists}
+} -result {error renaming "tf1" to "tf2": file exists}
test fCmd-6.12 {CopyRenameOneFile: force != 0} -setup {
cleanup
} -constraints {notRoot} -body {
@@ -575,7 +605,7 @@ test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} -setup {
} -result 1
test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup {
cleanup
-} -constraints {notRoot} -body {
+} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2]
createfile [file join td1 td2 tf1]
file mkdir td2
@@ -584,12 +614,12 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup {
[subst {error renaming "td2" to "[file join td1 td2]": file *}]
test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} -setup {
cleanup
-} -constraints {notRoot} -returnCodes error -body {
+} -constraints {notRoot notWine} -returnCodes error -body {
file rename -force $root tf1
} -result [subst {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}]
test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup {
cleanup
-} -constraints {notRoot} -body {
+} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2]
createfile [file join td1 td2 tf1]
file mkdir td2
@@ -633,7 +663,7 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {xdev notRoot notWsl} -body {
file mkdir td1/td2/td3
- file attributes td1 -permissions 0o000
+ file attributes td1 -permissions 0
file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1 -permissions 0o755
@@ -644,7 +674,7 @@ test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup {
} -constraints {unix notRoot} -body {
file mkdir ~/td1/td2
set td1name [file join [file dirname ~] [file tail ~] td1]
- file attributes $td1name -permissions 0o000
+ file attributes $td1name -permissions 0
file copy ~/td1 td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
@@ -656,7 +686,7 @@ test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup {
file mkdir td2
file mkdir ~/td1
set td1name [file join [file dirname ~] [file tail ~] td1]
- file attributes $td1name -permissions 0o000
+ file attributes $td1name -permissions 0
file copy td2 ~/td1
} -returnCodes error -cleanup {
file attributes $td1name -permissions 0o755
@@ -667,7 +697,7 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup {
} -constraints {unix notRoot} -body {
file mkdir ~/td1/td2
set td2name [file join [file dirname ~] [file tail ~] td1 td2]
- file attributes $td2name -permissions 0o000
+ file attributes $td2name -permissions 0
file copy ~/td1 td1
} -returnCodes error -cleanup {
file attributes $td2name -permissions 0o755
@@ -680,12 +710,12 @@ test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
file mkdir [file join $tmpspace td1]
createfile [file join $tmpspace td1 tf1]
file rename -force td1 $tmpspace
-} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists}
+} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file exists}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup {
cleanup $tmpspace
} -constraints {notRoot xdev notWsl} -body {
file mkdir td1/td2/td3
- file attributes td1/td2/td3 -permissions 0o000
+ file attributes td1/td2/td3 -permissions 0
file rename td1 $tmpspace
} -returnCodes error -cleanup {
file attributes td1/td2/td3 -permissions 0o755
@@ -799,18 +829,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup {
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} -result {{tf3 tf4} 1 0}
-test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
- cleanup
-} -constraints {win win2000orXP testchmod} -body {
- file mkdir td1 td2
- testchmod 0o555 td2
- file rename td1 td3
- file rename td2 td4
- list [lsort [glob td*]] [file writable td3] [file writable td4]
-} -cleanup {
- cleanup
-} -result {{td3 td4} 1 0}
-test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup {
+test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {unix notRoot testchmod notDarwin9 notWsl} -body {
file mkdir td1 td2
@@ -823,7 +842,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup {
} -result {{td3 td4} 1 0}
test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
cleanup
-} -constraints {notRoot testchmod} -body {
+} -constraints {notRoot testchmod notWine} -body {
createfile tf1 tf1
createfile tf2 tf2
testchmod 0o444 tf2
@@ -831,17 +850,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
file rename -force tf2 tf2
list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} -result {tf1 tf2 1 0}
-test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup {
- cleanup
-} -constraints {win win2000orXP testchmod} -body {
- file mkdir td1
- file mkdir td2
- testchmod 0o555 td2
- file rename -force td1 .
- file rename -force td2 .
- list [lsort [glob td*]] [file writable td1] [file writable td2]
-} -result {{td1 td2} 1 0}
-test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup {
+test fCmd-9.6 {file rename: comprehensive: dir to self} -setup {
cleanup
} -constraints {unix notRoot testchmod notWsl} -body {
file mkdir td1
@@ -853,7 +862,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup {
} -result {{td1 td2} 1 0}
test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
cleanup
-} -constraints {notRoot testchmod} -body {
+} -constraints {notRoot testchmod notWine} -body {
createfile tf1
createfile tf2
createfile tfs1
@@ -874,7 +883,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
file rename -force tfs3 tfd3
file rename -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
-} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
+} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
@@ -910,25 +919,18 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
}
list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
[file writable [file join tdd2 tds2]] $w3 $w4
-} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
+} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file exists}} 1 1 0 0}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
cleanup
-} -constraints {notRoot testchmod} -body {
+} -constraints {notRoot testchmod notWine} -body {
file mkdir tds1
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
- if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 0o555 tds2
- }
set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg]
- if {[testConstraint unix] || [testConstraint winVista]} {
- set w2 0
- } else {
- set w2 [file writable tds2]
- }
+ set w2 0
list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} -match glob -result \
[subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file *}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file *}} 1 0}]
@@ -950,16 +952,9 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td1
file mkdir td2
file mkdir td3
- if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 0o555 td2
- }
file rename td1 [file join td3 td3]
file rename td2 [file join td3 td4]
- if {[testConstraint unix] || [testConstraint winVista]} {
- set w4 0
- } else {
- set w4 [file writable [file join td3 td4]]
- }
+ set w4 0
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] $w4
} -result [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
@@ -974,18 +969,18 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup {
[catch {file rename td1 td2} msg] $msg
} -cleanup {
testchmod 0o755 [file join td2 td1]
-} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
+} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file exists}}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup {
cleanup
-} -constraints {notRoot} -body {
+} -constraints {notRoot notWine} -body {
file mkdir [file join td1 td2] [file join td2 td1 td4]
file rename -force td1 td2
} -returnCodes error -match glob -result \
[subst {error renaming "td1" to "[file join td2 td1]": file *}]
test fCmd-9.14 {file rename: comprehensive: dir into self} -setup {
cleanup
-} -constraints {notRoot} -body {
+} -constraints {notRoot notWine} -body {
file mkdir td1
list [glob td*] [list [catch {file rename td1 td1} msg] $msg]
} -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}]
@@ -1081,7 +1076,7 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1]
test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
cleanup
-} -constraints {notRoot testchmod} -body {
+} -constraints {notRoot testchmod notWine} -body {
createfile tf1
createfile tf2
createfile tfs1
@@ -1111,7 +1106,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
file copy -force tfs3 tfd3
file copy -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
-} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
+} -result {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file exists}} 1 1 0 0}
test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
cleanup
} -constraints {notRoot testchmod} -body {
@@ -1135,7 +1130,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
set a4 [catch {file copy -force tds3 tdd3}]
set a5 [catch {file copy -force tds4 tdd4}]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
-} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
+} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
} -constraints {notRoot unixOrWin testchmod notWsl} -body {
@@ -1147,7 +1142,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
-} -result [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
+} -result [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file exists}} 1 0}]
test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup {
cleanup
} -constraints {notRoot testchmod} -body {
@@ -1548,7 +1543,7 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup {
catch {file delete -force -- tfa}
} -constraints {unix notRoot notWsl} -body {
file mkdir tfa/dir/a/b/c
- file attributes tfa/dir -permissions 0o000
+ file attributes tfa/dir -permissions 0
catch {file copy tfa tfa2}
} -cleanup {
file attributes tfa/dir -permissions 0o777
@@ -1591,7 +1586,7 @@ test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup {
} -constraints {unix notRoot} -body {
file mkdir tfa
createfile tfa/file
- file attributes tfa -permissions 0o000
+ file attributes tfa -permissions 0
catch {file mkdir tfa/file}
} -cleanup {
file attributes tfa -permissions 0o777
@@ -1960,7 +1955,7 @@ test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -se
} -constraints {unix notRoot notWsl} -body {
file mkdir tfa
file mkdir tfa/a
- file attributes tfa/a -permissions 0o000
+ file attributes tfa/a -permissions 00000
catch {file delete -force tfa}
} -cleanup {
file attributes tfa/a -permissions 0o777
@@ -2366,7 +2361,7 @@ test fCmd-28.6 {file link: unsupported operation} -setup {
file link -hard abc.link abc.dir
} -returnCodes error -cleanup {
cd [workingDirectory]
-} -result {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory}
+} -result {could not create new link "abc.link" pointing to "abc.dir": is a directory}
test fCmd-28.7 {file link: source already exists} -setup {
cd [temporaryDirectory]
} -constraints {linkFile} -body {
@@ -2425,7 +2420,7 @@ test fCmd-28.10.1 {file link: linking to nonexistent path} -setup {
test fCmd-28.11 {file link: success with directory} -setup {
cd [temporaryDirectory]
file delete -force abc.link
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
} -cleanup {
cd [workingDirectory]
@@ -2433,7 +2428,7 @@ test fCmd-28.11 {file link: success with directory} -setup {
test fCmd-28.12 {file link: cd into a link} -setup {
cd [temporaryDirectory]
file delete -force abc.link
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
set orig [pwd]
cd abc.link
@@ -2459,7 +2454,7 @@ test fCmd-28.12 {file link: cd into a link} -setup {
file delete -force abc.link
cd [workingDirectory]
} -result ok
-test fCmd-28.13 {file link} -constraints {linkDirectory} -setup {
+test fCmd-28.13 {file link} -constraints {linkDirectory notWine} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
} -body {
@@ -2493,7 +2488,7 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup {
test fCmd-28.15.2 {file link: copies link not dir} -setup {
cd [temporaryDirectory]
file delete -force abc.link
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
file copy abc.link abc2.link
list [file type abc2.link] [file tail [file link abc2.link]]
@@ -2514,7 +2509,7 @@ cd [workingDirectory]
test fCmd-28.16 {file link: glob inside link} -setup {
cd [temporaryDirectory]
file delete -force abc.link
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
file link abc.link abc.dir
lsort [glob -dir abc.link -tails *]
} -cleanup {
@@ -2524,13 +2519,13 @@ test fCmd-28.16 {file link: glob inside link} -setup {
test fCmd-28.17 {file link: glob -type l} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
glob -dir [pwd] -type l -tails abc*
} -cleanup {
file delete -force abc.link
cd [workingDirectory]
} -result {abc.link}
-test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup {
+test fCmd-28.18 {file link: glob -type d} -constraints {linkDirectory notWine} -setup {
cd [temporaryDirectory]
file link abc.link abc.dir
} -body {
@@ -2541,7 +2536,7 @@ test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup {
} -result [lsort [list abc.link abc.dir abc2.dir]]
test fCmd-28.19 {file link: relative paths} -setup {
cd [temporaryDirectory]
-} -constraints {win linkDirectory} -body {
+} -constraints {win linkDirectory notWine} -body {
file mkdir d1/d2/d3
file link d1/l2 d1/d2
} -cleanup {
@@ -2599,16 +2594,14 @@ test fCmd-30.1 {file writable on 'My Documents'} -setup {
} -constraints {win reg} -body {
file writable $mydocsname
} -result 1
-test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body {
+test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body {
expr {[info exists env(USERPROFILE)]
&& [file exists $env(USERPROFILE)/NTUSER.DAT]
&& [file readable $env(USERPROFILE)/NTUSER.DAT]}
} -result 1
# At least one CI environment (GitHub Actions) is set up with the page file in
# an unusual location; skip the test if that is so.
-test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {
- win notContinuousIntegration
-} -body {
+test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -body {
set r {}
if {[info exists env(SystemDrive)]} {
set path $env(SystemDrive)/pagefile.sys
@@ -2618,6 +2611,146 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {
}
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
+ string tolower [file home $::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::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-31.9 {file home USER does not follow env(HOME)} -setup {
+ set ::env(HOME) [file join $::env(HOME) foo]
+} -cleanup {
+ set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+ string tolower [file home $::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(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
+ string tolower [file tildeexpand ~$::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::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
+ string tolower [file tildeexpand ~$::tcl_platform(user)/bar]
+} -match glob -result [file join [gethomedirglob $::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
+ string tolower [file tildeexpand ~$::tcl_platform(user)\\bar]
+} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
+test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
+ set ::env(HOME) [file join $::env(HOME) foo]
+} -cleanup {
+ set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+ string tolower [file tildeexpand ~$::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
+
# cleanup
cleanup
diff --git a/tests/fileName.test b/tests/fileName.test
index 2a35987..b147bd7 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,8 +15,10 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testtranslatefilename [llength [info commands testtranslatefilename]]
@@ -30,6 +32,7 @@ if {[testConstraint win]} {
testConstraint symbolicLinkFile 0
testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}]
}
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# This match compares the first two words of the result. If the wanted result
# is "equal", then this is successful if the words are equal. If the wanted
# result is "not equal", then this is successful if the words are different.
@@ -199,7 +202,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
-} "/ foo"
+} "//foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
@@ -436,14 +439,14 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
-} "/a/b"
+} "//a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} "/a/b"
test filename-7.19 {[Bug f34cf83dd0]} {
file join foo //bar
-} /bar
+} //bar
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
@@ -788,7 +791,7 @@ test filename-11.17 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.17.1 {Tcl_GlobCmd} {win} {
+test filename-11.17.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -directory $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -799,7 +802,7 @@ test filename-11.17.1 {Tcl_GlobCmd} {win} {
[file join $globname y1.c] [file join $globname z1.c]]]
test filename-11.17.2 {Tcl_GlobCmd} -setup {
set dir [pwd]
-} -constraints {notRoot linkDirectory} -body {
+} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
@@ -812,7 +815,7 @@ test filename-11.17.2 {Tcl_GlobCmd} -setup {
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} -setup {
set dir [pwd]
-} -constraints {notRoot linkDirectory} -body {
+} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
@@ -827,7 +830,7 @@ test filename-11.17.3 {Tcl_GlobCmd} -setup {
# Make sure the bugfix isn't too simple. We don't want to break 'glob -type l'
test filename-11.17.4 {Tcl_GlobCmd} -setup {
set dir [pwd]
-} -constraints {notRoot linkDirectory} -body {
+} -constraints {notRoot linkDirectory notWine} -body {
cd $globname
file link -symbolic link a1
cd $dir
@@ -845,7 +848,7 @@ test filename-11.17.6 {Tcl_GlobCmd} {
[list "weird name.c" x,z1.c x1.c y1.c z1.c]]]
test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} -setup {
set dir [pwd]
-} -constraints {linkDirectory} -body {
+} -constraints {linkDirectory notWine} -body {
cd $globname
file mkdir nonexistent
file link -symbolic link nonexistent
@@ -877,7 +880,7 @@ test filename-11.18 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.18.1 {Tcl_GlobCmd} {win} {
+test filename-11.18.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -894,7 +897,7 @@ test filename-11.19 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.19.1 {Tcl_GlobCmd} {win} {
+test filename-11.19.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -903,7 +906,7 @@ test filename-11.19.1 {Tcl_GlobCmd} {win} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.20 {Tcl_GlobCmd} {
+test filename-11.20 {Tcl_GlobCmd} notWine {
lsort [glob -type d -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
@@ -933,7 +936,7 @@ test filename-11.22 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.22.1 {Tcl_GlobCmd} {win} {
+test filename-11.22.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -dir $globname *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -950,7 +953,7 @@ test filename-11.23 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.23.1 {Tcl_GlobCmd} {win} {
+test filename-11.23.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -path $globname/ *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -967,7 +970,7 @@ test filename-11.24 {Tcl_GlobCmd} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.24.1 {Tcl_GlobCmd} {win} {
+test filename-11.24.1 {Tcl_GlobCmd} {win notWine} {
lsort [glob -join -path [string range $globname 0 5] * *]
} [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
@@ -976,17 +979,17 @@ test filename-11.24.1 {Tcl_GlobCmd} {win} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-11.25 {Tcl_GlobCmd} {
+test filename-11.25 {Tcl_GlobCmd} notWine {
lsort [glob -type d -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
-test filename-11.25.1 {Tcl_GlobCmd} {
+test filename-11.25.1 {Tcl_GlobCmd} notWine {
lsort [glob -type {d r} -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]
-test filename-11.25.2 {Tcl_GlobCmd} {
+test filename-11.25.2 {Tcl_GlobCmd} notWine {
lsort [glob -type {d r w} -dir $globname *]
} [lsort [list [file join $globname a1]\
[file join $globname a2]\
@@ -1230,10 +1233,10 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup {
test filename-14.7 {asterisks, question marks, and brackets} {unix} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
-test filename-14.7.1 {asterisks, question marks, and brackets} {win} {
+test filename-14.7.1 {asterisks, question marks, and brackets} {win notWine} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
-test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} {
+test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin notWine} {
lsort [glob globTest/.*]
} {globTest/. globTest/.. globTest/.1}
test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
@@ -1242,7 +1245,7 @@ test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob {globTest/[xyab]1.*}]
} {globTest/x1.c globTest/y1.c}
-test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} {
+test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin notWine} {
lsort [glob globTest/*/]
} {globTest/a1/ globTest/a2/ globTest/a3/}
test filename-14.17 {asterisks, question marks, and brackets} -setup {
@@ -1282,7 +1285,7 @@ test filename-14.25 {type specific globbing} {unix} {
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]
-test filename-14.25.1 {type specific globbing} {win} {
+test filename-14.25.1 {type specific globbing} {win notWine} {
lsort [glob -dir globTest -types f *]
} [lsort [list \
[file join $globname .1]\
@@ -1327,7 +1330,7 @@ unset globname
# AFS, "000" protection doesn't prevent access by owner, so the following test
# is not portable.
-catch {file attributes globTest/a1 -permissions 0o000}
+catch {file attributes globTest/a1 -permissions 0}
test filename-15.1 {unix specific globbing} {unix nonPortable} {
string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
@@ -1627,6 +1630,61 @@ test fileName-20.10 {globbing for special chars} -setup {
removeFile fileName-20.10 $s
removeDirectory sub ~
} -result ~/sub/fileName-20.10
+
+
+apply [list {} {
+ test fileName-6d4e9d1af5bf5b7d {
+ memory leak in SetFsPathFromAny
+
+ Runs under both a TCL_DEBUG_MEM build and a -DPURIFY build for
+ valgrind, which is useful since Valgrind provides information about the
+ error location, but [memory] doesn't.
+ } -setup {
+ if {[namespace which ::memory] eq {}} {
+ set memcheckcmd [list ::apply [list script {
+ uplevel 1 $script
+ return 0
+ } [namespace current]]]
+ } else {
+ set memcheckcmd ::tcltests::scriptmemcheck
+ }
+ } -body {
+ {*}$memcheckcmd {
+ set interp [interp create]
+ interp eval $interp {
+ apply [list {} {
+ upvar 1 f f
+
+ # A unique name so that no internal representation of this
+ # literal value has been picked up from any other script
+ # that has alredy been sourced into this interpreter.
+ set variableUniqueInTheEntireTclCodebase a
+ set name variableUniqueInTheEntireTclCodebase
+
+ # give the Tcl_Obj for "var1" an internal representation of
+ # type 'localVarNameType'.
+ set $name
+
+ set f [open variableUniqueInTheEntireTclCodebase w]
+ try {
+ puts $f {some data}
+ } finally {
+ close $f
+ }
+
+ set f [open variableUniqueInTheEntireTclCodebase]
+ try {
+ read $f
+ } finally {
+ catch {file delete variableUniqueInTheEntireTclCodebase}
+ close $f
+ }
+ } [namespace current]]
+ }
+ interp delete $interp
+ }
+ } -result 0
+} [namespace current]]
# cleanup
catch {file delete -force C:/globTest}
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index f825e2b..7512504 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -4,18 +4,17 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 2002 Vincent Darley.
+# Copyright © 2002 Vincent Darley.
#
# 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::*
-}
-
namespace eval ::tcl::test::fileSystem {
- namespace import ::tcltest::*
+
+ if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+ }
catch {
file delete -force link.file
@@ -26,15 +25,15 @@ namespace eval ::tcl::test::fileSystem {
testConstraint loaddll 0
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
+ package require -exact tcl::test [info patchlevel]
set ::ddever [package require dde]
- set ::ddelib [lindex [package ifneeded dde $::ddever] 1]
+ set ::ddelib [info loaded {} Dde]
set ::regver [package require registry]
- set ::reglib [lindex [package ifneeded registry $::regver] 1]
- testConstraint loaddll 1
+ set ::reglib [info loaded {} Registry]
+ testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}]
}
-# Test for commands defined in Tcltest executable
+# Test for commands defined in tcl::test package
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
@@ -65,11 +64,12 @@ apply {{} {
set dir [pwd]
try {
- foreach vol [file volumes] {
- if {![catch {cd $vol}]} {
- lappend drives $vol
- }
- }
+ set drives [lmap vol [file volumes] {
+ if {$vol eq [zipfs root] || [catch {cd $vol}]} {
+ continue
+ }
+ set vol
+ }]
testConstraint moreThanOneDrive [expr {[llength $drives] > 1}]
} finally {
cd $dir
@@ -390,13 +390,13 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
testPathEqual [file norm /../../] [file norm /]
} ok
-test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body {
- set x //foo
+test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -body {
+ set x ///foo
file normalize $x
file join $x bar
} -result /foo/bar
test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body {
- set x //foo
+ set x ///foo
file normalize $x
file join $x
} -result /foo
@@ -693,7 +693,7 @@ test filesystem-7.4 {cross-filesystem file copy with -force} -setup {
file delete -force simplefile
file delete -force file2
cd $dir
-} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
+} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file exists} 0 {} 1}
test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
set dir [pwd]
cd [tcltest::temporaryDirectory]
@@ -705,7 +705,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
# First copy should succeed
set res [catch {file copy simplefs:/simplefile file2} err]
lappend res $err
- file attributes file2 -permissions 0o000
+ file attributes file2 -permissions 0
# Second copy should fail (no -force)
lappend res [catch {file copy simplefs:/simplefile file2} err]
lappend res $err
@@ -718,7 +718,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
file delete -force simplefile
file delete -force file2
cd $dir
-} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
+} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file exists} 0 {} 1}
test filesystem-7.6 {cross-filesystem dir copy with -force} -setup {
set dir [pwd]
cd [tcltest::temporaryDirectory]
@@ -746,7 +746,7 @@ test filesystem-7.6 {cross-filesystem dir copy with -force} -setup {
file delete -force simpledir
file delete -force dir2
cd $dir
-} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
+} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file exists} 0 {} 1 1}
test filesystem-7.7 {cross-filesystem dir copy with -force} -setup {
set dir [pwd]
cd [tcltest::temporaryDirectory]
@@ -776,7 +776,7 @@ test filesystem-7.7 {cross-filesystem dir copy with -force} -setup {
file delete -force simpledir
file delete -force dir2
cd $dir
-} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1}
+} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file exists} 0 {} 1 1}
removeFile gorp.file
test filesystem-7.8 {vfs cd} -setup {
set dir [pwd]
diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test
index 24003b8..f47635d 100644
--- a/tests/fileSystemEncoding.test
+++ b/tests/fileSystemEncoding.test
@@ -1,6 +1,6 @@
#! /usr/bin/env tclsh
-# Copyright (c) 2019 Poor Yorick
+# Copyright © 2019 Poor Yorick
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
@@ -13,7 +13,7 @@ namespace eval ::tcl::test::fileSystemEncoding {
namespace import -force ::tcltest::*
}
- variable fname1 \u767b\u9e1b\u9d72\u6a13
+ variable fname1 登鸛鵲樓
source [file join [file dirname [info script]] tcltests.tcl]
diff --git a/tests/for-old.test b/tests/for-old.test
index baf40fa..f5d1de9 100644
--- a/tests/for-old.test
+++ b/tests/for-old.test
@@ -6,8 +6,8 @@
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/for.test b/tests/for.test
index 8659d8e..26300ce 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright © 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/foreach.test b/tests/foreach.test
index bb06b80..4a1c35a 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-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.
diff --git a/tests/format.test b/tests/format.test
index 6944cc3..4accb33 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1998 Sun Microsystems, Inc.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 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.
@@ -16,23 +16,21 @@ if {"::tcltest" ni [namespace children]} {
}
# %u output depends on word length, so this test is not portable.
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
-testConstraint wideIs64bit [expr {
- (wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
-testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
+testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain
# particularly in Continuous Integration, and there isn't anything much we can
# do about it.
-testConstraint notWinCI [expr {
- ($::tcl_platform(platform) ne "windows") || ![info exists ::env(CI)]}]
-
+testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}]
+
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
-} { 6 34 16923 -12 -1 0xe 0XC}
+} { 6 34 16923 -12 -1 0xe 0xC}
test format-1.3 {integer formatting} longIs32bit {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 4294967284 -1 0}
@@ -58,40 +56,40 @@ test format-1.7.1 {integer formatting} longIs64bit {
} { 6 22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffff4}
+} {0 0x6 0x22 0x421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4}
+} {0 0x6 0x22 0x421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffff4 }
test format-1.10.1 {integer formatting} longIs64bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffffffffffff4 }
test format-1.11 {integer formatting} longIs32bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 037777777764 }
+} {0 0o6 0o42 0o41033 0o37777777764 }
test format-1.11.1 {integer formatting} longIs64bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 01777777777777777777764}
+} {0 0o6 0o42 0o41033 0o1777777777777777777764}
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
-} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12}
+ format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
+} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0 6 34 16923 -12}
+ format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-1.15 {integer formatting} {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0 6 34 16923 -12 }
+ format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-2.1 {string formatting} {
@@ -107,8 +105,8 @@ test format-2.4 {string formatting} {
format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. % x x}
test format-2.5 {string formatting, embedded nulls} {
- format "%10s" abc\0def
-} " abc\0def"
+ format "%10s" abc\x00def
+} " abc\x00def"
test format-2.6 {string formatting, international chars} {
format "%10s" abc\uFEFFdef
} " abc\uFEFFdef"
@@ -145,13 +143,19 @@ test format-2.16 {string formatting, width and precision} {
test format-2.17 {string formatting, width and precision} {
format "a%5.7sa" foobarbaz
} "afoobarba"
+test format-2.18 {string formatting, surrogates} {
+ format "\uD83D%s" \uDE02
+} \uD83D\uDE02
+test format-2.19 {string formatting, surrogates} {
+ format "%s\uDE02" \uD83D
+} \uD83D\uDE02
test format-3.1 {Tcl_FormatObjCmd: character formatting} {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65
} "|A|A|A|A|A | A| A|A |"
test format-3.2 {Tcl_FormatObjCmd: international character formatting} {
- format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f
-} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |"
+ format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xA2 0x4E4E 0x25A 0xC3 0xFF08 0 3 0x6575 -4 0x4E4F
+} "|¢|乎|ɚ|Ã|( | \x00| 敵|乏 |"
test format-4.1 {e and f formats} {eformat} {
format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
@@ -269,13 +273,13 @@ test format-6.1 {floating-point zeroes} {eformat} {
test format-6.2 {floating-point zeroes} {eformat} {
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0}
-test format-6.3 {floating-point zeroes} {eformat notWinCI} {
+test format-6.3 {floating-point zeroes} {eformat knownMsvcBug} {
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0.000}
test format-6.4 {floating-point zeroes} {eformat} {
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
} {0e+00 0 0}
-test format-6.5 {floating-point zeroes} {eformat notWinCI} {
+test format-6.5 {floating-point zeroes} {eformat knownMsvcBug} {
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
} {0.e+00 0. 0.}
test format-6.6 {floating-point zeroes} {
@@ -378,6 +382,29 @@ test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
+# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and
+# equivalent to "%d" in 32-bit platforms, they are really not useful in
+# scripts, therefore they are not documented. It's intended use is through
+# the function Tcl_AppendPrintfToObj (et al).
+test format-8.24 {Undocumented formats} -body {
+ format "%zd %td %d" [expr {2**30}] [expr {2**30}] [expr {2**30}]
+} -result {1073741824 1073741824 1073741824}
+test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body {
+ format "%zd %td %lld" [expr {2**33}] [expr {2**33}] [expr {2**33}]
+} -result {8589934592 8589934592 8589934592}
+# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent
+# to "%#x" in 32-bit platforms, it are really not useful in scripts,
+# therefore they are not documented. It's intended use is through the
+# function Tcl_AppendPrintfToObj (et al).
+test format-8.26 {Undocumented formats} -body {
+ format "%p %#x" [expr {2**31}] [expr {2**31}]
+} -result {0x80000000 0x80000000}
+test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body {
+ format "%p %#llx" [expr {2**33}] [expr {2**33}]
+} -result {0x200000000 0x200000000}
+test format-8.28 {Internal use of TCL_COMBINE flag should not be visible at script level} {
+ format %c 0x10000041
+} \uFFFD
test format-9.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
@@ -438,6 +465,12 @@ test format-11.11 {XPG3 %$n specifiers} {
test format-11.12 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5 6} msg] $msg
} {0 { 6}}
+test format-11.13 {XPG3 %$n specifiers} {
+ format {%2$.*s %4$d} 1 -4294967298 abcdefghijklmnop 44
+} { 44}
+test format-11.14 {XPG3 %$n specifiers} {
+ format {%2$.*s %4$d} 1 4294967298 abcdefghijklmnop 44
+} {abcdefghijklmnop 44}
test format-12.1 {negative width specifiers} {
format "%*d" -47 25
@@ -531,7 +564,7 @@ for {set i 290} {$i < 400} {incr i} {
append b "x"
}
-test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} {
+test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
@@ -545,7 +578,7 @@ test format-17.4 {testing %l with non-integer} {
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
format %llu 0xabcdef0123456789abcdef
-} -returnCodes 1 -result {unsigned bignum format is invalid}
+} -result 207698809136909011942886895
test format-17.6 {testing %llu with negative number} -body {
format %llu -1
} -returnCodes 1 -result {unsigned bignum format is invalid}
@@ -564,7 +597,7 @@ test format-18.1 {do not demote existing numeric values} {
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
-test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
+test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
diff --git a/tests/get.test b/tests/get.test
index a7bab5d..0281760 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -4,8 +4,8 @@
# file tclGet.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,10 +16,13 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+
+source [file join [file dirname [info script]] tcltests.tcl]
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}
@@ -42,12 +45,12 @@ test get-1.6 {Tcl_GetInt procedure} testgetint {
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 {
- 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.9 {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.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}}}
@@ -62,7 +65,7 @@ test get-1.13 {Tcl_GetInt procedure} testgetint {
} {0 -2}
test get-1.14 {Tcl_GetInt procedure} testgetint {
list [catch {testgetint -4294967294} msg] $msg
-} {0 2}
+} {1 {integer value too large to represent}}
test get-2.1 {Tcl_GetInt procedure} {
format %g 1.23
@@ -96,17 +99,32 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} {
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
- lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} {
+ lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} {
catch {testgetint 44 $x} x
set x
}
-} {44 44 44 44 54 52 52 46}
-test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
- lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} {
+} {44 44 44 44 54 51 52 46}
+
+test get-3.4 {Tcl_GetDouble with iffy numbers} {testdoubleobj} {
+ lmap x {0 0.0 " .0" ".0 " " 0e0 " "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} {
catch {testdoubleobj set 1 $x} x
set x
}
-} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
+} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}}
+
+test get-3.4.1 {Tcl_GetDouble with iffy numbers} {testdoubleobj deprecated} {
+ lmap x {"09"} {
+ catch {testdoubleobj set 1 $x} x
+ set x
+ }
+} {{expected floating-point number but got "09" (looks like invalid octal number)}}
+
+test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint {
+ lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x0_a " 0b1111_1111 " 0_07 " " 0o1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 0x_b 0o_2_0 0o2__3_4} {
+ catch {testgetint $x} x
+ set x
+ }
+} {0 10 2 33 1423324 10 255 7 8 {expected integer but got " 0b_1_0 "} {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"} {expected integer but got "0x_b"} {expected integer but got "0o_2_0"} 156}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/history.test b/tests/history.test
index 813f84f..557c856 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/http.test b/tests/http.test
index 498621b..e9a0b31 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -4,9 +4,9 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,23 +15,9 @@ if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
+source [file join [file dirname [info script]] tcltests.tcl]
-if {[catch {package require http 2} version]} {
- if {[info exists http2]} {
- catch {puts "Cannot load http 2.* package"}
- return
- } else {
- catch {puts "Running http 2.* tests in child interp"}
- set interp [interp create http2]
- $interp eval [list set http2 "running"]
- $interp eval [list set argv $argv]
- $interp eval [list source [info script]]
- interp delete $interp
- return
- }
-}
-testConstraint http2.9.7 [package vsatisfies [package provide http] 2.9.7]
-testConstraint http2.9.8 [package vsatisfies [package provide http] 2.9.8]
+package require http 2.10
proc bgerror {args} {
global errorInfo
@@ -44,8 +30,7 @@ proc bgerror {args} {
# Name resolution is often a problem on OSX; not focus of HTTP package anyway.
# Also a problem on other platforms for http-4.14 (test with bad port number).
set HOST localhost
-set port 8010
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
+set bindata "This is binary data\x0D\x0Amore\x0Dmore\x0Amore\x00null"
catch {unset data}
# Ensure httpd file exists
@@ -62,10 +47,10 @@ if {![file exists $httpdFile]} {
catch {package require Thread 2.7-}
if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
set httpthread [thread::create -preserved]
+ lappend threadStack [list thread::release $httpthread]
thread::send $httpthread [list source $httpdFile]
- thread::send $httpthread [list set port $port]
thread::send $httpthread [list set bindata $bindata]
- thread::send $httpthread {httpd_init $port}
+ thread::send $httpthread {httpd_init 0; set port} port
puts "Running httpd in thread $httpthread"
} else {
if {![file exists $httpdFile]} {
@@ -77,26 +62,46 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
# 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"
- unset port
+ catch {unset port}
return
+ }
+ set threadStack {}
+}
+
+if {![info exists ThreadLevel]} {
+ if {[catch {package require Thread}] == 0} {
+ set ValueRange {0 1 2}
} else {
- # Running httpd in the current thread overwrites the values of port
- # (here) and HOST (in the sourced server file).
- set port [lindex [fconfigure $listen -sockname] 2]
+ set ValueRange {0 1}
}
+
+ # For each value of ThreadLevel, source this file recursively in the
+ # same interpreter.
+ foreach ThreadLevel $ValueRange {
+ source [info script]
+ }
+ if {[llength $threadStack]} {
+ eval [lpop threadStack]
+ }
+ catch {unset ThreadLevel}
+ catch {unset ValueRange}
+ return
}
+
+catch {puts "==== Test with ThreadLevel $ThreadLevel ===="}
+http::config -threadlevel $ThreadLevel
-test http-1.1 {http::config} {
+test http-1.1.$ThreadLevel {http::config} {
http::config -useragent UserAgent
http::config
-} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
-test http-1.2 {http::config} {
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter http::ProxyRequired -proxyhost {} -proxynot {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1]
+test http-1.2.$ThreadLevel {http::config} {
http::config -proxyfilter
} http::ProxyRequired
-test http-1.3 {http::config} {
+test http-1.3.$ThreadLevel {http::config} {
catch {http::config -junk}
} 1
-test http-1.4 {http::config} {
+test http-1.4.$ThreadLevel {http::config} {
set savedconf [http::config]
http::config -proxyhost nowhere.come -proxyport 8080 \
-proxyfilter myFilter -useragent "Tcl Test Suite" \
@@ -104,11 +109,11 @@ test http-1.4 {http::config} {
set x [http::config]
http::config {*}$savedconf
set x
-} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
-test http-1.5 {http::config} -returnCodes error -body {
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter myFilter -proxyhost nowhere.come -proxynot {} -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1]
+test http-1.5.$ThreadLevel {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
-test http-1.6 {http::config} -setup {
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyauth, -proxyfilter, -proxyhost, -proxynot, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip}
+test http-1.6.$ThreadLevel {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
set enc [list [http::config -urlencoding]]
@@ -118,40 +123,42 @@ test http-1.6 {http::config} -setup {
http::config -urlencoding $oldenc
} -result {utf-8 iso8859-1}
-test http-2.1 {http::reset} {
+test http-2.1.$ThreadLevel {http::reset} {
catch {http::reset http#1}
} 0
-test http-2.2 {http::CharsetToEncoding} http2.9.7 {
+test http-2.2.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding iso-8859-11
} iso8859-11
-test http-2.3 {http::CharsetToEncoding} http2.9.7 {
+test http-2.3.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding iso-2022-kr
} iso2022-kr
-test http-2.4 {http::CharsetToEncoding} http2.9.7 {
+test http-2.4.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding shift-jis
} shiftjis
-test http-2.5 {http::CharsetToEncoding} http2.9.7 {
+test http-2.5.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding windows-437
} cp437
-test http-2.6 {http::CharsetToEncoding} http2.9.7 {
+test http-2.6.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding latin5
} iso8859-9
-test http-2.7 {http::CharsetToEncoding} http2.9.7 {
+test http-2.7.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding latin1
} iso8859-1
-test http-2.8 {http::CharsetToEncoding} http2.9.7 {
+test http-2.8.$ThreadLevel {http::CharsetToEncoding} {
http::CharsetToEncoding latin4
} binary
-test http-3.1 {http::geturl} -returnCodes error -body {
+test http-3.1.$ThreadLevel {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 {
+} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -guesstype, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
+
+test http-3.2.$ThreadLevel {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 {
+test http-3.3.$ThreadLevel {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
@@ -160,6 +167,7 @@ test http-3.3 {http::geturl} -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
@@ -169,7 +177,8 @@ 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 {
+
+test http-3.4.$ThreadLevel {http::geturl} -body {
set token [http::geturl $url]
http::data $token
} -cleanup {
@@ -182,7 +191,7 @@ proc selfproxy {host} {
global port
return [list ${::HOST} $port]
}
-test http-3.5 {http::geturl} -body {
+test http-3.5.$ThreadLevel {http::geturl} -body {
http::config -proxyfilter selfproxy
set token [http::geturl $url]
http::data $token
@@ -193,7 +202,7 @@ test http-3.5 {http::geturl} -body {
<h1>Hello, World!</h1>
<h2>GET http:$url</h2>
</body></html>"
-test http-3.6 {http::geturl} -body {
+test http-3.6.$ThreadLevel {http::geturl} -body {
http::config -proxyfilter bogus
set token [http::geturl $url]
http::data $token
@@ -204,7 +213,7 @@ test http-3.6 {http::geturl} -body {
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-3.7 {http::geturl} -body {
+test http-3.7.$ThreadLevel {http::geturl} -body {
set token [http::geturl $url -headers {Pragma no-cache}]
http::data $token
} -cleanup {
@@ -213,7 +222,7 @@ test http-3.7 {http::geturl} -body {
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-3.8 {http::geturl} -body {
+test http-3.8.$ThreadLevel {http::geturl} -body {
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000]
http::data $token
} -cleanup {
@@ -227,13 +236,13 @@ test http-3.8 {http::geturl} -body {
<dt>Foo<dd>Bar
</dl>
</body></html>"
-test http-3.9 {http::geturl} -body {
+test http-3.9.$ThreadLevel {http::geturl} -body {
set token [http::geturl $url -validate 1]
http::code $token
} -cleanup {
http::cleanup $token
} -result "HTTP/1.0 200 OK"
-test http-3.10 {http::geturl queryprogress} -setup {
+test http-3.10.$ThreadLevel {http::geturl queryprogress} -setup {
set query foo=bar
set sep ""
set i 0
@@ -256,7 +265,7 @@ test http-3.10 {http::geturl queryprogress} -setup {
} -cleanup {
http::cleanup $t
} -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
-test http-3.11 {http::geturl querychannel with -command} -setup {
+test http-3.11.$ThreadLevel {http::geturl querychannel with -command} -setup {
set query foo=bar
set sep ""
set i 0
@@ -295,7 +304,7 @@ test http-3.11 {http::geturl querychannel with -command} -setup {
# The status is "eof".
# On Windows, the http::wait procedure gets a "connection reset by peer" error
# while reading the reply.
-test http-3.12 {http::geturl querychannel with aborted request} -setup {
+test http-3.12.$ThreadLevel {http::geturl querychannel with aborted request} -setup {
set query foo=bar
set sep ""
set i 0
@@ -333,7 +342,7 @@ test http-3.12 {http::geturl querychannel with aborted request} -setup {
removeFile outdata
http::cleanup $t
} -result {ok {HTTP/1.0 200 Data follows}}
-test http-3.13 {http::geturl socket leak test} {
+test http-3.13.$ThreadLevel {http::geturl socket leak test} {
set chanCount [llength [file channels]]
for {set i 0} {$i < 3} {incr i} {
catch {http::geturl $badurl -timeout 5000}
@@ -341,43 +350,43 @@ test http-3.13 {http::geturl socket leak test} {
# No extra channels should be taken
expr {[llength [file channels]] == $chanCount}
} 1
-test http-3.14 "http::geturl $fullurl" -body {
+test http-3.14.$ThreadLevel "http::geturl $fullurl" -body {
set token [http::geturl $fullurl -validate 1]
http::code $token
} -cleanup {
http::cleanup $token
} -result "HTTP/1.0 200 OK"
-test http-3.15 {http::geturl parse failures} -body {
+test http-3.15.$ThreadLevel {http::geturl parse failures} -body {
http::geturl "{invalid}:url"
} -returnCodes error -result {Unsupported URL: {invalid}:url}
-test http-3.16 {http::geturl parse failures} -body {
+test http-3.16.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http:relative/url
} -returnCodes error -result {Unsupported URL: http:relative/url}
-test http-3.17 {http::geturl parse failures} -body {
+test http-3.17.$ThreadLevel {http::geturl parse failures} -body {
http::geturl /absolute/url
} -returnCodes error -result {Missing host part: /absolute/url}
-test http-3.18 {http::geturl parse failures} -body {
+test http-3.18.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://somewhere:123456789/
} -returnCodes error -result {Invalid port number: 123456789}
-test http-3.19 {http::geturl parse failures} -body {
+test http-3.19.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://{user}@somewhere
} -returnCodes error -result {Illegal characters in URL user}
-test http-3.20 {http::geturl parse failures} -body {
+test http-3.20.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://%user@somewhere
} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
-test http-3.21 {http::geturl parse failures} -body {
+test http-3.21.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://somewhere/{path}
} -returnCodes error -result {Illegal characters in URL path}
-test http-3.22 {http::geturl parse failures} -body {
+test http-3.22.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://somewhere/%path
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
-test http-3.23 {http::geturl parse failures} -body {
+test http-3.23.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://somewhere/path?{query}?
} -returnCodes error -result {Illegal characters in URL path}
-test http-3.24 {http::geturl parse failures} -body {
+test http-3.24.$ThreadLevel {http::geturl parse failures} -body {
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
-test http-3.25 {http::meta} -setup {
+test http-3.25.$ThreadLevel {http::meta} -setup {
unset -nocomplain m token
} -body {
set token [http::geturl $url -timeout 3000]
@@ -386,8 +395,8 @@ test http-3.25 {http::meta} -setup {
} -cleanup {
http::cleanup $token
unset -nocomplain m token
-} -result {Content-Length Content-Type Date}
-test http-3.26 {http::meta} -setup {
+} -result {content-length content-type date}
+test http-3.26.$ThreadLevel {http::meta} -setup {
unset -nocomplain m token
} -body {
set token [http::geturl $url -headers {X-Check 1} -timeout 3000]
@@ -396,8 +405,8 @@ test http-3.26 {http::meta} -setup {
} -cleanup {
http::cleanup $token
unset -nocomplain m token
-} -result {Content-Length Content-Type Date X-Check}
-test http-3.27 {http::geturl: -headers override -type} -body {
+} -result {content-length content-type date x-check}
+test http-3.27.$ThreadLevel {http::geturl: -headers override -type} -body {
set token [http::geturl $url/headers -type "text/plain" -query dummy \
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
http::data $token
@@ -405,12 +414,12 @@ test http-3.27 {http::geturl: -headers override -type} -body {
http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
-Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
+Connection close
Content-Length 5}
-test http-3.28 {http::geturl: -headers override -type default} -body {
+test http-3.28.$ThreadLevel {http::geturl: -headers override -type default} -body {
set token [http::geturl $url/headers -query dummy \
-headers [list "Content-Type" "text/plain;charset=utf-8"]]
http::data $token
@@ -418,12 +427,12 @@ test http-3.28 {http::geturl: -headers override -type default} -body {
http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
-Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
+Connection close
Content-Length 5}
-test http-3.29 {http::geturl IPv6 address} -body {
+test http-3.29.$ThreadLevel {http::geturl IPv6 address} -body {
# We only want to see if the URL gets parsed correctly. This is
# the case if http::geturl succeeds or returns a socket related
# error. If the parsing is wrong, we'll get a parse error.
@@ -437,20 +446,20 @@ test http-3.29 {http::geturl IPv6 address} -body {
} -cleanup {
catch { http::cleanup $token }
} -result 0
-test http-3.30 {http::geturl query without path} -body {
+test http-3.30.$ThreadLevel {http::geturl query without path} -body {
set token [http::geturl $authorityurl?var=val]
http::ncode $token
} -cleanup {
catch { http::cleanup $token }
} -result 200
-test http-3.31 {http::geturl fragment without path} -body {
+test http-3.31.$ThreadLevel {http::geturl fragment without path} -body {
set token [http::geturl "$authorityurl#fragment42"]
http::ncode $token
} -cleanup {
catch { http::cleanup $token }
} -result 200
# Bug c11a51c482
-test http-3.32 {http::geturl: -headers override -accept default} -body {
+test http-3.32.$ThreadLevel {http::geturl: -headers override -accept default} -body {
set token [http::geturl $url/headers -query dummy \
-headers [list "Accept" "text/plain,application/tcl-test-value"]]
http::data $token
@@ -458,50 +467,48 @@ test http-3.32 {http::geturl: -headers override -accept default} -body {
http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
-Connection close
Accept text/plain,application/tcl-test-value
Accept-Encoding .*
+Connection close
Content-Type application/x-www-form-urlencoded
Content-Length 5}
# Bug 838e99a76d
-test http-3.33 {http::geturl application/xml is text} -body {
+test http-3.33.$ThreadLevel {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 {
+test http-3.34.$ThreadLevel {http::geturl -headers not a list} -returnCodes error -body {
http::geturl http://test/t -headers \"
-} -constraints http2.9.8 -result {Bad value for -headers ("), must be list}
-test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body {
+} -result {Bad value for -headers ("), must be list}
+test http-3.35.$ThreadLevel {http::geturl -headers not even number of elements} -returnCodes error -body {
http::geturl http://test/t -headers {List Length 3}
-} -constraints http2.9.8 -result {Bad value for -headers (List Length 3), number of list elements must be even}
+} -result {Bad value for -headers (List Length 3), number of list elements must be even}
-test http-4.1 {http::Event} -body {
+test http-4.1.$ThreadLevel {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))}
+ expr {($data(totalsize) == $meta(content-length))}
} -cleanup {
http::cleanup $token
} -result 1
-test http-4.2 {http::Event} -body {
+test http-4.2.$ThreadLevel {http::Event} -body {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
+ string compare $data(type) [string trim $meta(content-type)]
} -cleanup {
http::cleanup $token
} -result 0
-test http-4.3 {http::Event} -body {
+test http-4.3.$ThreadLevel {http::Event} -body {
set token [http::geturl $url]
http::code $token
} -cleanup {
http::cleanup $token
} -result {HTTP/1.0 200 Data follows}
-test http-4.4 {http::Event} -setup {
+test http-4.4.$ThreadLevel {http::Event} -setup {
set testfile [makeFile "" testfile]
} -body {
set out [open $testfile w]
@@ -518,7 +525,7 @@ test http-4.4 {http::Event} -setup {
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {http::Event} -setup {
+test http-4.5.$ThreadLevel {http::Event} -setup {
set testfile [makeFile "" testfile]
} -body {
set out [open $testfile w]
@@ -531,7 +538,7 @@ test http-4.5 {http::Event} -setup {
removeFile $testfile
http::cleanup $token
} -result 1
-test http-4.6 {http::Event} -setup {
+test http-4.6.$ThreadLevel {http::Event} -setup {
set testfile [makeFile "" testfile]
} -body {
set out [open $testfile w]
@@ -553,64 +560,68 @@ proc myProgress {token total current} {
}
set progress [list $total $current]
}
-test http-4.6.1 {http::Event} knownBug {
+test http-4.6.1.$ThreadLevel {http::Event} knownBug {
set token [http::geturl $url -blocksize 50 -progress myProgress]
return $progress
} {111 111}
-test http-4.7 {http::Event} -body {
+test http-4.7.$ThreadLevel {http::Event} -body {
set token [http::geturl $url -keepalive 0 -progress myProgress]
return $progress
} -cleanup {
http::cleanup $token
} -result {111 111}
-test http-4.8 {http::Event} -body {
+test http-4.8.$ThreadLevel {http::Event} -body {
set token [http::geturl $url]
http::status $token
} -cleanup {
http::cleanup $token
} -result {ok}
-test http-4.9 {http::Event} -body {
+test http-4.9.$ThreadLevel {http::Event} -body {
set token [http::geturl $url -progress myProgress]
http::code $token
} -cleanup {
http::cleanup $token
} -result {HTTP/1.0 200 Data follows}
-test http-4.10 {http::Event} -body {
+test http-4.10.$ThreadLevel {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 {
+test http-4.11.$ThreadLevel {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 {
+test http-4.12.$ThreadLevel {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 {
+test http-4.13.$ThreadLevel {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 {
+test http-4.14.$ThreadLevel {http::Event} -body {
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#]
if {$token eq ""} {
error "bogus return from http::geturl"
@@ -619,19 +630,24 @@ test http-4.14 {http::Event} -body {
lindex [http::error $token] 0
} -cleanup {
catch {http::cleanup $token}
-} -result {connect failed connection refused}
+} -result {connect failed: connection refused}
+
# Bogus host
-test http-4.15 {http::Event} -body {
+test http-4.15.$ThreadLevel {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 \#]
+ # With http::config -threadlevel 1 or 2, the script enters the event loop
+ # during the DNS lookup, and has the opportunity to time out.
+ # Increase -timeout from 3000 to 10000 to prevent this.
+ set token [http::geturl //not_a_host.tcl.tk -timeout 10000 -command \#]
http::wait $token
- http::status $token
+ set result "[http::status $token] -- [lindex [http::error $token] 0]"
# error codes vary among platforms.
} -cleanup {
catch {http::cleanup $token}
-} -returnCodes 1 -match glob -result "couldn't open socket*"
-test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
+} -match glob -result "error -- couldn't open socket*"
+
+test http-4.16.$ThreadLevel {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
proc list-difference {l1 l2} {
lmap item $l2 {if {$item in $l1} continue; set item}
}
@@ -646,25 +662,25 @@ test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
rename list-difference {}
} -result {}
-test http-5.1 {http::formatQuery} {
+test http-5.1.$ThreadLevel {http::formatQuery} {
http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value%20two}
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
-test http-5.3 {http::formatQuery} {
+test http-5.3.$ThreadLevel {http::formatQuery} {
http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0D%0Aline2%0D%0Aline3}
-test http-5.4 {http::formatQuery} {
- http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
+test http-5.4.$ThreadLevel {http::formatQuery} {
+ http::formatQuery name1 ~bwelch name2 ¡¢¢
} {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2}
-test http-5.5 {http::formatQuery} {
+test http-5.5.$ThreadLevel {http::formatQuery} {
set enc [http::config -urlencoding]
http::config -urlencoding iso8859-1
- set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
+ set res [http::formatQuery name1 ~bwelch name2 ¡¢¢]
http::config -urlencoding $enc
set res
} {name1=~bwelch&name2=%A1%A2%A2}
-test http-6.1 {http::ProxyRequired} -body {
+test http-6.1.$ThreadLevel {http::ProxyRequired} -body {
http::config -proxyhost ${::HOST} -proxyport $port
set token [http::geturl $url]
http::wait $token
@@ -678,41 +694,487 @@ test http-6.1 {http::ProxyRequired} -body {
<h2>GET http:$url</h2>
</body></html>"
-test http-7.1 {http::mapReply} {
+test http-7.1.$ThreadLevel {http::mapReply} {
http::mapReply "abc\$\[\]\"\\()\}\{"
} {abc%24%5B%5D%22%5C%28%29%7D%7B}
-test http-7.2 {http::mapReply} {
+test http-7.2.$ThreadLevel {http::mapReply} {
# RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
# so make sure this gets converted to utf-8 then urlencoded.
- http::mapReply "\u2208"
+ http::mapReply "∈"
} {%E2%88%88}
-test http-7.3 {http::formatQuery} -setup {
+test http-7.3.$ThreadLevel {http::formatQuery} -setup {
set enc [http::config -urlencoding]
} -returnCodes error -body {
- # this would be reverting to http <=2.4 behavior
+ # -urlencoding "" no longer supported. Use "iso8859-1".
http::config -urlencoding ""
- http::mapReply "\u2208"
+ http::mapReply "∈"
} -cleanup {
http::config -urlencoding $enc
-} -result "can't read \"formMap(\u2208)\": no such element in array"
-test http-7.4 {http::formatQuery} -setup {
+} -result {unknown encoding ""}
+test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup {
set enc [http::config -urlencoding]
} -body {
# this would be reverting to http <=2.4 behavior w/o errors
- # (unknown chars become '?')
+ # with Tcl 8.x (unknown chars become '?'), generating a
+ # proper exception with Tcl 9.0
http::config -urlencoding "iso8859-1"
- http::mapReply "\u2208"
+ http::mapReply "∈"
} -cleanup {
http::config -urlencoding $enc
} -result {%3F}
+package require tcl::idna 1.0
+
+test http-idna-1.1.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna
+} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
+test http-idna-1.2.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna ?
+} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
+test http-idna-1.3.$ThreadLevel {IDNA package: basics} -body {
+ ::tcl::idna version
+} -result 1.0.1
+test http-idna-1.4.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna version what
+} -result {wrong # args: should be "::tcl::idna version"}
+test http-idna-1.5.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny
+} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
+test http-idna-1.6.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny ?
+} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
+test http-idna-1.7.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.8.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode a b c
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.9.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.10.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode a b c
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.11.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna decode
+} -result {wrong # args: should be "::tcl::idna decode hostname"}
+test http-idna-1.12.$ThreadLevel {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna encode
+} -result {wrong # args: should be "::tcl::idna encode hostname"}
+
+test http-idna-2.1.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode abc
+} abc-
+test http-idna-2.2.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode a€b€c
+} abc-k50ab
+test http-idna-2.3.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode ABC
+} ABC-
+test http-idna-2.4.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode A€B€C
+} ABC-k50ab
+test http-idna-2.5.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 0
+} abc-
+test http-idna-2.6.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode A€B€C 0
+} abc-k50ab
+test http-idna-2.7.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 1
+} ABC-
+test http-idna-2.8.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode A€B€C 1
+} ABC-k50ab
+test http-idna-2.9.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode abc 0
+} abc-
+test http-idna-2.10.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode a€b€c 0
+} abc-k50ab
+test http-idna-2.11.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode abc 1
+} ABC-
+test http-idna-2.12.$ThreadLevel {puny encode: functional test} {
+ ::tcl::idna puny encode a€b€c 1
+} ABC-k50ab
+test http-idna-2.13.$ThreadLevel {puny encode: edge cases} {
+ ::tcl::idna puny encode ""
+} ""
+test http-idna-2.14-A.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+ }]] ""]
+} egbpdaj6bu4bxfgehfvwxn
+test http-idna-2.14-B.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587
+ }]] ""]
+} ihqwcrb4cv8a8dqg056pqjye
+test http-idna-2.14-C.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587
+ }]] ""]
+} ihqwctvzc91f659drss3x8bo0yb
+test http-idna-2.14-D.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+ }]] ""]
+} Proprostnemluvesky-uyb24dma41a
+test http-idna-2.14-E.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+ }]] ""]
+} 4dbcagdahymbxekheh6e0a7fei0b
+test http-idna-2.14-F.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+ }]] ""]
+} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd
+test http-idna-2.14-G.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+ }]] ""]
+} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa
+test http-idna-2.14-H.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+ }]] ""]
+} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c
+test http-idna-2.14-I.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+ }]] ""]
+} b1abfaaepdrnnbgefbadotcwatmq2g4l
+test http-idna-2.14-J.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+ }]] ""]
+} PorqunopuedensimplementehablarenEspaol-fmd56a
+test http-idna-2.14-K.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+ }]] ""]
+} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g
+test http-idna-2.14-L.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F
+ }]] ""]
+} 3B-ww4c5e180e575a65lsy2b
+test http-idna-2.14-M.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+ }]] ""]
+} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n
+test http-idna-2.14-N.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+ }]] ""]
+} Hello-Another-Way--fc4qua05auwb3674vfr0b
+test http-idna-2.14-O.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032
+ }]] ""]
+} 2-u9tlzr9756bt3uc0v
+test http-idna-2.14-P.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+ }]] ""]
+} MajiKoi5-783gue6qz075azm5e
+test http-idna-2.14-Q.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0
+ }]] ""]
+} de-jg4avhby1noc0d
+test http-idna-2.14-R.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067
+ }]] ""]
+} d9juau41awczczp
+test http-idna-2.14-S.$ThreadLevel {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode {-> $1.00 <-}
+} {-> $1.00 <--}
+
+test http-idna-3.1.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc-
+} abc
+test http-idna-3.2.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab
+} a€b€c
+test http-idna-3.3.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-
+} ABC
+test http-idna-3.4.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-k50ab
+} A€B€C
+test http-idna-3.5.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB
+} A€B€C
+test http-idna-3.6.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc-K50AB
+} a€b€c
+test http-idna-3.7.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 0
+} abc
+test http-idna-3.8.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 0
+} a€b€c
+test http-idna-3.9.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 1
+} ABC
+test http-idna-3.10.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 1
+} A€B€C
+test http-idna-3.11.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 0
+} abc
+test http-idna-3.12.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 0
+} a€b€c
+test http-idna-3.13.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 1
+} ABC
+test http-idna-3.14.$ThreadLevel {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 1
+} A€B€C
+test http-idna-3.15.$ThreadLevel {puny decode: edge cases and errors} {
+ # Is this case actually correct?
+ binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]]
+} c282c281c280
+test http-idna-3.16.$ThreadLevel {puny decode: edge cases and errors} -returnCodes error -body {
+ ::tcl::idna puny decode abc!
+} -result {bad decode character "!"}
+test http-idna-3.17.$ThreadLevel {puny decode: edge cases and errors} {
+ catch {::tcl::idna puny decode abc!} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-3.18.$ThreadLevel {puny decode: edge cases and errors} {
+ ::tcl::idna puny decode ""
+} {}
+# A helper so we don't get lots of crap in failures
+proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}}
+test http-idna-3.19-A.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn]
+} [list {*}{
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+}]
+test http-idna-3.19-B.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye]
+} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587}
+test http-idna-3.19-C.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb]
+} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587}
+test http-idna-3.19-D.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a]
+} [list {*}{
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+}]
+test http-idna-3.19-E.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b]
+} [list {*}{
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+}]
+test http-idna-3.19-F.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd]
+} [list {*}{
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+}]
+test http-idna-3.19-G.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa]
+} [list {*}{
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+}]
+test http-idna-3.19-H.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c]
+} [list {*}{
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]
+test http-idna-3.19-I.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l]
+} [list {*}{
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+}]
+test http-idna-3.19-J.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ PorqunopuedensimplementehablarenEspaol-fmd56a]
+} [list {*}{
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+}]
+test http-idna-3.19-K.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g]
+} [list {*}{
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+}]
+test http-idna-3.19-L.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b]
+} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F}
+test http-idna-3.19-M.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n]
+} [list {*}{
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+}]
+test http-idna-3.19-N.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b]
+} [list {*}{
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+}]
+test http-idna-3.19-O.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v]
+} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032}
+test http-idna-3.19-P.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e]
+} [list {*}{
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+}]
+test http-idna-3.19-Q.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode de-jg4avhby1noc0d]
+} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0}
+test http-idna-3.19-R.$ThreadLevel {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode d9juau41awczczp]
+} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067}
+test http-idna-3.19-S.$ThreadLevel {puny decode: examples from RFC 3492} {
+ ::tcl::idna puny decode {-> $1.00 <--}
+} {-> $1.00 <-}
+rename hexify ""
+
+test http-idna-4.1.$ThreadLevel {IDNA encoding} {
+ ::tcl::idna encode abc.def
+} abc.def
+test http-idna-4.2.$ThreadLevel {IDNA encoding} {
+ ::tcl::idna encode a€b€c.def
+} xn--abc-k50ab.def
+test http-idna-4.3.$ThreadLevel {IDNA encoding} {
+ ::tcl::idna encode def.a€b€c
+} def.xn--abc-k50ab
+test http-idna-4.4.$ThreadLevel {IDNA encoding} {
+ ::tcl::idna encode ABC.DEF
+} ABC.DEF
+test http-idna-4.5.$ThreadLevel {IDNA encoding} {
+ ::tcl::idna encode A€B€C.def
+} xn--ABC-k50ab.def
+test http-idna-4.6.$ThreadLevel {IDNA encoding: invalid edge case} {
+ # Should this be an error?
+ ::tcl::idna encode abc..def
+} abc..def
+test http-idna-4.7.$ThreadLevel {IDNA encoding: invalid char} -returnCodes error -body {
+ ::tcl::idna encode abc.$.def
+} -result {bad character "$" in DNS name}
+test http-idna-4.7.1.$ThreadLevel {IDNA encoding: invalid char} {
+ catch {::tcl::idna encode abc.$.def} -> opt
+ dict get $opt -errorcode
+} {IDNA INVALID_NAME_CHARACTER {$}}
+test http-idna-4.8.$ThreadLevel {IDNA encoding: empty} {
+ ::tcl::idna encode ""
+} {}
+set overlong www.[join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]] ""].com
+test http-idna-4.9.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} -body {
+ ::tcl::idna encode $overlong
+} -returnCodes error -result "hostname part too long"
+test http-idna-4.9.1.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} {
+ catch {::tcl::idna encode $overlong} -> opt
+ dict get $opt -errorcode
+} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c}
+unset overlong
+test http-idna-4.10.$ThreadLevel {IDNA encoding: edge cases} {
+ ::tcl::idna encode passé.example.com
+} xn--pass-epa.example.com
+
+test http-idna-5.1.$ThreadLevel {IDNA decoding} {
+ ::tcl::idna decode abc.def
+} abc.def
+test http-idna-5.2.$ThreadLevel {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.def
+} abc.def
+test http-idna-5.3.$ThreadLevel {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.xn--def-
+} abc.def
+test http-idna-5.4.$ThreadLevel {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode XN--abc-.XN--def-
+} abc.def
+test http-idna-5.5.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--$$$.example.com
+} -result {bad decode character "$"}
+test http-idna-5.5.1.$ThreadLevel {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--$$$.example.com} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-5.6.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
+} -result {exceeded input data}
+test http-idna-5.6.1.$ThreadLevel {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT LENGTH}
+
# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
-if {[info exists httpthread]} {
- thread::release $httpthread
+if {[llength $threadStack]} {
+ eval [lpop threadStack]
} else {
close $listen
}
diff --git a/tests/http11.test b/tests/http11.test
index f243e56..55e7d39 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -2,7 +2,7 @@
#
# Test HTTP/1.1 features.
#
-# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-package require http 2.9
+package require http 2.10
# start the server
variable httpd_output
@@ -51,15 +51,11 @@ proc halt_httpd {} {
}
proc meta {tok {key ""}} {
- set meta [http::meta $tok]
- if {$key ne ""} {
- if {[dict exists $meta $key]} {
- return [dict get $meta $key]
- } else {
- return ""
- }
+ if {$key eq ""} {
+ return [http::meta $tok]
+ } else {
+ return [http::metaValue $tok $key]
}
- return $meta
}
proc state {tok {key ""}} {
@@ -87,10 +83,32 @@ proc check_crc {tok args} {
}
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
+
+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>} 5000]\n</body></html>" largedoc.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 {
+test http11-1.0.$ThreadLevel "normal request for document " -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
@@ -101,20 +119,21 @@ test http11-1.0 "normal request for document " -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close}
-test http11-1.1 "normal,gzip,non-chunked" -setup {
+test http11-1.1.$ThreadLevel "normal,gzip,non-chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
-timeout 10000 -headers {accept-encoding gzip}]
http::wait $tok
list [http::status $tok] [http::code $tok] [check_crc $tok] \
- [meta $tok content-encoding] [meta $tok transfer-encoding]
+ [meta $tok content-encoding] [meta $tok transfer-encoding] \
+ [http::meta $tok content-encoding] [http::meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok gzip {}}
+} -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}}
-test http11-1.2 "normal,deflated,non-chunked" -setup {
+test http11-1.2.$ThreadLevel "normal,deflated,non-chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -127,7 +146,22 @@ test http11-1.2 "normal,deflated,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
-test http11-1.3 "normal,compressed,non-chunked" -setup {
+test http11-1.2.1.$ThreadLevel "normal,deflated,non-chunked,msdeflate" -setup {
+ variable httpd [create_httpd]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+ -timeout 10000 -headers {accept-encoding deflate}]
+ http::wait $tok
+ list [http::status $tok] [http::code $tok] [check_crc $tok] \
+ [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
+
+test http11-1.3.$ThreadLevel "normal,compressed,non-chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -140,7 +174,7 @@ test http11-1.3 "normal,compressed,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok compress {}}
-test http11-1.4 "normal,identity,non-chunked" -setup {
+test http11-1.4.$ThreadLevel "normal,identity,non-chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -153,7 +187,7 @@ test http11-1.4 "normal,identity,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {}}
-test http11-1.5 "normal request for document, unsupported coding" -setup {
+test http11-1.5.$ThreadLevel "normal request for document, unsupported coding" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -166,20 +200,21 @@ test http11-1.5 "normal request for document, unsupported coding" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {}}
-test http11-1.6 "normal, specify 1.1 " -setup {
+test http11-1.6.$ThreadLevel "normal, specify 1.1 " -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
-protocol 1.1 -timeout 10000]
http::wait $tok
list [http::status $tok] [http::code $tok] [check_crc $tok] \
- [meta $tok connection] [meta $tok transfer-encoding]
+ [meta $tok connection] [meta $tok transfer-encoding] \
+ [http::meta $tok connection] [http::meta $tok transfer-encoding]
} -cleanup {
http::cleanup $tok
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok close chunked}
+} -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}}
-test http11-1.7 "normal, 1.1 and keepalive " -setup {
+test http11-1.7.$ThreadLevel "normal, 1.1 and keepalive " -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -192,7 +227,7 @@ test http11-1.7 "normal, 1.1 and keepalive " -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
-test http11-1.8 "normal, 1.1 and keepalive, server close" -setup {
+test http11-1.8.$ThreadLevel "normal, 1.1 and keepalive, server close" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
@@ -205,7 +240,7 @@ test http11-1.8 "normal, 1.1 and keepalive, server close" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {}}
-test http11-1.9 "normal,gzip,chunked" -setup {
+test http11-1.9.$ThreadLevel "normal,gzip,chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -218,7 +253,7 @@ test http11-1.9 "normal,gzip,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok gzip chunked}
-test http11-1.10 "normal,deflate,chunked" -setup {
+test http11-1.10.$ThreadLevel "normal,deflate,chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -231,7 +266,22 @@ test http11-1.10 "normal,deflate,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
-test http11-1.11 "normal,compress,chunked" -setup {
+test http11-1.10.1.$ThreadLevel "normal,deflate,chunked,msdeflate" -setup {
+ variable httpd [create_httpd]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 10000 -headers {accept-encoding deflate}]
+ http::wait $tok
+ list [http::status $tok] [http::code $tok] [check_crc $tok] \
+ [meta $tok content-encoding] [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
+
+test http11-1.11.$ThreadLevel "normal,compress,chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -244,7 +294,7 @@ test http11-1.11 "normal,compress,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok compress chunked}
-test http11-1.12 "normal,identity,chunked" -setup {
+test http11-1.12.$ThreadLevel "normal,identity,chunked" -setup {
variable httpd [create_httpd]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
@@ -257,7 +307,7 @@ test http11-1.12 "normal,identity,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
-test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup {
+test http11-1.13.$ThreadLevel "normal, 1.1 and keepalive as server default, no zip" -setup {
variable httpd [create_httpd]
set zipTmp [http::config -zip]
http::config -zip 0
@@ -296,7 +346,7 @@ proc progressPause {var token total current} {
return
}
-test http11-2.0 "-channel" -setup {
+test http11-2.0.$ThreadLevel "-channel" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -314,7 +364,7 @@ test http11-2.0 "-channel" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close chunked}
-test http11-2.1 "-channel, encoding gzip" -setup {
+test http11-2.1.$ThreadLevel "-channel, encoding gzip" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -323,17 +373,42 @@ test http11-2.1 "-channel, encoding gzip" -setup {
http::wait $tok
seek $chan 0
set data [read $chan]
+ set diff [expr {[file size testdoc.html] - [file size testfile.tmp]}]
list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
[meta $tok connection] [meta $tok content-encoding]\
- [meta $tok transfer-encoding]
+ [meta $tok transfer-encoding] -- $diff bytes lost
} -cleanup {
http::cleanup $tok
close $chan
removeFile testfile.tmp
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked}
+} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost}
-test http11-2.2 "-channel, encoding deflate" -setup {
+# Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)"
+# This test failed before the bugfix.
+# The pass/fail depended on file size.
+test http11-2.1.1.$ThreadLevel "-channel, encoding gzip" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+ set fileName largedoc.html
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/$fileName \
+ -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ set diff [expr {[file size $fileName] - [file size testfile.tmp]}]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding] -- $diff bytes lost
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost}
+
+test http11-2.2.$ThreadLevel "-channel, encoding deflate" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -352,7 +427,28 @@ test http11-2.2 "-channel, encoding deflate" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
-test http11-2.3 "-channel,encoding compress" -setup {
+test http11-2.2.1.$ThreadLevel "-channel, encoding deflate,msdeflate" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
+
+test http11-2.3.$ThreadLevel "-channel,encoding compress" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -372,7 +468,7 @@ test http11-2.3 "-channel,encoding compress" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close compress chunked}
-test http11-2.4 "-channel,encoding identity" -setup {
+test http11-2.4.$ThreadLevel "-channel,encoding identity" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -392,7 +488,7 @@ test http11-2.4 "-channel,encoding identity" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
-test http11-2.4.1 "-channel,encoding identity with -progress" -setup {
+test http11-2.4.1.$ThreadLevel "-channel,encoding identity with -progress" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
set logdata ""
@@ -418,7 +514,7 @@ test http11-2.4.1 "-channel,encoding identity with -progress" -setup {
unset -nocomplain logdata data
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0}
-test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup {
+test http11-2.4.2.$ThreadLevel "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
set logdata ""
@@ -444,7 +540,7 @@ test http11-2.4.2 "-channel,encoding identity with -progress progressPause enter
unset -nocomplain logdata data ::WaitHere
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0}
-test http11-2.5 "-channel,encoding unsupported" -setup {
+test http11-2.5.$ThreadLevel "-channel,encoding unsupported" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -464,7 +560,7 @@ test http11-2.5 "-channel,encoding unsupported" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
-test http11-2.6 "-channel,encoding gzip,non-chunked" -setup {
+test http11-2.6.$ThreadLevel "-channel,encoding gzip,non-chunked" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -484,7 +580,7 @@ test http11-2.6 "-channel,encoding gzip,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0}
-test http11-2.7 "-channel,encoding deflate,non-chunked" -setup {
+test http11-2.7.$ThreadLevel "-channel,encoding deflate,non-chunked" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -504,7 +600,32 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
-test http11-2.8 "-channel,encoding compress,non-chunked" -setup {
+test http11-2.7.1.$ThreadLevel "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup {
+ # Test fails because a -channel can only try one un-deflate algorithm, and the
+ # compliant "decompress" is tried, not the non-compliant "inflate" of
+ # the MS browser implementation.
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \
+ -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
+
+test http11-2.8.$ThreadLevel "-channel,encoding compress,non-chunked" -constraints badCompress -setup {
+ # The Tcl "compress" algorithm appears to be incorrect and has been removed.
+ # Bug [a13b9d0ce1].
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -524,7 +645,7 @@ test http11-2.8 "-channel,encoding compress,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close compress {} 0}
-test http11-2.9 "-channel,encoding identity,non-chunked" -setup {
+test http11-2.9.$ThreadLevel "-channel,encoding identity,non-chunked" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -544,7 +665,7 @@ test http11-2.9 "-channel,encoding identity,non-chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}
-test http11-2.10 "-channel,deflate,keepalive" -setup {
+test http11-2.10.$ThreadLevel "-channel,deflate,keepalive" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -565,7 +686,28 @@ test http11-2.10 "-channel,deflate,keepalive" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
-test http11-2.11 "-channel,identity,keepalive" -setup {
+test http11-2.10.1.$ThreadLevel "-channel,deflate,keepalive,msdeflate" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \
+ -timeout 5000 -channel $chan -keepalive 1 \
+ -headers {accept-encoding deflate}]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
+
+test http11-2.11.$ThreadLevel "-channel,identity,keepalive" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -585,7 +727,7 @@ test http11-2.11 "-channel,identity,keepalive" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
-test http11-2.12 "-channel,negotiate,keepalive" -setup {
+test http11-2.12.$ThreadLevel "-channel,negotiate,keepalive" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
@@ -603,7 +745,7 @@ test http11-2.12 "-channel,negotiate,keepalive" -setup {
close $chan
removeFile testfile.tmp
halt_httpd
-} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
+} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate 0}
# -------------------------------------------------------------------------
@@ -633,7 +775,7 @@ proc handlerPause {var sock token} {
return [string length $chunk]
}
-test http11-3.0 "-handler,close,identity" -setup {
+test http11-3.0.$ThreadLevel "-handler,close,identity" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -650,7 +792,7 @@ test http11-3.0 "-handler,close,identity" -setup {
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
-test http11-3.1 "-handler,protocol1.0" -setup {
+test http11-3.1.$ThreadLevel "-handler,protocol1.0" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -668,7 +810,7 @@ test http11-3.1 "-handler,protocol1.0" -setup {
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
-test http11-3.2 "-handler,close,chunked" -setup {
+test http11-3.2.$ThreadLevel "-handler,close,chunked" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -686,7 +828,7 @@ test http11-3.2 "-handler,close,chunked" -setup {
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
-test http11-3.3 "-handler,keepalive,chunked" -setup {
+test http11-3.3.$ThreadLevel "-handler,keepalive,chunked" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -714,7 +856,7 @@ test http11-3.3 "-handler,keepalive,chunked" -setup {
# "Connection: keep-alive", i.e. the server will keep the connection
# open. In HTTP/1.0 this is not the case, and this is a test that
# the Tcl client assumes "Connection: close" by default in HTTP/1.0.
-test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup {
+test http11-3.4.$ThreadLevel "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -732,7 +874,7 @@ test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connecti
} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0}
# It is not forbidden for a handler to enter the event loop.
-test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup {
+test http11-3.5.$ThreadLevel "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup {
variable httpd [create_httpd]
set testdata ""
} -body {
@@ -749,7 +891,7 @@ test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters e
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
-test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup {
+test http11-3.6.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress" -setup {
variable httpd [create_httpd]
set testdata ""
set logdata ""
@@ -770,7 +912,7 @@ test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setu
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0}
-test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup {
+test http11-3.7.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup {
variable httpd [create_httpd]
set testdata ""
set logdata ""
@@ -791,7 +933,7 @@ test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progre
halt_httpd
} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0}
-test http11-3.8 "close,identity no -handler but with -progress" -setup {
+test http11-3.8.$ThreadLevel "close,identity no -handler but with -progress" -setup {
variable httpd [create_httpd]
set logdata ""
} -body {
@@ -812,7 +954,7 @@ test http11-3.8 "close,identity no -handler but with -progress" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0}
-test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup {
+test http11-3.9.$ThreadLevel "close,identity no -handler but with -progress progressPause enters event loop" -setup {
variable httpd [create_httpd]
set logdata ""
} -body {
@@ -833,7 +975,7 @@ test http11-3.9 "close,identity no -handler but with -progress progressPause ent
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0}
-test http11-4.0 "normal post request" -setup {
+test http11-4.0.$ThreadLevel "normal post request" -setup {
variable httpd [create_httpd]
} -body {
set query [http::formatQuery q 1 z 2]
@@ -849,7 +991,7 @@ test http11-4.0 "normal post request" -setup {
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7}
-test http11-4.1 "normal post request, check query length" -setup {
+test http11-4.1.$ThreadLevel "normal post request, check query length" -setup {
variable httpd [create_httpd]
} -body {
set query [http::formatQuery q 1 z 2]
@@ -866,7 +1008,7 @@ test http11-4.1 "normal post request, check query length" -setup {
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7}
-test http11-4.2 "normal post request, check long query length" -setup {
+test http11-4.2.$ThreadLevel "normal post request, check long query length" -setup {
variable httpd [create_httpd]
} -body {
set query [string repeat a 24576]
@@ -883,7 +1025,7 @@ test http11-4.2 "normal post request, check long query length" -setup {
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576}
-test http11-4.3 "normal post request, check channel query length" -setup {
+test http11-4.3.$ThreadLevel "normal post request, check channel query length" -setup {
variable httpd [create_httpd]
set chan [open [makeFile {} testfile.tmp] wb+]
puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192]
@@ -918,6 +1060,7 @@ foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
if {[llength [info proc $p]]} {rename $p {}}
}
removeFile testdoc.html
+removeFile largedoc.html
unset -nocomplain httpd_port httpd p
::tcltest::cleanupTests
diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test
index 4306149..491aae0 100644
--- a/tests/httpPipeline.test
+++ b/tests/httpPipeline.test
@@ -3,7 +3,7 @@
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
-# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -13,7 +13,31 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-package require http 2.9
+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]
@@ -815,7 +839,7 @@ for {set header 1} {$header <= 4} {incr header} {
# Here's the test:
- test httpPipeline-${header}.${footer}${label}-${tag} $name \
+ test httpPipeline-${header}.${footer}${label}-${tag}-$ThreadLevel $name \
-constraints $cons \
-setup [string map [list TE $te] {
# Restore default values for tests:
diff --git a/tests/httpProxy.test b/tests/httpProxy.test
new file mode 100644
index 0000000..d8bd6b7
--- /dev/null
+++ b/tests/httpProxy.test
@@ -0,0 +1,1146 @@
+# Commands covered: http::geturl when using a proxy server.
+#
+# This file contains a collection of tests for the http script library.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Ajuba Solutions.
+# Copyright © 2022 Keith Nash.
+#
+# 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::*
+}
+
+package require http 2.10
+
+proc bgerror {args} {
+ global errorInfo
+ puts stderr "httpProxy.test bgerror"
+ puts stderr [join $args]
+ puts stderr $errorInfo
+}
+
+proc stopMe {token} {
+ set ${token}(z) done
+}
+
+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
+
+
+#testConstraint needsSquid 1
+#testConstraint needsTls 1
+
+if {[testConstraint needsTls]} {
+ package require tls
+ http::register https 443 [list ::tls::socket -ssl2 0 -ssl3 0 \
+ -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 -autoservername 1]
+}
+
+# Testing with Squid
+# - Example Squid configuration for Enterprise Linux 8 (Red Hat, Oracle, Rocky,
+# Alma, ...) is in file tests/httpProxySquidConfigForEL8.tar.gz.
+# - Two instances of Squid are launched, one that needs authentication and one
+# that does not.
+# - Each instance of Squid listens on IPv4 and IPv6, on different ports.
+
+# Instance of Squid that does not need authentication.
+set n4host 127.0.0.1
+set n6host ::1
+set n4port 3128
+set n6port 3130
+
+# Instance of Squid that needs authentication.
+set a4host 127.0.0.1
+set a6host ::1
+set a4port 3129
+set a6port 3131
+
+# concat Basic [base64::encode alice:alicia]
+set aliceCreds {Basic YWxpY2U6YWxpY2lh}
+
+# concat Basic [base64::encode intruder:intruder]
+set badCreds {Basic aW50cnVkZXI6aW50cnVkZXI=}
+
+test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 noauth} -constraints {needsSquid} -setup {
+} -body {
+ set token [http::geturl http://$n4host:$n4port/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed]"
+} -result {complete ok 400 -- none} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 noauth} -constraints {needsSquid} -setup {
+} -body {
+ set token [http::geturl http://\[$n6host\]:$n6port/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed]"
+} -result {complete ok 400 -- none} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 auth} -constraints {needsSquid} -setup {
+} -body {
+ set token [http::geturl http://$a4host:$a4port/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed]"
+} -result {complete ok 400 -- none} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 auth} -constraints {needsSquid} -setup {
+} -body {
+ set token [http::geturl http://\[$a6host\]:$a6port/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed]"
+} -result {complete ok 400 -- none} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid} -setup {
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+}
+
+test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup {
+ http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- HttpProxy -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+ http::config -proxyhost {} -proxyport {} -proxynot {}
+}
+
+test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- SecureProxy -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+ http::config -proxyhost {} -proxyport {} -proxynot {}
+}
+
+test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup {
+ http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- HttpProxy -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+ http::config -proxyhost {} -proxyport {} -proxynot {}
+}
+
+test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- SecureProxy -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res
+ http::config -proxyhost {} -proxyport {} -proxynot {}
+}
+
+test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.7.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.7x.$ThreadLevel {http with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+
+ http::config -proxyauth $aliceCreds
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.8.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.8x.$ThreadLevel {https with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+
+ http::config -proxyauth $aliceCreds
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.9.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.9p.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+after idle {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.9x.$ThreadLevel {http with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+
+ http::config -proxyauth $aliceCreds
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.10.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.10p.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+after idle {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token0; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-3.10x.$ThreadLevel {https with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+
+ http::config -proxyauth $aliceCreds
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.7.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.8.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {}
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.9.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.9p.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+after idle {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token0; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.10.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-4.10p.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {}
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+
+after idle {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 200 -- none 0 0 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl http://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup {
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds
+} -body {
+ set token [http::geturl https://www.google.com/]
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]"
+} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup {
+ http::cleanup $token
+ unset -nocomplain token ri res pos1 pos2
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.7.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.7p.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ # Use the same caution as for the corresponding https test.
+after idle {
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.8.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.8p.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds
+} -body {
+ set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}]
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+after idle {
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+}
+ vwait ${token0}(z)
+ after cancel $can0
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can0 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.9.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds
+ set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # Use the same caution as for the corresponding https test.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+test httpProxy-5.10.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup {
+ array unset ::http::socketMapping
+ http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds
+ set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000]
+} -body {
+ # If a bug passes the socket of a failed CONNECT to the main request, an infinite
+ # wait can occur despite -timeout. Fix this with http::reset; to do this the call
+ # to http::geturl must be async so we have $token for use as argument of reset.
+ set can [after 6000 {http::reset $token; set ${token}(z) timeout}]
+ set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe]
+ vwait ${token}(z)
+ after cancel $can
+
+ set ri [http::responseInfo $token]
+ set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization]
+ set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds]
+ set same [string equal [set ${token0}(sock)] [set ${token}(sock)]]
+ set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\
+ [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\
+ [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same"
+} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup {
+ http::cleanup $token0
+ http::cleanup $token
+ unset -nocomplain token0 token ri res pos1 pos2 can same
+ array unset ::http::socketMapping
+ http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {}
+}
+
+# cleanup
+unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds
+
+rename bgerror {}
+rename stopMe {}
+
+::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
+
diff --git a/tests/httpProxySquidConfigForEL8.tar.gz b/tests/httpProxySquidConfigForEL8.tar.gz
new file mode 100644
index 0000000..a94dbdb
--- /dev/null
+++ b/tests/httpProxySquidConfigForEL8.tar.gz
Binary files differ
diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl
index 6a2226e..1dc6772 100644
--- a/tests/httpTest.tcl
+++ b/tests/httpTest.tcl
@@ -3,7 +3,7 @@
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
-# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -68,7 +68,11 @@ proc http::Log {args} {
}
return
}
-
+# The http::Log routine above needs the variable ::httpTest::testOptions
+# Set up to destroy it when that variable goes away.
+trace add variable ::httpTest::testOptions unset {apply {args {
+ proc ::http::Log args {}
+}}}
# Called by http::Log (the "testing" version) to record logs for later analysis.
diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl
index a40449a..5437bf6 100644
--- a/tests/httpTestScript.tcl
+++ b/tests/httpTestScript.tcl
@@ -3,7 +3,7 @@
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
-# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
+# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/httpcookie.test b/tests/httpcookie.test
new file mode 100644
index 0000000..329330d
--- /dev/null
+++ b/tests/httpcookie.test
@@ -0,0 +1,875 @@
+# Commands covered: http::cookiejar
+#
+# This file contains a collection of tests for the cookiejar package.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright © 2014 Donal K. Fellows.
+#
+# 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
+
+testConstraint notMacCI [expr {![info exists ::env(MAC_CI)]}]
+testConstraint sqlite3 [expr {[testConstraint notMacCI] && ![catch {
+ package require sqlite3
+}]}]
+testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
+ package require cookiejar
+}]}]
+
+set COOKIEJAR_VERSION 0.2.0
+test http-cookiejar-1.1 "cookie storage: packaging" {cookiejar} {
+ package require cookiejar
+} $COOKIEJAR_VERSION
+test http-cookiejar-1.2 "cookie storage: packaging" {cookiejar} {
+ package require cookiejar
+ package require cookiejar
+} $COOKIEJAR_VERSION
+
+test http-cookiejar-2.1 "cookie storage: basics" -constraints {
+ cookiejar
+} -returnCodes error -body {
+ http::cookiejar
+} -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
+test http-cookiejar-2.2 "cookie storage: basics" -constraints {
+ cookiejar
+} -returnCodes error -body {
+ http::cookiejar ?
+} -result {unknown method "?": must be configure, create, destroy or new}
+test http-cookiejar-2.3 "cookie storage: basics" -constraints {
+ cookiejar
+} -body {
+ http::cookiejar configure
+} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
+test http-cookiejar-2.4 "cookie storage: basics" -constraints {
+ cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure a b c d e
+} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
+test http-cookiejar-2.5 "cookie storage: basics" -constraints {
+ cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure a
+} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.6 "cookie storage: basics" -constraints {
+ cookiejar
+} -returnCodes error -body {
+ http::cookiejar configure -d
+} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.7 "cookie storage: basics" -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints {cookiejar} -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel debug] \
+ [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel error] \
+ [http::cookiejar configure -loglevel]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug debug error error}
+test http-cookiejar-2.8 "cookie storage: basics" -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints {cookiejar} -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel d] \
+ [http::cookiejar configure -loglevel i] \
+ [http::cookiejar configure -loglevel w] \
+ [http::cookiejar configure -loglevel e]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug info warn error}
+test http-cookiejar-2.9 "cookie storage: basics" -body {
+ http::cookiejar configure -off
+} -constraints {cookiejar} -match glob -result *
+test http-cookiejar-2.10 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -offline true
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -result 1
+test http-cookiejar-2.11 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -offline nonbool
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -returnCodes error -result {expected boolean value but got "nonbool"}
+test http-cookiejar-2.12 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -purgeold]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -purge nonint
+} -cleanup {
+ catch {http::cookiejar configure -purgeold $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.13 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -domainref nonint
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.14 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -domainref -42
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "-42"}
+test http-cookiejar-2.15 "cookie storage: basics" -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+ set result unset
+ set tracer [http::cookiejar create tracer]
+} -constraints {cookiejar} -body {
+ oo::objdefine $tracer method PostponeRefresh {} {
+ set ::result set
+ next
+ }
+ http::cookiejar configure -domainref 12345
+ return $result
+} -cleanup {
+ $tracer destroy
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -result set
+
+test http-cookiejar-3.1 "cookie storage: class" {cookiejar} {
+ info object isa object http::cookiejar
+} 1
+test http-cookiejar-3.2 "cookie storage: class" {cookiejar} {
+ info object isa class http::cookiejar
+} 1
+test http-cookiejar-3.3 "cookie storage: class" {cookiejar} {
+ lsort [info object methods http::cookiejar]
+} {configure}
+test http-cookiejar-3.4 "cookie storage: class" {cookiejar} {
+ lsort [info object methods http::cookiejar -all]
+} {configure create destroy new}
+test http-cookiejar-3.5 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {cookiejar} -body {
+ namespace eval :: {http::cookiejar create cookiejar}
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result ::cookiejar
+test http-cookiejar-3.6 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {cookiejar} -body {
+ list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
+ [::cookiejar destroy] [info commands ::cookiejar]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {::cookiejar ::cookiejar {} {}}
+test http-cookiejar-3.7 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+} -constraints {cookiejar} -body {
+ http::cookiejar create ::cookiejar foo bar
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
+test http-cookiejar-3.8 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints {cookiejar} -body {
+ list [file exists $f] [http::cookiejar create ::cookiejar $f] \
+ [file exists $f]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {0 ::cookiejar 1}
+test http-cookiejar-3.9 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "bogus content for a database" cookiejar]
+} -constraints {cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -match glob -result *
+test http-cookiejar-3.10 "cookie storage: class" -setup {
+ catch {rename ::cookiejar ""}
+ set dir [makeDirectory cookiejar]
+} -constraints {cookiejar} -body {
+ http::cookiejar create ::cookiejar $dir
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeDirectory $dir
+} -match glob -result *
+
+test http-cookiejar-4.1 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar method ?arg ...?"}
+test http-cookiejar-4.2 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar ?
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie}
+test http-cookiejar-4.3 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ lsort [info object methods cookiejar -all]
+} -cleanup {
+ ::cookiejar destroy
+} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie}
+test http-cookiejar-4.4 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar getCookies
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar getCookies proto host path"}
+test http-cookiejar-4.5 "cookie storage" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar getCookies http www.example.com /
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.6 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar storeCookie options"}
+test http-cookiejar-4.7 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.8 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.9 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.10 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.11 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.12 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.13 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.14 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.15 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.16 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo1 bar foo2 bar}}
+test http-cookiejar-4.17 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+} -constraints {cookiejar} -body {
+ cookiejar lookup a b c d
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
+test http-cookiejar-4.18 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [catch {cookiejar lookup www.example.com foo} value] $value
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
+test http-cookiejar-4.19 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key bar
+ value foo
+ secure 0
+ domain www.example.org
+ origin www.example.org
+ path /
+ hostonly 1
+ }
+ lappend result [lsort [cookiejar lookup]]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+ lappend result [cookiejar lookup www.example.org]
+ lappend result [cookiejar lookup www.example.org bar]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{www.example.com www.example.org} foo bar bar foo}
+test http-cookiejar-4.20 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.21 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.22 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ cookiejar forceLoadDomainData x y z
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
+test http-cookiejar-4.23 "cookie storage: instance" -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints {cookiejar} -body {
+ cookiejar forceLoadDomainData
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.23.a {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -offline 1
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+test http-cookiejar-4.23.b {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints {cookiejar} -body {
+ http::cookiejar configure -offline 0
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+
+test http-cookiejar-5.1 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain com
+ origin com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.2 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain foo.example.com
+ origin bar.example.org
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.3 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com}
+test http-cookiejar-5.4 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo
+ value bar2
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lsort [cookiejar lookup]
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com www.example.com}
+test http-cookiejar-5.5 "cookie storage: constraints" -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints {cookiejar} -body {
+ cookiejar storeCookie {
+ key foo1
+ value 1
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo2
+ value 2
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo3
+ value 3
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo4
+ value 4
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo5
+ value 5
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo6
+ value 6
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo7
+ value 7
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo8
+ value 8
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo9
+ value 9
+ secure 0
+ domain sub.www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ list [cookiejar getCookies http www.example.com /] \
+ [cookiejar getCookies http www2.example.com /] \
+ [cookiejar getCookies https www.example.com /] \
+ [cookiejar getCookies http sub.www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}}
+
+test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine cookiejar export PurgeCookies
+ set result {}
+ proc values cookies {
+ global result
+ lappend result [lsort [lmap {k v} $cookies {set v}]]
+ }
+} -constraints {cookiejar} -body {
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session-global
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+ after 2500
+ update
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar PurgeCookies
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value go-away
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ expires 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
+
+test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints {cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result ::cookiejar
+test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+ set result {}
+} -constraints {cookiejar} -body {
+ http::cookiejar create ::cookiejar $f
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+ lappend result [::cookiejar getCookies http www.example.com /]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {{foo cookie} {} {foo cookie}}
+
+::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/httpd b/tests/httpd
index 48e14ea..a7b42a1 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -2,8 +2,8 @@
#
# The httpd_ procedures implement a stub http server.
#
-# Copyright (c) 1997-1998 Sun Microsystems, Inc.
-# Copyright (c) 1999-2000 Scriptics Corporation
+# Copyright © 1997-1998 Sun Microsystems, Inc.
+# Copyright © 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,7 +16,12 @@
set HOST localhost
proc httpd_init {{port 8015}} {
- socket -server httpdAccept $port
+ set s [socket -server httpdAccept $port]
+ # Save the actual port number in a global variable.
+ # This is important when we're called with port 0
+ # for picking an unused port at random.
+ set ::port [lindex [chan configure $s -sockname] 2]
+ return $s
}
proc httpd_log {args} {
global httpLog
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index 89590ec..9e0edcd 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -3,12 +3,12 @@
# A simple httpd for testing HTTP/1.1 client features.
# Not suitable for use on a internet connected port.
#
-# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
+# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# 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-
+package require Tcl
proc ::tcl::dict::get? {dict key} {
if {[dict exists $dict $key]} {
@@ -46,7 +46,7 @@ proc get-chunks {data {compression gzip}} {
}
set data ""
- set chunker [make-chunk-generator $data 512]
+ set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
append data $chunk
}
@@ -60,7 +60,7 @@ proc blow-chunks {data {ochan stdout} {compression gzip}} {
compress { set data [zlib compress $data] }
}
- set chunker [make-chunk-generator $data 512]
+ set chunker [make-chunk-generator $data 671]
while {[string length [set chunk [$chunker]]]} {
puts -nonewline $ochan $chunk
}
@@ -150,7 +150,11 @@ proc Service {chan addr port} {
if {[file exists $path] && [file isfile $path]} {
foreach {what type} [mime-type $path] break
set f [open $path r]
- if {$what eq "binary"} {chan configure $f -translation binary}
+ if {$what eq "binary"} {
+ chan configure $f -translation binary
+ } else {
+ chan configure $f -encoding utf-8
+ }
set data [read $f]
close $f
set code "200 OK"
@@ -160,6 +164,12 @@ proc Service {chan addr port} {
if {$protocol eq "HTTP/1.1"} {
foreach enc [split [dict get? $meta accept-encoding] ,] {
set enc [string trim $enc]
+ # The current implementation of "compress" appears to be
+ # incorrect (bug [a13b9d0ce1]). Keep it here for
+ # experimentation only. The tests that use it have the
+ # constraint "badCompress". The client code in http has
+ # been removed, but can be restored from comments if
+ # experimentation is desired.
if {$enc in {deflate gzip compress}} {
set encoding $enc
break
@@ -171,6 +181,7 @@ proc Service {chan addr port} {
}
set nosendclose 0
+ set msdeflate 0
foreach pair [split $query &] {
if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
switch -exact -- $key {
@@ -178,6 +189,7 @@ proc Service {chan addr port} {
close {set close 1 ; set transfer 0}
transfer {set transfer $val}
content-type {set type $val}
+ msdeflate {set msdeflate $val}
}
}
if {$protocol eq "HTTP/1.1"} {
@@ -211,10 +223,23 @@ proc Service {chan addr port} {
flush $chan
chan configure $chan -buffering full -translation binary
+ if {$encoding eq {deflate}} {
+ # When http.tcl uses the correct decoder (bug [a13b9d0ce1]) for
+ # "accept-encoding deflate", i.e. "zlib decompress", this choice of
+ # encoding2 allows the tests to pass. It appears to do "deflate"
+ # correctly, but this has not been verified with a non-Tcl client.
+ set encoding2 compress
+ } else {
+ set encoding2 $encoding
+ }
if {$transfer eq "chunked"} {
- blow-chunks $data $chan $encoding
- } elseif {$encoding ne "identity"} {
- puts -nonewline $chan [zlib $encoding $data]
+ blow-chunks $data $chan $encoding2
+ } elseif {$encoding2 ne "identity" && $msdeflate eq {1}} {
+ puts -nonewline $chan [string range [zlib $encoding2 $data] 2 end-4]
+ # Used in some tests of "deflate" to produce the non-RFC-compliant
+ # Microsoft version of "deflate".
+ } elseif {$encoding2 ne "identity"} {
+ puts -nonewline $chan [zlib $encoding2 $data]
} else {
puts -nonewline $chan $data
}
diff --git a/tests/httpold.test b/tests/httpold.test
deleted file mode 100644
index e760c92..0000000
--- a/tests/httpold.test
+++ /dev/null
@@ -1,306 +0,0 @@
-# Commands covered: http_config, http_get, http_wait, http_reset
-#
-# This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-#
-# 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 {[catch {package require http 1.0}]} {
- if {[info exists httpold]} {
- catch {puts "Cannot load http 1.0 package"}
- ::tcltest::cleanupTests
- return
- } else {
- catch {puts "Running http 1.0 tests in child interp"}
- set interp [interp create httpold]
- $interp eval [list set httpold "running"]
- $interp eval [list set argv $argv]
- $interp eval [list source [info script]]
- interp delete $interp
- ::tcltest::cleanupTests
- return
- }
-}
-
-# Do not use [info hostname].
-# Name resolution is often a problem on OSX; not focus of HTTP package anyway.
-# Also a problem on other platforms for http-4.14 (test with bad port number).
-set HOST localhost
-
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-catch {unset data}
-
-##
-## The httpd script implement a stub http server
-## Sourcing httpd overwrites the value of HOST.
-##
-source [file join [file dirname [info script]] httpd]
-
-set port 8010
-if {[catch {httpd_init $port} listen]} {
- puts "Cannot start http server, http test skipped"
- unset port
- ::tcltest::cleanupTests
- return
-}
-
-test httpold-1.1 {http_config} {
- http_config
-} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
-
-test httpold-1.2 {http_config} {
- http_config -proxyfilter
-} httpProxyRequired
-
-test httpold-1.3 {http_config} {
- catch {http_config -junk}
-} 1
-
-test httpold-1.4 {http_config} {
- http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
- set x [http_config]
- http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
- -useragent "Tcl http client package 1.0"
- set x
-} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-
-test httpold-1.5 {http_config} {
- catch {http_config -proxyhost {} -junk 8080}
-} 1
-
-test httpold-2.1 {http_reset} {
- catch {http_reset http#1}
-} 0
-
-test httpold-3.1 {http_get} {
- catch {http_get -bogus flag}
-} 1
-test httpold-3.2 {http_get} {
- catch {http_get http:junk} err
- set err
-} {Unsupported URL: http:junk}
-
-set url ${::HOST}:$port
-test httpold-3.3 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<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 binurl ${::HOST}:$port/binary
-
-test httpold-3.4 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-proc selfproxy {host} {
- global port
- return [list ${::HOST} $port]
-}
-test httpold-3.5 {http_get} {
- http_config -proxyfilter selfproxy
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-test httpold-3.6 {http_get} {
- http_config -proxyfilter bogus
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.7 {http_get} {
- set token [http_get $url -headers {Pragma no-cache}]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.8 {http_get} {
- set token [http_get $url -query Name=Value&Foo=Bar]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>POST $tail</h2>
-<h2>Query</h2>
-<dl>
-<dt>Name<dd>Value
-<dt>Foo<dd>Bar
-</dl>
-</body></html>"
-
-test httpold-3.9 {http_get} {
- set token [http_get $url -validate 1]
- http_code $token
-} "HTTP/1.0 200 OK"
-
-
-test httpold-4.1 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- expr {$data(totalsize) == $meta(Content-Length)}
-} 1
-
-test httpold-4.2 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
-} 0
-
-test httpold-4.3 {httpEvent} {
- set token [http_get $url]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-
-test httpold-4.4 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- set in [open $testfile]
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-4.5 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- upvar #0 $token data
- removeFile $testfile
- expr {$data(currentsize) == $data(totalsize)}
-} 1
-
-test httpold-4.6 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $binurl -channel $out]
- close $out
- set in [open $testfile]
- fconfigure $in -translation binary
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "$bindata$binurl"
-
-proc myProgress {token total current} {
- global progress httpLog
- if {[info exists httpLog] && $httpLog} {
- puts "progress $total $current"
- }
- set progress [list $total $current]
-}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test httpold-4.6 {httpEvent} {
- set token [http_get $url -blocksize 50 -progress myProgress]
- set progress
- } {111 111}
-}
-test httpold-4.7 {httpEvent} {
- set token [http_get $url -progress myProgress]
- set progress
-} {111 111}
-test httpold-4.8 {httpEvent} {
- set token [http_get $url]
- http_status $token
-} {ok}
-test httpold-4.9 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-test httpold-4.10 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_size $token
-} {111}
-test httpold-4.11 {httpEvent} {
- set token [http_get $url -timeout 1 -command {#}]
- http_reset $token
- http_status $token
-} {reset}
-test httpold-4.12 {httpEvent} -body {
- set tout {}
- update
- set x {}
- set token [http_get $url?delay=500 -timeout 1 -command {lappend x fail}]
- set i 0; while {$x eq {} && [incr i] < 50} {
- set tout [after 20 {set x progress}]
- vwait x
- if {$x ne "progress"} break
- set x [http_status $token]
- }
- set x
-} -cleanup {
- if {$tout ne {}} {after cancel $tout}
-} -result timeout
-
-test httpold-5.1 {http_formatQuery} {
- http_formatQuery name1 value1 name2 "value two"
-} {name1=value1&name2=value+two}
-
-test httpold-5.2 {http_formatQuery} {
- http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
-} {name1=%7ebwelch&name2=%a1%a2%a2}
-
-test httpold-5.3 {http_formatQuery} {
- http_formatQuery lines "line1\nline2\nline3"
-} {lines=line1%0d%0aline2%0d%0aline3}
-
-test httpold-6.1 {httpProxyRequired} {
- update
- http_config -proxyhost ${::HOST} -proxyport $port
- set token [http_get $url]
- http_wait $token
- http_config -proxyhost {} -proxyport {}
- upvar #0 $token data
- set data(body)
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-# cleanup
-catch {unset url}
-catch {unset port}
-catch {unset data}
-close $listen
-::tcltest::cleanupTests
-return
diff --git a/tests/icuUcmTests.tcl b/tests/icuUcmTests.tcl
new file mode 100644
index 0000000..3b70748
--- /dev/null
+++ b/tests/icuUcmTests.tcl
@@ -0,0 +1,1891 @@
+
+# This file is automatically generated by ucm2tests.tcl.
+# Edits will be overwritten on next generation.
+#
+# Generates tests comparing Tcl encodings to ICU.
+# The generated file is NOT standalone. It should be sourced into a test script.
+
+proc ucmConvertfromMismatches {enc map} {
+ set mismatches {}
+ foreach {unihex hex} $map {
+ set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
+ set unich [subst "\\U$unihex"]
+ if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} {
+ lappend mismatches "<[printable $unich],$hex>"
+ }
+ }
+ return $mismatches
+}
+proc ucmConverttoMismatches {enc map} {
+ set mismatches {}
+ foreach {unihex hex} $map {
+ set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits
+ set unich [subst "\\U$unihex"]
+ if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} {
+ lappend mismatches "<[printable $unich],$hex>"
+ }
+ }
+ return $mismatches
+}
+if {[info commands printable] eq ""} {
+ proc printable {s} {
+ set print ""
+ foreach c [split $s ""] {
+ set i [scan $c %c]
+ if {[string is print $c] && ($i <= 127)} {
+ append print $c
+ } elseif {$i <= 0xff} {
+ append print \\x[format %02X $i]
+ } elseif {$i <= 0xffff} {
+ append print \\u[format %04X $i]
+ } else {
+ append print \\U[format %08X $i]
+ }
+ }
+ return $print
+ }
+}
+
+
+#
+# cp1250 (generated from glibc-CP1250-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1250 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1250 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1250 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1250 81 tcl8 \U00000081 -1 {} {}
+ cp1250 81 replace \uFFFD -1 {} {}
+ cp1250 81 strict {} 0 {} {}
+ cp1250 83 tcl8 \U00000083 -1 {} {}
+ cp1250 83 replace \uFFFD -1 {} {}
+ cp1250 83 strict {} 0 {} {}
+ cp1250 88 tcl8 \U00000088 -1 {} {}
+ cp1250 88 replace \uFFFD -1 {} {}
+ cp1250 88 strict {} 0 {} {}
+ cp1250 90 tcl8 \U00000090 -1 {} {}
+ cp1250 90 replace \uFFFD -1 {} {}
+ cp1250 90 strict {} 0 {} {}
+ cp1250 98 tcl8 \U00000098 -1 {} {}
+ cp1250 98 replace \uFFFD -1 {} {}
+ cp1250 98 strict {} 0 {} {}
+}; # cp1250
+
+# cp1250 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1250 \U00000080 tcl8 1A -1 {} {}
+ cp1250 \U00000080 replace 1A -1 {} {}
+ cp1250 \U00000080 strict {} 0 {} {}
+ cp1250 \U00000400 tcl8 1A -1 {} {}
+ cp1250 \U00000400 replace 1A -1 {} {}
+ cp1250 \U00000400 strict {} 0 {} {}
+ cp1250 \U0000D800 tcl8 1A -1 {} {}
+ cp1250 \U0000D800 replace 1A -1 {} {}
+ cp1250 \U0000D800 strict {} 0 {} {}
+ cp1250 \U0000DC00 tcl8 1A -1 {} {}
+ cp1250 \U0000DC00 replace 1A -1 {} {}
+ cp1250 \U0000DC00 strict {} 0 {} {}
+ cp1250 \U00010000 tcl8 1A -1 {} {}
+ cp1250 \U00010000 replace 1A -1 {} {}
+ cp1250 \U00010000 strict {} 0 {} {}
+ cp1250 \U0010FFFF tcl8 1A -1 {} {}
+ cp1250 \U0010FFFF replace 1A -1 {} {}
+ cp1250 \U0010FFFF strict {} 0 {} {}
+}; # cp1250
+
+#
+# cp1251 (generated from glibc-CP1251-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1251 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1251 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99}
+} -result {}
+
+# cp1251 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1251 98 tcl8 \U00000098 -1 {} {}
+ cp1251 98 replace \uFFFD -1 {} {}
+ cp1251 98 strict {} 0 {} {}
+}; # cp1251
+
+# cp1251 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1251 \U00000080 tcl8 1A -1 {} {}
+ cp1251 \U00000080 replace 1A -1 {} {}
+ cp1251 \U00000080 strict {} 0 {} {}
+ cp1251 \U00000400 tcl8 1A -1 {} {}
+ cp1251 \U00000400 replace 1A -1 {} {}
+ cp1251 \U00000400 strict {} 0 {} {}
+ cp1251 \U0000D800 tcl8 1A -1 {} {}
+ cp1251 \U0000D800 replace 1A -1 {} {}
+ cp1251 \U0000D800 strict {} 0 {} {}
+ cp1251 \U0000DC00 tcl8 1A -1 {} {}
+ cp1251 \U0000DC00 replace 1A -1 {} {}
+ cp1251 \U0000DC00 strict {} 0 {} {}
+ cp1251 \U00010000 tcl8 1A -1 {} {}
+ cp1251 \U00010000 replace 1A -1 {} {}
+ cp1251 \U00010000 strict {} 0 {} {}
+ cp1251 \U0010FFFF tcl8 1A -1 {} {}
+ cp1251 \U0010FFFF replace 1A -1 {} {}
+ cp1251 \U0010FFFF strict {} 0 {} {}
+}; # cp1251
+
+#
+# cp1252 (generated from glibc-CP1252-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1252 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1252 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1252 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1252 81 tcl8 \U00000081 -1 {} {}
+ cp1252 81 replace \uFFFD -1 {} {}
+ cp1252 81 strict {} 0 {} {}
+ cp1252 8D tcl8 \U0000008D -1 {} {}
+ cp1252 8D replace \uFFFD -1 {} {}
+ cp1252 8D strict {} 0 {} {}
+ cp1252 8F tcl8 \U0000008F -1 {} {}
+ cp1252 8F replace \uFFFD -1 {} {}
+ cp1252 8F strict {} 0 {} {}
+ cp1252 90 tcl8 \U00000090 -1 {} {}
+ cp1252 90 replace \uFFFD -1 {} {}
+ cp1252 90 strict {} 0 {} {}
+ cp1252 9D tcl8 \U0000009D -1 {} {}
+ cp1252 9D replace \uFFFD -1 {} {}
+ cp1252 9D strict {} 0 {} {}
+}; # cp1252
+
+# cp1252 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1252 \U00000080 tcl8 1A -1 {} {}
+ cp1252 \U00000080 replace 1A -1 {} {}
+ cp1252 \U00000080 strict {} 0 {} {}
+ cp1252 \U00000400 tcl8 1A -1 {} {}
+ cp1252 \U00000400 replace 1A -1 {} {}
+ cp1252 \U00000400 strict {} 0 {} {}
+ cp1252 \U0000D800 tcl8 1A -1 {} {}
+ cp1252 \U0000D800 replace 1A -1 {} {}
+ cp1252 \U0000D800 strict {} 0 {} {}
+ cp1252 \U0000DC00 tcl8 1A -1 {} {}
+ cp1252 \U0000DC00 replace 1A -1 {} {}
+ cp1252 \U0000DC00 strict {} 0 {} {}
+ cp1252 \U00010000 tcl8 1A -1 {} {}
+ cp1252 \U00010000 replace 1A -1 {} {}
+ cp1252 \U00010000 strict {} 0 {} {}
+ cp1252 \U0010FFFF tcl8 1A -1 {} {}
+ cp1252 \U0010FFFF replace 1A -1 {} {}
+ cp1252 \U0010FFFF strict {} 0 {} {}
+}; # cp1252
+
+#
+# cp1253 (generated from glibc-CP1253-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1253 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1253 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1253 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1253 81 tcl8 \U00000081 -1 {} {}
+ cp1253 81 replace \uFFFD -1 {} {}
+ cp1253 81 strict {} 0 {} {}
+ cp1253 88 tcl8 \U00000088 -1 {} {}
+ cp1253 88 replace \uFFFD -1 {} {}
+ cp1253 88 strict {} 0 {} {}
+ cp1253 8A tcl8 \U0000008A -1 {} {}
+ cp1253 8A replace \uFFFD -1 {} {}
+ cp1253 8A strict {} 0 {} {}
+ cp1253 8C tcl8 \U0000008C -1 {} {}
+ cp1253 8C replace \uFFFD -1 {} {}
+ cp1253 8C strict {} 0 {} {}
+ cp1253 8D tcl8 \U0000008D -1 {} {}
+ cp1253 8D replace \uFFFD -1 {} {}
+ cp1253 8D strict {} 0 {} {}
+ cp1253 8E tcl8 \U0000008E -1 {} {}
+ cp1253 8E replace \uFFFD -1 {} {}
+ cp1253 8E strict {} 0 {} {}
+ cp1253 8F tcl8 \U0000008F -1 {} {}
+ cp1253 8F replace \uFFFD -1 {} {}
+ cp1253 8F strict {} 0 {} {}
+ cp1253 90 tcl8 \U00000090 -1 {} {}
+ cp1253 90 replace \uFFFD -1 {} {}
+ cp1253 90 strict {} 0 {} {}
+ cp1253 98 tcl8 \U00000098 -1 {} {}
+ cp1253 98 replace \uFFFD -1 {} {}
+ cp1253 98 strict {} 0 {} {}
+ cp1253 9A tcl8 \U0000009A -1 {} {}
+ cp1253 9A replace \uFFFD -1 {} {}
+ cp1253 9A strict {} 0 {} {}
+ cp1253 9C tcl8 \U0000009C -1 {} {}
+ cp1253 9C replace \uFFFD -1 {} {}
+ cp1253 9C strict {} 0 {} {}
+ cp1253 9D tcl8 \U0000009D -1 {} {}
+ cp1253 9D replace \uFFFD -1 {} {}
+ cp1253 9D strict {} 0 {} {}
+ cp1253 9E tcl8 \U0000009E -1 {} {}
+ cp1253 9E replace \uFFFD -1 {} {}
+ cp1253 9E strict {} 0 {} {}
+ cp1253 9F tcl8 \U0000009F -1 {} {}
+ cp1253 9F replace \uFFFD -1 {} {}
+ cp1253 9F strict {} 0 {} {}
+ cp1253 AA tcl8 \U000000AA -1 {} {}
+ cp1253 AA replace \uFFFD -1 {} {}
+ cp1253 AA strict {} 0 {} {}
+ cp1253 D2 tcl8 \U000000D2 -1 {} {}
+ cp1253 D2 replace \uFFFD -1 {} {}
+ cp1253 D2 strict {} 0 {} {}
+ cp1253 FF tcl8 \U000000FF -1 {} {}
+ cp1253 FF replace \uFFFD -1 {} {}
+ cp1253 FF strict {} 0 {} {}
+}; # cp1253
+
+# cp1253 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1253 \U00000080 tcl8 1A -1 {} {}
+ cp1253 \U00000080 replace 1A -1 {} {}
+ cp1253 \U00000080 strict {} 0 {} {}
+ cp1253 \U00000400 tcl8 1A -1 {} {}
+ cp1253 \U00000400 replace 1A -1 {} {}
+ cp1253 \U00000400 strict {} 0 {} {}
+ cp1253 \U0000D800 tcl8 1A -1 {} {}
+ cp1253 \U0000D800 replace 1A -1 {} {}
+ cp1253 \U0000D800 strict {} 0 {} {}
+ cp1253 \U0000DC00 tcl8 1A -1 {} {}
+ cp1253 \U0000DC00 replace 1A -1 {} {}
+ cp1253 \U0000DC00 strict {} 0 {} {}
+ cp1253 \U00010000 tcl8 1A -1 {} {}
+ cp1253 \U00010000 replace 1A -1 {} {}
+ cp1253 \U00010000 strict {} 0 {} {}
+ cp1253 \U0010FFFF tcl8 1A -1 {} {}
+ cp1253 \U0010FFFF replace 1A -1 {} {}
+ cp1253 \U0010FFFF strict {} 0 {} {}
+}; # cp1253
+
+#
+# cp1254 (generated from glibc-CP1254-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1254 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1254 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1254 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1254 81 tcl8 \U00000081 -1 {} {}
+ cp1254 81 replace \uFFFD -1 {} {}
+ cp1254 81 strict {} 0 {} {}
+ cp1254 8D tcl8 \U0000008D -1 {} {}
+ cp1254 8D replace \uFFFD -1 {} {}
+ cp1254 8D strict {} 0 {} {}
+ cp1254 8E tcl8 \U0000008E -1 {} {}
+ cp1254 8E replace \uFFFD -1 {} {}
+ cp1254 8E strict {} 0 {} {}
+ cp1254 8F tcl8 \U0000008F -1 {} {}
+ cp1254 8F replace \uFFFD -1 {} {}
+ cp1254 8F strict {} 0 {} {}
+ cp1254 90 tcl8 \U00000090 -1 {} {}
+ cp1254 90 replace \uFFFD -1 {} {}
+ cp1254 90 strict {} 0 {} {}
+ cp1254 9D tcl8 \U0000009D -1 {} {}
+ cp1254 9D replace \uFFFD -1 {} {}
+ cp1254 9D strict {} 0 {} {}
+ cp1254 9E tcl8 \U0000009E -1 {} {}
+ cp1254 9E replace \uFFFD -1 {} {}
+ cp1254 9E strict {} 0 {} {}
+}; # cp1254
+
+# cp1254 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1254 \U00000080 tcl8 1A -1 {} {}
+ cp1254 \U00000080 replace 1A -1 {} {}
+ cp1254 \U00000080 strict {} 0 {} {}
+ cp1254 \U00000400 tcl8 1A -1 {} {}
+ cp1254 \U00000400 replace 1A -1 {} {}
+ cp1254 \U00000400 strict {} 0 {} {}
+ cp1254 \U0000D800 tcl8 1A -1 {} {}
+ cp1254 \U0000D800 replace 1A -1 {} {}
+ cp1254 \U0000D800 strict {} 0 {} {}
+ cp1254 \U0000DC00 tcl8 1A -1 {} {}
+ cp1254 \U0000DC00 replace 1A -1 {} {}
+ cp1254 \U0000DC00 strict {} 0 {} {}
+ cp1254 \U00010000 tcl8 1A -1 {} {}
+ cp1254 \U00010000 replace 1A -1 {} {}
+ cp1254 \U00010000 strict {} 0 {} {}
+ cp1254 \U0010FFFF tcl8 1A -1 {} {}
+ cp1254 \U0010FFFF replace 1A -1 {} {}
+ cp1254 \U0010FFFF strict {} 0 {} {}
+}; # cp1254
+
+#
+# cp1255 (generated from glibc-CP1255-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1255 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1255 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99}
+} -result {}
+
+# cp1255 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1255 81 tcl8 \U00000081 -1 {} {}
+ cp1255 81 replace \uFFFD -1 {} {}
+ cp1255 81 strict {} 0 {} {}
+ cp1255 8A tcl8 \U0000008A -1 {} {}
+ cp1255 8A replace \uFFFD -1 {} {}
+ cp1255 8A strict {} 0 {} {}
+ cp1255 8C tcl8 \U0000008C -1 {} {}
+ cp1255 8C replace \uFFFD -1 {} {}
+ cp1255 8C strict {} 0 {} {}
+ cp1255 8D tcl8 \U0000008D -1 {} {}
+ cp1255 8D replace \uFFFD -1 {} {}
+ cp1255 8D strict {} 0 {} {}
+ cp1255 8E tcl8 \U0000008E -1 {} {}
+ cp1255 8E replace \uFFFD -1 {} {}
+ cp1255 8E strict {} 0 {} {}
+ cp1255 8F tcl8 \U0000008F -1 {} {}
+ cp1255 8F replace \uFFFD -1 {} {}
+ cp1255 8F strict {} 0 {} {}
+ cp1255 90 tcl8 \U00000090 -1 {} {}
+ cp1255 90 replace \uFFFD -1 {} {}
+ cp1255 90 strict {} 0 {} {}
+ cp1255 9A tcl8 \U0000009A -1 {} {}
+ cp1255 9A replace \uFFFD -1 {} {}
+ cp1255 9A strict {} 0 {} {}
+ cp1255 9C tcl8 \U0000009C -1 {} {}
+ cp1255 9C replace \uFFFD -1 {} {}
+ cp1255 9C strict {} 0 {} {}
+ cp1255 9D tcl8 \U0000009D -1 {} {}
+ cp1255 9D replace \uFFFD -1 {} {}
+ cp1255 9D strict {} 0 {} {}
+ cp1255 9E tcl8 \U0000009E -1 {} {}
+ cp1255 9E replace \uFFFD -1 {} {}
+ cp1255 9E strict {} 0 {} {}
+ cp1255 9F tcl8 \U0000009F -1 {} {}
+ cp1255 9F replace \uFFFD -1 {} {}
+ cp1255 9F strict {} 0 {} {}
+ cp1255 CA tcl8 \U000000CA -1 {} {}
+ cp1255 CA replace \uFFFD -1 {} {}
+ cp1255 CA strict {} 0 {} {}
+ cp1255 D9 tcl8 \U000000D9 -1 {} {}
+ cp1255 D9 replace \uFFFD -1 {} {}
+ cp1255 D9 strict {} 0 {} {}
+ cp1255 DA tcl8 \U000000DA -1 {} {}
+ cp1255 DA replace \uFFFD -1 {} {}
+ cp1255 DA strict {} 0 {} {}
+ cp1255 DB tcl8 \U000000DB -1 {} {}
+ cp1255 DB replace \uFFFD -1 {} {}
+ cp1255 DB strict {} 0 {} {}
+ cp1255 DC tcl8 \U000000DC -1 {} {}
+ cp1255 DC replace \uFFFD -1 {} {}
+ cp1255 DC strict {} 0 {} {}
+ cp1255 DD tcl8 \U000000DD -1 {} {}
+ cp1255 DD replace \uFFFD -1 {} {}
+ cp1255 DD strict {} 0 {} {}
+ cp1255 DE tcl8 \U000000DE -1 {} {}
+ cp1255 DE replace \uFFFD -1 {} {}
+ cp1255 DE strict {} 0 {} {}
+ cp1255 DF tcl8 \U000000DF -1 {} {}
+ cp1255 DF replace \uFFFD -1 {} {}
+ cp1255 DF strict {} 0 {} {}
+ cp1255 FB tcl8 \U000000FB -1 {} {}
+ cp1255 FB replace \uFFFD -1 {} {}
+ cp1255 FB strict {} 0 {} {}
+ cp1255 FC tcl8 \U000000FC -1 {} {}
+ cp1255 FC replace \uFFFD -1 {} {}
+ cp1255 FC strict {} 0 {} {}
+ cp1255 FF tcl8 \U000000FF -1 {} {}
+ cp1255 FF replace \uFFFD -1 {} {}
+ cp1255 FF strict {} 0 {} {}
+}; # cp1255
+
+# cp1255 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1255 \U00000080 tcl8 1A -1 {} {}
+ cp1255 \U00000080 replace 1A -1 {} {}
+ cp1255 \U00000080 strict {} 0 {} {}
+ cp1255 \U00000400 tcl8 1A -1 {} {}
+ cp1255 \U00000400 replace 1A -1 {} {}
+ cp1255 \U00000400 strict {} 0 {} {}
+ cp1255 \U0000D800 tcl8 1A -1 {} {}
+ cp1255 \U0000D800 replace 1A -1 {} {}
+ cp1255 \U0000D800 strict {} 0 {} {}
+ cp1255 \U0000DC00 tcl8 1A -1 {} {}
+ cp1255 \U0000DC00 replace 1A -1 {} {}
+ cp1255 \U0000DC00 strict {} 0 {} {}
+ cp1255 \U00010000 tcl8 1A -1 {} {}
+ cp1255 \U00010000 replace 1A -1 {} {}
+ cp1255 \U00010000 strict {} 0 {} {}
+ cp1255 \U0010FFFF tcl8 1A -1 {} {}
+ cp1255 \U0010FFFF replace 1A -1 {} {}
+ cp1255 \U0010FFFF strict {} 0 {} {}
+}; # cp1255
+
+#
+# cp1256 (generated from glibc-CP1256-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1256 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1256 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1256 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # cp1256
+
+# cp1256 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1256 \U00000080 tcl8 1A -1 {} {}
+ cp1256 \U00000080 replace 1A -1 {} {}
+ cp1256 \U00000080 strict {} 0 {} {}
+ cp1256 \U00000400 tcl8 1A -1 {} {}
+ cp1256 \U00000400 replace 1A -1 {} {}
+ cp1256 \U00000400 strict {} 0 {} {}
+ cp1256 \U0000D800 tcl8 1A -1 {} {}
+ cp1256 \U0000D800 replace 1A -1 {} {}
+ cp1256 \U0000D800 strict {} 0 {} {}
+ cp1256 \U0000DC00 tcl8 1A -1 {} {}
+ cp1256 \U0000DC00 replace 1A -1 {} {}
+ cp1256 \U0000DC00 strict {} 0 {} {}
+ cp1256 \U00010000 tcl8 1A -1 {} {}
+ cp1256 \U00010000 replace 1A -1 {} {}
+ cp1256 \U00010000 strict {} 0 {} {}
+ cp1256 \U0010FFFF tcl8 1A -1 {} {}
+ cp1256 \U0010FFFF replace 1A -1 {} {}
+ cp1256 \U0010FFFF strict {} 0 {} {}
+}; # cp1256
+
+#
+# cp1257 (generated from glibc-CP1257-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1257 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1257 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99}
+} -result {}
+
+# cp1257 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1257 81 tcl8 \U00000081 -1 {} {}
+ cp1257 81 replace \uFFFD -1 {} {}
+ cp1257 81 strict {} 0 {} {}
+ cp1257 83 tcl8 \U00000083 -1 {} {}
+ cp1257 83 replace \uFFFD -1 {} {}
+ cp1257 83 strict {} 0 {} {}
+ cp1257 88 tcl8 \U00000088 -1 {} {}
+ cp1257 88 replace \uFFFD -1 {} {}
+ cp1257 88 strict {} 0 {} {}
+ cp1257 8A tcl8 \U0000008A -1 {} {}
+ cp1257 8A replace \uFFFD -1 {} {}
+ cp1257 8A strict {} 0 {} {}
+ cp1257 8C tcl8 \U0000008C -1 {} {}
+ cp1257 8C replace \uFFFD -1 {} {}
+ cp1257 8C strict {} 0 {} {}
+ cp1257 90 tcl8 \U00000090 -1 {} {}
+ cp1257 90 replace \uFFFD -1 {} {}
+ cp1257 90 strict {} 0 {} {}
+ cp1257 98 tcl8 \U00000098 -1 {} {}
+ cp1257 98 replace \uFFFD -1 {} {}
+ cp1257 98 strict {} 0 {} {}
+ cp1257 9A tcl8 \U0000009A -1 {} {}
+ cp1257 9A replace \uFFFD -1 {} {}
+ cp1257 9A strict {} 0 {} {}
+ cp1257 9C tcl8 \U0000009C -1 {} {}
+ cp1257 9C replace \uFFFD -1 {} {}
+ cp1257 9C strict {} 0 {} {}
+ cp1257 9F tcl8 \U0000009F -1 {} {}
+ cp1257 9F replace \uFFFD -1 {} {}
+ cp1257 9F strict {} 0 {} {}
+ cp1257 A1 tcl8 \U000000A1 -1 {} {}
+ cp1257 A1 replace \uFFFD -1 {} {}
+ cp1257 A1 strict {} 0 {} {}
+ cp1257 A5 tcl8 \U000000A5 -1 {} {}
+ cp1257 A5 replace \uFFFD -1 {} {}
+ cp1257 A5 strict {} 0 {} {}
+}; # cp1257
+
+# cp1257 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1257 \U00000080 tcl8 1A -1 {} {}
+ cp1257 \U00000080 replace 1A -1 {} {}
+ cp1257 \U00000080 strict {} 0 {} {}
+ cp1257 \U00000400 tcl8 1A -1 {} {}
+ cp1257 \U00000400 replace 1A -1 {} {}
+ cp1257 \U00000400 strict {} 0 {} {}
+ cp1257 \U0000D800 tcl8 1A -1 {} {}
+ cp1257 \U0000D800 replace 1A -1 {} {}
+ cp1257 \U0000D800 strict {} 0 {} {}
+ cp1257 \U0000DC00 tcl8 1A -1 {} {}
+ cp1257 \U0000DC00 replace 1A -1 {} {}
+ cp1257 \U0000DC00 strict {} 0 {} {}
+ cp1257 \U00010000 tcl8 1A -1 {} {}
+ cp1257 \U00010000 replace 1A -1 {} {}
+ cp1257 \U00010000 strict {} 0 {} {}
+ cp1257 \U0010FFFF tcl8 1A -1 {} {}
+ cp1257 \U0010FFFF replace 1A -1 {} {}
+ cp1257 \U0010FFFF strict {} 0 {} {}
+}; # cp1257
+
+#
+# cp1258 (generated from glibc-CP1258-2.1.2)
+
+test encoding-convertfrom-ucmCompare-cp1258 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99}
+} -result {}
+
+test encoding-convertto-ucmCompare-cp1258 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99}
+} -result {}
+
+# cp1258 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ cp1258 81 tcl8 \U00000081 -1 {} {}
+ cp1258 81 replace \uFFFD -1 {} {}
+ cp1258 81 strict {} 0 {} {}
+ cp1258 8A tcl8 \U0000008A -1 {} {}
+ cp1258 8A replace \uFFFD -1 {} {}
+ cp1258 8A strict {} 0 {} {}
+ cp1258 8D tcl8 \U0000008D -1 {} {}
+ cp1258 8D replace \uFFFD -1 {} {}
+ cp1258 8D strict {} 0 {} {}
+ cp1258 8E tcl8 \U0000008E -1 {} {}
+ cp1258 8E replace \uFFFD -1 {} {}
+ cp1258 8E strict {} 0 {} {}
+ cp1258 8F tcl8 \U0000008F -1 {} {}
+ cp1258 8F replace \uFFFD -1 {} {}
+ cp1258 8F strict {} 0 {} {}
+ cp1258 90 tcl8 \U00000090 -1 {} {}
+ cp1258 90 replace \uFFFD -1 {} {}
+ cp1258 90 strict {} 0 {} {}
+ cp1258 9A tcl8 \U0000009A -1 {} {}
+ cp1258 9A replace \uFFFD -1 {} {}
+ cp1258 9A strict {} 0 {} {}
+ cp1258 9D tcl8 \U0000009D -1 {} {}
+ cp1258 9D replace \uFFFD -1 {} {}
+ cp1258 9D strict {} 0 {} {}
+ cp1258 9E tcl8 \U0000009E -1 {} {}
+ cp1258 9E replace \uFFFD -1 {} {}
+ cp1258 9E strict {} 0 {} {}
+ cp1258 EC tcl8 \U000000EC -1 {} {}
+ cp1258 EC replace \uFFFD -1 {} {}
+ cp1258 EC strict {} 0 {} {}
+}; # cp1258
+
+# cp1258 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ cp1258 \U00000080 tcl8 1A -1 {} {}
+ cp1258 \U00000080 replace 1A -1 {} {}
+ cp1258 \U00000080 strict {} 0 {} {}
+ cp1258 \U00000400 tcl8 1A -1 {} {}
+ cp1258 \U00000400 replace 1A -1 {} {}
+ cp1258 \U00000400 strict {} 0 {} {}
+ cp1258 \U0000D800 tcl8 1A -1 {} {}
+ cp1258 \U0000D800 replace 1A -1 {} {}
+ cp1258 \U0000D800 strict {} 0 {} {}
+ cp1258 \U0000DC00 tcl8 1A -1 {} {}
+ cp1258 \U0000DC00 replace 1A -1 {} {}
+ cp1258 \U0000DC00 strict {} 0 {} {}
+ cp1258 \U00010000 tcl8 1A -1 {} {}
+ cp1258 \U00010000 replace 1A -1 {} {}
+ cp1258 \U00010000 strict {} 0 {} {}
+ cp1258 \U0010FFFF tcl8 1A -1 {} {}
+ cp1258 \U0010FFFF replace 1A -1 {} {}
+ cp1258 \U0010FFFF strict {} 0 {} {}
+}; # cp1258
+
+#
+# gb1988 (generated from glibc-GB_1988_80-2.3.3)
+
+test encoding-convertfrom-ucmCompare-gb1988 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E}
+} -result {}
+
+test encoding-convertto-ucmCompare-gb1988 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E}
+} -result {}
+
+# gb1988 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ gb1988 80 tcl8 \U00000080 -1 {} {}
+ gb1988 80 replace \uFFFD -1 {} {}
+ gb1988 80 strict {} 0 {} {}
+ gb1988 81 tcl8 \U00000081 -1 {} {}
+ gb1988 81 replace \uFFFD -1 {} {}
+ gb1988 81 strict {} 0 {} {}
+ gb1988 82 tcl8 \U00000082 -1 {} {}
+ gb1988 82 replace \uFFFD -1 {} {}
+ gb1988 82 strict {} 0 {} {}
+ gb1988 83 tcl8 \U00000083 -1 {} {}
+ gb1988 83 replace \uFFFD -1 {} {}
+ gb1988 83 strict {} 0 {} {}
+ gb1988 84 tcl8 \U00000084 -1 {} {}
+ gb1988 84 replace \uFFFD -1 {} {}
+ gb1988 84 strict {} 0 {} {}
+ gb1988 85 tcl8 \U00000085 -1 {} {}
+ gb1988 85 replace \uFFFD -1 {} {}
+ gb1988 85 strict {} 0 {} {}
+ gb1988 86 tcl8 \U00000086 -1 {} {}
+ gb1988 86 replace \uFFFD -1 {} {}
+ gb1988 86 strict {} 0 {} {}
+ gb1988 87 tcl8 \U00000087 -1 {} {}
+ gb1988 87 replace \uFFFD -1 {} {}
+ gb1988 87 strict {} 0 {} {}
+ gb1988 88 tcl8 \U00000088 -1 {} {}
+ gb1988 88 replace \uFFFD -1 {} {}
+ gb1988 88 strict {} 0 {} {}
+ gb1988 89 tcl8 \U00000089 -1 {} {}
+ gb1988 89 replace \uFFFD -1 {} {}
+ gb1988 89 strict {} 0 {} {}
+ gb1988 8A tcl8 \U0000008A -1 {} {}
+ gb1988 8A replace \uFFFD -1 {} {}
+ gb1988 8A strict {} 0 {} {}
+ gb1988 8B tcl8 \U0000008B -1 {} {}
+ gb1988 8B replace \uFFFD -1 {} {}
+ gb1988 8B strict {} 0 {} {}
+ gb1988 8C tcl8 \U0000008C -1 {} {}
+ gb1988 8C replace \uFFFD -1 {} {}
+ gb1988 8C strict {} 0 {} {}
+ gb1988 8D tcl8 \U0000008D -1 {} {}
+ gb1988 8D replace \uFFFD -1 {} {}
+ gb1988 8D strict {} 0 {} {}
+ gb1988 8E tcl8 \U0000008E -1 {} {}
+ gb1988 8E replace \uFFFD -1 {} {}
+ gb1988 8E strict {} 0 {} {}
+ gb1988 8F tcl8 \U0000008F -1 {} {}
+ gb1988 8F replace \uFFFD -1 {} {}
+ gb1988 8F strict {} 0 {} {}
+ gb1988 90 tcl8 \U00000090 -1 {} {}
+ gb1988 90 replace \uFFFD -1 {} {}
+ gb1988 90 strict {} 0 {} {}
+ gb1988 91 tcl8 \U00000091 -1 {} {}
+ gb1988 91 replace \uFFFD -1 {} {}
+ gb1988 91 strict {} 0 {} {}
+ gb1988 92 tcl8 \U00000092 -1 {} {}
+ gb1988 92 replace \uFFFD -1 {} {}
+ gb1988 92 strict {} 0 {} {}
+ gb1988 93 tcl8 \U00000093 -1 {} {}
+ gb1988 93 replace \uFFFD -1 {} {}
+ gb1988 93 strict {} 0 {} {}
+ gb1988 94 tcl8 \U00000094 -1 {} {}
+ gb1988 94 replace \uFFFD -1 {} {}
+ gb1988 94 strict {} 0 {} {}
+ gb1988 95 tcl8 \U00000095 -1 {} {}
+ gb1988 95 replace \uFFFD -1 {} {}
+ gb1988 95 strict {} 0 {} {}
+ gb1988 96 tcl8 \U00000096 -1 {} {}
+ gb1988 96 replace \uFFFD -1 {} {}
+ gb1988 96 strict {} 0 {} {}
+ gb1988 97 tcl8 \U00000097 -1 {} {}
+ gb1988 97 replace \uFFFD -1 {} {}
+ gb1988 97 strict {} 0 {} {}
+ gb1988 98 tcl8 \U00000098 -1 {} {}
+ gb1988 98 replace \uFFFD -1 {} {}
+ gb1988 98 strict {} 0 {} {}
+ gb1988 99 tcl8 \U00000099 -1 {} {}
+ gb1988 99 replace \uFFFD -1 {} {}
+ gb1988 99 strict {} 0 {} {}
+ gb1988 9A tcl8 \U0000009A -1 {} {}
+ gb1988 9A replace \uFFFD -1 {} {}
+ gb1988 9A strict {} 0 {} {}
+ gb1988 9B tcl8 \U0000009B -1 {} {}
+ gb1988 9B replace \uFFFD -1 {} {}
+ gb1988 9B strict {} 0 {} {}
+ gb1988 9C tcl8 \U0000009C -1 {} {}
+ gb1988 9C replace \uFFFD -1 {} {}
+ gb1988 9C strict {} 0 {} {}
+ gb1988 9D tcl8 \U0000009D -1 {} {}
+ gb1988 9D replace \uFFFD -1 {} {}
+ gb1988 9D strict {} 0 {} {}
+ gb1988 9E tcl8 \U0000009E -1 {} {}
+ gb1988 9E replace \uFFFD -1 {} {}
+ gb1988 9E strict {} 0 {} {}
+ gb1988 9F tcl8 \U0000009F -1 {} {}
+ gb1988 9F replace \uFFFD -1 {} {}
+ gb1988 9F strict {} 0 {} {}
+ gb1988 A0 tcl8 \U000000A0 -1 {} {}
+ gb1988 A0 replace \uFFFD -1 {} {}
+ gb1988 A0 strict {} 0 {} {}
+ gb1988 A1 tcl8 \U000000A1 -1 {} {}
+ gb1988 A1 replace \uFFFD -1 {} {}
+ gb1988 A1 strict {} 0 {} {}
+ gb1988 A2 tcl8 \U000000A2 -1 {} {}
+ gb1988 A2 replace \uFFFD -1 {} {}
+ gb1988 A2 strict {} 0 {} {}
+ gb1988 A3 tcl8 \U000000A3 -1 {} {}
+ gb1988 A3 replace \uFFFD -1 {} {}
+ gb1988 A3 strict {} 0 {} {}
+ gb1988 A4 tcl8 \U000000A4 -1 {} {}
+ gb1988 A4 replace \uFFFD -1 {} {}
+ gb1988 A4 strict {} 0 {} {}
+ gb1988 A5 tcl8 \U000000A5 -1 {} {}
+ gb1988 A5 replace \uFFFD -1 {} {}
+ gb1988 A5 strict {} 0 {} {}
+ gb1988 A6 tcl8 \U000000A6 -1 {} {}
+ gb1988 A6 replace \uFFFD -1 {} {}
+ gb1988 A6 strict {} 0 {} {}
+ gb1988 A7 tcl8 \U000000A7 -1 {} {}
+ gb1988 A7 replace \uFFFD -1 {} {}
+ gb1988 A7 strict {} 0 {} {}
+ gb1988 A8 tcl8 \U000000A8 -1 {} {}
+ gb1988 A8 replace \uFFFD -1 {} {}
+ gb1988 A8 strict {} 0 {} {}
+ gb1988 A9 tcl8 \U000000A9 -1 {} {}
+ gb1988 A9 replace \uFFFD -1 {} {}
+ gb1988 A9 strict {} 0 {} {}
+ gb1988 AA tcl8 \U000000AA -1 {} {}
+ gb1988 AA replace \uFFFD -1 {} {}
+ gb1988 AA strict {} 0 {} {}
+ gb1988 AB tcl8 \U000000AB -1 {} {}
+ gb1988 AB replace \uFFFD -1 {} {}
+ gb1988 AB strict {} 0 {} {}
+ gb1988 AC tcl8 \U000000AC -1 {} {}
+ gb1988 AC replace \uFFFD -1 {} {}
+ gb1988 AC strict {} 0 {} {}
+ gb1988 AD tcl8 \U000000AD -1 {} {}
+ gb1988 AD replace \uFFFD -1 {} {}
+ gb1988 AD strict {} 0 {} {}
+ gb1988 AE tcl8 \U000000AE -1 {} {}
+ gb1988 AE replace \uFFFD -1 {} {}
+ gb1988 AE strict {} 0 {} {}
+ gb1988 AF tcl8 \U000000AF -1 {} {}
+ gb1988 AF replace \uFFFD -1 {} {}
+ gb1988 AF strict {} 0 {} {}
+ gb1988 B0 tcl8 \U000000B0 -1 {} {}
+ gb1988 B0 replace \uFFFD -1 {} {}
+ gb1988 B0 strict {} 0 {} {}
+ gb1988 B1 tcl8 \U000000B1 -1 {} {}
+ gb1988 B1 replace \uFFFD -1 {} {}
+ gb1988 B1 strict {} 0 {} {}
+ gb1988 B2 tcl8 \U000000B2 -1 {} {}
+ gb1988 B2 replace \uFFFD -1 {} {}
+ gb1988 B2 strict {} 0 {} {}
+ gb1988 B3 tcl8 \U000000B3 -1 {} {}
+ gb1988 B3 replace \uFFFD -1 {} {}
+ gb1988 B3 strict {} 0 {} {}
+ gb1988 B4 tcl8 \U000000B4 -1 {} {}
+ gb1988 B4 replace \uFFFD -1 {} {}
+ gb1988 B4 strict {} 0 {} {}
+ gb1988 B5 tcl8 \U000000B5 -1 {} {}
+ gb1988 B5 replace \uFFFD -1 {} {}
+ gb1988 B5 strict {} 0 {} {}
+ gb1988 B6 tcl8 \U000000B6 -1 {} {}
+ gb1988 B6 replace \uFFFD -1 {} {}
+ gb1988 B6 strict {} 0 {} {}
+ gb1988 B7 tcl8 \U000000B7 -1 {} {}
+ gb1988 B7 replace \uFFFD -1 {} {}
+ gb1988 B7 strict {} 0 {} {}
+ gb1988 B8 tcl8 \U000000B8 -1 {} {}
+ gb1988 B8 replace \uFFFD -1 {} {}
+ gb1988 B8 strict {} 0 {} {}
+ gb1988 B9 tcl8 \U000000B9 -1 {} {}
+ gb1988 B9 replace \uFFFD -1 {} {}
+ gb1988 B9 strict {} 0 {} {}
+ gb1988 BA tcl8 \U000000BA -1 {} {}
+ gb1988 BA replace \uFFFD -1 {} {}
+ gb1988 BA strict {} 0 {} {}
+ gb1988 BB tcl8 \U000000BB -1 {} {}
+ gb1988 BB replace \uFFFD -1 {} {}
+ gb1988 BB strict {} 0 {} {}
+ gb1988 BC tcl8 \U000000BC -1 {} {}
+ gb1988 BC replace \uFFFD -1 {} {}
+ gb1988 BC strict {} 0 {} {}
+ gb1988 BD tcl8 \U000000BD -1 {} {}
+ gb1988 BD replace \uFFFD -1 {} {}
+ gb1988 BD strict {} 0 {} {}
+ gb1988 BE tcl8 \U000000BE -1 {} {}
+ gb1988 BE replace \uFFFD -1 {} {}
+ gb1988 BE strict {} 0 {} {}
+ gb1988 BF tcl8 \U000000BF -1 {} {}
+ gb1988 BF replace \uFFFD -1 {} {}
+ gb1988 BF strict {} 0 {} {}
+ gb1988 C0 tcl8 \U000000C0 -1 {} {}
+ gb1988 C0 replace \uFFFD -1 {} {}
+ gb1988 C0 strict {} 0 {} {}
+ gb1988 C1 tcl8 \U000000C1 -1 {} {}
+ gb1988 C1 replace \uFFFD -1 {} {}
+ gb1988 C1 strict {} 0 {} {}
+ gb1988 C2 tcl8 \U000000C2 -1 {} {}
+ gb1988 C2 replace \uFFFD -1 {} {}
+ gb1988 C2 strict {} 0 {} {}
+ gb1988 C3 tcl8 \U000000C3 -1 {} {}
+ gb1988 C3 replace \uFFFD -1 {} {}
+ gb1988 C3 strict {} 0 {} {}
+ gb1988 C4 tcl8 \U000000C4 -1 {} {}
+ gb1988 C4 replace \uFFFD -1 {} {}
+ gb1988 C4 strict {} 0 {} {}
+ gb1988 C5 tcl8 \U000000C5 -1 {} {}
+ gb1988 C5 replace \uFFFD -1 {} {}
+ gb1988 C5 strict {} 0 {} {}
+ gb1988 C6 tcl8 \U000000C6 -1 {} {}
+ gb1988 C6 replace \uFFFD -1 {} {}
+ gb1988 C6 strict {} 0 {} {}
+ gb1988 C7 tcl8 \U000000C7 -1 {} {}
+ gb1988 C7 replace \uFFFD -1 {} {}
+ gb1988 C7 strict {} 0 {} {}
+ gb1988 C8 tcl8 \U000000C8 -1 {} {}
+ gb1988 C8 replace \uFFFD -1 {} {}
+ gb1988 C8 strict {} 0 {} {}
+ gb1988 C9 tcl8 \U000000C9 -1 {} {}
+ gb1988 C9 replace \uFFFD -1 {} {}
+ gb1988 C9 strict {} 0 {} {}
+ gb1988 CA tcl8 \U000000CA -1 {} {}
+ gb1988 CA replace \uFFFD -1 {} {}
+ gb1988 CA strict {} 0 {} {}
+ gb1988 CB tcl8 \U000000CB -1 {} {}
+ gb1988 CB replace \uFFFD -1 {} {}
+ gb1988 CB strict {} 0 {} {}
+ gb1988 CC tcl8 \U000000CC -1 {} {}
+ gb1988 CC replace \uFFFD -1 {} {}
+ gb1988 CC strict {} 0 {} {}
+ gb1988 CD tcl8 \U000000CD -1 {} {}
+ gb1988 CD replace \uFFFD -1 {} {}
+ gb1988 CD strict {} 0 {} {}
+ gb1988 CE tcl8 \U000000CE -1 {} {}
+ gb1988 CE replace \uFFFD -1 {} {}
+ gb1988 CE strict {} 0 {} {}
+ gb1988 CF tcl8 \U000000CF -1 {} {}
+ gb1988 CF replace \uFFFD -1 {} {}
+ gb1988 CF strict {} 0 {} {}
+ gb1988 D0 tcl8 \U000000D0 -1 {} {}
+ gb1988 D0 replace \uFFFD -1 {} {}
+ gb1988 D0 strict {} 0 {} {}
+ gb1988 D1 tcl8 \U000000D1 -1 {} {}
+ gb1988 D1 replace \uFFFD -1 {} {}
+ gb1988 D1 strict {} 0 {} {}
+ gb1988 D2 tcl8 \U000000D2 -1 {} {}
+ gb1988 D2 replace \uFFFD -1 {} {}
+ gb1988 D2 strict {} 0 {} {}
+ gb1988 D3 tcl8 \U000000D3 -1 {} {}
+ gb1988 D3 replace \uFFFD -1 {} {}
+ gb1988 D3 strict {} 0 {} {}
+ gb1988 D4 tcl8 \U000000D4 -1 {} {}
+ gb1988 D4 replace \uFFFD -1 {} {}
+ gb1988 D4 strict {} 0 {} {}
+ gb1988 D5 tcl8 \U000000D5 -1 {} {}
+ gb1988 D5 replace \uFFFD -1 {} {}
+ gb1988 D5 strict {} 0 {} {}
+ gb1988 D6 tcl8 \U000000D6 -1 {} {}
+ gb1988 D6 replace \uFFFD -1 {} {}
+ gb1988 D6 strict {} 0 {} {}
+ gb1988 D7 tcl8 \U000000D7 -1 {} {}
+ gb1988 D7 replace \uFFFD -1 {} {}
+ gb1988 D7 strict {} 0 {} {}
+ gb1988 D8 tcl8 \U000000D8 -1 {} {}
+ gb1988 D8 replace \uFFFD -1 {} {}
+ gb1988 D8 strict {} 0 {} {}
+ gb1988 D9 tcl8 \U000000D9 -1 {} {}
+ gb1988 D9 replace \uFFFD -1 {} {}
+ gb1988 D9 strict {} 0 {} {}
+ gb1988 DA tcl8 \U000000DA -1 {} {}
+ gb1988 DA replace \uFFFD -1 {} {}
+ gb1988 DA strict {} 0 {} {}
+ gb1988 DB tcl8 \U000000DB -1 {} {}
+ gb1988 DB replace \uFFFD -1 {} {}
+ gb1988 DB strict {} 0 {} {}
+ gb1988 DC tcl8 \U000000DC -1 {} {}
+ gb1988 DC replace \uFFFD -1 {} {}
+ gb1988 DC strict {} 0 {} {}
+ gb1988 DD tcl8 \U000000DD -1 {} {}
+ gb1988 DD replace \uFFFD -1 {} {}
+ gb1988 DD strict {} 0 {} {}
+ gb1988 DE tcl8 \U000000DE -1 {} {}
+ gb1988 DE replace \uFFFD -1 {} {}
+ gb1988 DE strict {} 0 {} {}
+ gb1988 DF tcl8 \U000000DF -1 {} {}
+ gb1988 DF replace \uFFFD -1 {} {}
+ gb1988 DF strict {} 0 {} {}
+ gb1988 E0 tcl8 \U000000E0 -1 {} {}
+ gb1988 E0 replace \uFFFD -1 {} {}
+ gb1988 E0 strict {} 0 {} {}
+ gb1988 E1 tcl8 \U000000E1 -1 {} {}
+ gb1988 E1 replace \uFFFD -1 {} {}
+ gb1988 E1 strict {} 0 {} {}
+ gb1988 E2 tcl8 \U000000E2 -1 {} {}
+ gb1988 E2 replace \uFFFD -1 {} {}
+ gb1988 E2 strict {} 0 {} {}
+ gb1988 E3 tcl8 \U000000E3 -1 {} {}
+ gb1988 E3 replace \uFFFD -1 {} {}
+ gb1988 E3 strict {} 0 {} {}
+ gb1988 E4 tcl8 \U000000E4 -1 {} {}
+ gb1988 E4 replace \uFFFD -1 {} {}
+ gb1988 E4 strict {} 0 {} {}
+ gb1988 E5 tcl8 \U000000E5 -1 {} {}
+ gb1988 E5 replace \uFFFD -1 {} {}
+ gb1988 E5 strict {} 0 {} {}
+ gb1988 E6 tcl8 \U000000E6 -1 {} {}
+ gb1988 E6 replace \uFFFD -1 {} {}
+ gb1988 E6 strict {} 0 {} {}
+ gb1988 E7 tcl8 \U000000E7 -1 {} {}
+ gb1988 E7 replace \uFFFD -1 {} {}
+ gb1988 E7 strict {} 0 {} {}
+ gb1988 E8 tcl8 \U000000E8 -1 {} {}
+ gb1988 E8 replace \uFFFD -1 {} {}
+ gb1988 E8 strict {} 0 {} {}
+ gb1988 E9 tcl8 \U000000E9 -1 {} {}
+ gb1988 E9 replace \uFFFD -1 {} {}
+ gb1988 E9 strict {} 0 {} {}
+ gb1988 EA tcl8 \U000000EA -1 {} {}
+ gb1988 EA replace \uFFFD -1 {} {}
+ gb1988 EA strict {} 0 {} {}
+ gb1988 EB tcl8 \U000000EB -1 {} {}
+ gb1988 EB replace \uFFFD -1 {} {}
+ gb1988 EB strict {} 0 {} {}
+ gb1988 EC tcl8 \U000000EC -1 {} {}
+ gb1988 EC replace \uFFFD -1 {} {}
+ gb1988 EC strict {} 0 {} {}
+ gb1988 ED tcl8 \U000000ED -1 {} {}
+ gb1988 ED replace \uFFFD -1 {} {}
+ gb1988 ED strict {} 0 {} {}
+ gb1988 EE tcl8 \U000000EE -1 {} {}
+ gb1988 EE replace \uFFFD -1 {} {}
+ gb1988 EE strict {} 0 {} {}
+ gb1988 EF tcl8 \U000000EF -1 {} {}
+ gb1988 EF replace \uFFFD -1 {} {}
+ gb1988 EF strict {} 0 {} {}
+ gb1988 F0 tcl8 \U000000F0 -1 {} {}
+ gb1988 F0 replace \uFFFD -1 {} {}
+ gb1988 F0 strict {} 0 {} {}
+ gb1988 F1 tcl8 \U000000F1 -1 {} {}
+ gb1988 F1 replace \uFFFD -1 {} {}
+ gb1988 F1 strict {} 0 {} {}
+ gb1988 F2 tcl8 \U000000F2 -1 {} {}
+ gb1988 F2 replace \uFFFD -1 {} {}
+ gb1988 F2 strict {} 0 {} {}
+ gb1988 F3 tcl8 \U000000F3 -1 {} {}
+ gb1988 F3 replace \uFFFD -1 {} {}
+ gb1988 F3 strict {} 0 {} {}
+ gb1988 F4 tcl8 \U000000F4 -1 {} {}
+ gb1988 F4 replace \uFFFD -1 {} {}
+ gb1988 F4 strict {} 0 {} {}
+ gb1988 F5 tcl8 \U000000F5 -1 {} {}
+ gb1988 F5 replace \uFFFD -1 {} {}
+ gb1988 F5 strict {} 0 {} {}
+ gb1988 F6 tcl8 \U000000F6 -1 {} {}
+ gb1988 F6 replace \uFFFD -1 {} {}
+ gb1988 F6 strict {} 0 {} {}
+ gb1988 F7 tcl8 \U000000F7 -1 {} {}
+ gb1988 F7 replace \uFFFD -1 {} {}
+ gb1988 F7 strict {} 0 {} {}
+ gb1988 F8 tcl8 \U000000F8 -1 {} {}
+ gb1988 F8 replace \uFFFD -1 {} {}
+ gb1988 F8 strict {} 0 {} {}
+ gb1988 F9 tcl8 \U000000F9 -1 {} {}
+ gb1988 F9 replace \uFFFD -1 {} {}
+ gb1988 F9 strict {} 0 {} {}
+ gb1988 FA tcl8 \U000000FA -1 {} {}
+ gb1988 FA replace \uFFFD -1 {} {}
+ gb1988 FA strict {} 0 {} {}
+ gb1988 FB tcl8 \U000000FB -1 {} {}
+ gb1988 FB replace \uFFFD -1 {} {}
+ gb1988 FB strict {} 0 {} {}
+ gb1988 FC tcl8 \U000000FC -1 {} {}
+ gb1988 FC replace \uFFFD -1 {} {}
+ gb1988 FC strict {} 0 {} {}
+ gb1988 FD tcl8 \U000000FD -1 {} {}
+ gb1988 FD replace \uFFFD -1 {} {}
+ gb1988 FD strict {} 0 {} {}
+ gb1988 FE tcl8 \U000000FE -1 {} {}
+ gb1988 FE replace \uFFFD -1 {} {}
+ gb1988 FE strict {} 0 {} {}
+ gb1988 FF tcl8 \U000000FF -1 {} {}
+ gb1988 FF replace \uFFFD -1 {} {}
+ gb1988 FF strict {} 0 {} {}
+}; # gb1988
+
+# gb1988 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ gb1988 \U00000024 tcl8 1A -1 {} {}
+ gb1988 \U00000024 replace 1A -1 {} {}
+ gb1988 \U00000024 strict {} 0 {} {}
+ gb1988 \U00000400 tcl8 1A -1 {} {}
+ gb1988 \U00000400 replace 1A -1 {} {}
+ gb1988 \U00000400 strict {} 0 {} {}
+ gb1988 \U0000D800 tcl8 1A -1 {} {}
+ gb1988 \U0000D800 replace 1A -1 {} {}
+ gb1988 \U0000D800 strict {} 0 {} {}
+ gb1988 \U0000DC00 tcl8 1A -1 {} {}
+ gb1988 \U0000DC00 replace 1A -1 {} {}
+ gb1988 \U0000DC00 strict {} 0 {} {}
+ gb1988 \U00010000 tcl8 1A -1 {} {}
+ gb1988 \U00010000 replace 1A -1 {} {}
+ gb1988 \U00010000 strict {} 0 {} {}
+ gb1988 \U0010FFFF tcl8 1A -1 {} {}
+ gb1988 \U0010FFFF replace 1A -1 {} {}
+ gb1988 \U0010FFFF strict {} 0 {} {}
+}; # gb1988
+
+#
+# iso8859-1 (generated from glibc-ISO_8859_1-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-1 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-1 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF}
+} -result {}
+
+# iso8859-1 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-1
+
+# iso8859-1 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-1 \U00000400 tcl8 1A -1 {} {}
+ iso8859-1 \U00000400 replace 1A -1 {} {}
+ iso8859-1 \U00000400 strict {} 0 {} {}
+ iso8859-1 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-1 \U0000D800 replace 1A -1 {} {}
+ iso8859-1 \U0000D800 strict {} 0 {} {}
+ iso8859-1 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-1 \U0000DC00 replace 1A -1 {} {}
+ iso8859-1 \U0000DC00 strict {} 0 {} {}
+ iso8859-1 \U00010000 tcl8 1A -1 {} {}
+ iso8859-1 \U00010000 replace 1A -1 {} {}
+ iso8859-1 \U00010000 strict {} 0 {} {}
+ iso8859-1 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-1 \U0010FFFF replace 1A -1 {} {}
+ iso8859-1 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-1
+
+#
+# iso8859-2 (generated from glibc-ISO_8859_2-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-2 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-2 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD}
+} -result {}
+
+# iso8859-2 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-2
+
+# iso8859-2 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-2 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-2 \U000000A1 replace 1A -1 {} {}
+ iso8859-2 \U000000A1 strict {} 0 {} {}
+ iso8859-2 \U00000400 tcl8 1A -1 {} {}
+ iso8859-2 \U00000400 replace 1A -1 {} {}
+ iso8859-2 \U00000400 strict {} 0 {} {}
+ iso8859-2 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-2 \U0000D800 replace 1A -1 {} {}
+ iso8859-2 \U0000D800 strict {} 0 {} {}
+ iso8859-2 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-2 \U0000DC00 replace 1A -1 {} {}
+ iso8859-2 \U0000DC00 strict {} 0 {} {}
+ iso8859-2 \U00010000 tcl8 1A -1 {} {}
+ iso8859-2 \U00010000 replace 1A -1 {} {}
+ iso8859-2 \U00010000 strict {} 0 {} {}
+ iso8859-2 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-2 \U0010FFFF replace 1A -1 {} {}
+ iso8859-2 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-2
+
+#
+# iso8859-3 (generated from glibc-ISO_8859_3-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-3 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-3 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF}
+} -result {}
+
+# iso8859-3 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ iso8859-3 A5 tcl8 \U000000A5 -1 {} {}
+ iso8859-3 A5 replace \uFFFD -1 {} {}
+ iso8859-3 A5 strict {} 0 {} {}
+ iso8859-3 AE tcl8 \U000000AE -1 {} {}
+ iso8859-3 AE replace \uFFFD -1 {} {}
+ iso8859-3 AE strict {} 0 {} {}
+ iso8859-3 BE tcl8 \U000000BE -1 {} {}
+ iso8859-3 BE replace \uFFFD -1 {} {}
+ iso8859-3 BE strict {} 0 {} {}
+ iso8859-3 C3 tcl8 \U000000C3 -1 {} {}
+ iso8859-3 C3 replace \uFFFD -1 {} {}
+ iso8859-3 C3 strict {} 0 {} {}
+ iso8859-3 D0 tcl8 \U000000D0 -1 {} {}
+ iso8859-3 D0 replace \uFFFD -1 {} {}
+ iso8859-3 D0 strict {} 0 {} {}
+ iso8859-3 E3 tcl8 \U000000E3 -1 {} {}
+ iso8859-3 E3 replace \uFFFD -1 {} {}
+ iso8859-3 E3 strict {} 0 {} {}
+ iso8859-3 F0 tcl8 \U000000F0 -1 {} {}
+ iso8859-3 F0 replace \uFFFD -1 {} {}
+ iso8859-3 F0 strict {} 0 {} {}
+}; # iso8859-3
+
+# iso8859-3 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-3 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-3 \U000000A1 replace 1A -1 {} {}
+ iso8859-3 \U000000A1 strict {} 0 {} {}
+ iso8859-3 \U00000400 tcl8 1A -1 {} {}
+ iso8859-3 \U00000400 replace 1A -1 {} {}
+ iso8859-3 \U00000400 strict {} 0 {} {}
+ iso8859-3 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-3 \U0000D800 replace 1A -1 {} {}
+ iso8859-3 \U0000D800 strict {} 0 {} {}
+ iso8859-3 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-3 \U0000DC00 replace 1A -1 {} {}
+ iso8859-3 \U0000DC00 strict {} 0 {} {}
+ iso8859-3 \U00010000 tcl8 1A -1 {} {}
+ iso8859-3 \U00010000 replace 1A -1 {} {}
+ iso8859-3 \U00010000 strict {} 0 {} {}
+ iso8859-3 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-3 \U0010FFFF replace 1A -1 {} {}
+ iso8859-3 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-3
+
+#
+# iso8859-4 (generated from glibc-ISO_8859_4-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-4 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-4 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2}
+} -result {}
+
+# iso8859-4 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-4
+
+# iso8859-4 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-4 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-4 \U000000A1 replace 1A -1 {} {}
+ iso8859-4 \U000000A1 strict {} 0 {} {}
+ iso8859-4 \U00000400 tcl8 1A -1 {} {}
+ iso8859-4 \U00000400 replace 1A -1 {} {}
+ iso8859-4 \U00000400 strict {} 0 {} {}
+ iso8859-4 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-4 \U0000D800 replace 1A -1 {} {}
+ iso8859-4 \U0000D800 strict {} 0 {} {}
+ iso8859-4 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-4 \U0000DC00 replace 1A -1 {} {}
+ iso8859-4 \U0000DC00 strict {} 0 {} {}
+ iso8859-4 \U00010000 tcl8 1A -1 {} {}
+ iso8859-4 \U00010000 replace 1A -1 {} {}
+ iso8859-4 \U00010000 strict {} 0 {} {}
+ iso8859-4 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-4 \U0010FFFF replace 1A -1 {} {}
+ iso8859-4 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-4
+
+#
+# iso8859-5 (generated from glibc-ISO_8859_5-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-5 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-5 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0}
+} -result {}
+
+# iso8859-5 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-5
+
+# iso8859-5 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-5 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-5 \U000000A1 replace 1A -1 {} {}
+ iso8859-5 \U000000A1 strict {} 0 {} {}
+ iso8859-5 \U00000400 tcl8 1A -1 {} {}
+ iso8859-5 \U00000400 replace 1A -1 {} {}
+ iso8859-5 \U00000400 strict {} 0 {} {}
+ iso8859-5 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-5 \U0000D800 replace 1A -1 {} {}
+ iso8859-5 \U0000D800 strict {} 0 {} {}
+ iso8859-5 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-5 \U0000DC00 replace 1A -1 {} {}
+ iso8859-5 \U0000DC00 strict {} 0 {} {}
+ iso8859-5 \U00010000 tcl8 1A -1 {} {}
+ iso8859-5 \U00010000 replace 1A -1 {} {}
+ iso8859-5 \U00010000 strict {} 0 {} {}
+ iso8859-5 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-5 \U0010FFFF replace 1A -1 {} {}
+ iso8859-5 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-5
+
+#
+# iso8859-6 (generated from glibc-ISO_8859_6-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-6 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-6 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2}
+} -result {}
+
+# iso8859-6 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ iso8859-6 A1 tcl8 \U000000A1 -1 {} {}
+ iso8859-6 A1 replace \uFFFD -1 {} {}
+ iso8859-6 A1 strict {} 0 {} {}
+ iso8859-6 A2 tcl8 \U000000A2 -1 {} {}
+ iso8859-6 A2 replace \uFFFD -1 {} {}
+ iso8859-6 A2 strict {} 0 {} {}
+ iso8859-6 A3 tcl8 \U000000A3 -1 {} {}
+ iso8859-6 A3 replace \uFFFD -1 {} {}
+ iso8859-6 A3 strict {} 0 {} {}
+ iso8859-6 A5 tcl8 \U000000A5 -1 {} {}
+ iso8859-6 A5 replace \uFFFD -1 {} {}
+ iso8859-6 A5 strict {} 0 {} {}
+ iso8859-6 A6 tcl8 \U000000A6 -1 {} {}
+ iso8859-6 A6 replace \uFFFD -1 {} {}
+ iso8859-6 A6 strict {} 0 {} {}
+ iso8859-6 A7 tcl8 \U000000A7 -1 {} {}
+ iso8859-6 A7 replace \uFFFD -1 {} {}
+ iso8859-6 A7 strict {} 0 {} {}
+ iso8859-6 A8 tcl8 \U000000A8 -1 {} {}
+ iso8859-6 A8 replace \uFFFD -1 {} {}
+ iso8859-6 A8 strict {} 0 {} {}
+ iso8859-6 A9 tcl8 \U000000A9 -1 {} {}
+ iso8859-6 A9 replace \uFFFD -1 {} {}
+ iso8859-6 A9 strict {} 0 {} {}
+ iso8859-6 AA tcl8 \U000000AA -1 {} {}
+ iso8859-6 AA replace \uFFFD -1 {} {}
+ iso8859-6 AA strict {} 0 {} {}
+ iso8859-6 AB tcl8 \U000000AB -1 {} {}
+ iso8859-6 AB replace \uFFFD -1 {} {}
+ iso8859-6 AB strict {} 0 {} {}
+ iso8859-6 AE tcl8 \U000000AE -1 {} {}
+ iso8859-6 AE replace \uFFFD -1 {} {}
+ iso8859-6 AE strict {} 0 {} {}
+ iso8859-6 AF tcl8 \U000000AF -1 {} {}
+ iso8859-6 AF replace \uFFFD -1 {} {}
+ iso8859-6 AF strict {} 0 {} {}
+ iso8859-6 B0 tcl8 \U000000B0 -1 {} {}
+ iso8859-6 B0 replace \uFFFD -1 {} {}
+ iso8859-6 B0 strict {} 0 {} {}
+ iso8859-6 B1 tcl8 \U000000B1 -1 {} {}
+ iso8859-6 B1 replace \uFFFD -1 {} {}
+ iso8859-6 B1 strict {} 0 {} {}
+ iso8859-6 B2 tcl8 \U000000B2 -1 {} {}
+ iso8859-6 B2 replace \uFFFD -1 {} {}
+ iso8859-6 B2 strict {} 0 {} {}
+ iso8859-6 B3 tcl8 \U000000B3 -1 {} {}
+ iso8859-6 B3 replace \uFFFD -1 {} {}
+ iso8859-6 B3 strict {} 0 {} {}
+ iso8859-6 B4 tcl8 \U000000B4 -1 {} {}
+ iso8859-6 B4 replace \uFFFD -1 {} {}
+ iso8859-6 B4 strict {} 0 {} {}
+ iso8859-6 B5 tcl8 \U000000B5 -1 {} {}
+ iso8859-6 B5 replace \uFFFD -1 {} {}
+ iso8859-6 B5 strict {} 0 {} {}
+ iso8859-6 B6 tcl8 \U000000B6 -1 {} {}
+ iso8859-6 B6 replace \uFFFD -1 {} {}
+ iso8859-6 B6 strict {} 0 {} {}
+ iso8859-6 B7 tcl8 \U000000B7 -1 {} {}
+ iso8859-6 B7 replace \uFFFD -1 {} {}
+ iso8859-6 B7 strict {} 0 {} {}
+ iso8859-6 B8 tcl8 \U000000B8 -1 {} {}
+ iso8859-6 B8 replace \uFFFD -1 {} {}
+ iso8859-6 B8 strict {} 0 {} {}
+ iso8859-6 B9 tcl8 \U000000B9 -1 {} {}
+ iso8859-6 B9 replace \uFFFD -1 {} {}
+ iso8859-6 B9 strict {} 0 {} {}
+ iso8859-6 BA tcl8 \U000000BA -1 {} {}
+ iso8859-6 BA replace \uFFFD -1 {} {}
+ iso8859-6 BA strict {} 0 {} {}
+ iso8859-6 BC tcl8 \U000000BC -1 {} {}
+ iso8859-6 BC replace \uFFFD -1 {} {}
+ iso8859-6 BC strict {} 0 {} {}
+ iso8859-6 BD tcl8 \U000000BD -1 {} {}
+ iso8859-6 BD replace \uFFFD -1 {} {}
+ iso8859-6 BD strict {} 0 {} {}
+ iso8859-6 BE tcl8 \U000000BE -1 {} {}
+ iso8859-6 BE replace \uFFFD -1 {} {}
+ iso8859-6 BE strict {} 0 {} {}
+ iso8859-6 C0 tcl8 \U000000C0 -1 {} {}
+ iso8859-6 C0 replace \uFFFD -1 {} {}
+ iso8859-6 C0 strict {} 0 {} {}
+ iso8859-6 DB tcl8 \U000000DB -1 {} {}
+ iso8859-6 DB replace \uFFFD -1 {} {}
+ iso8859-6 DB strict {} 0 {} {}
+ iso8859-6 DC tcl8 \U000000DC -1 {} {}
+ iso8859-6 DC replace \uFFFD -1 {} {}
+ iso8859-6 DC strict {} 0 {} {}
+ iso8859-6 DD tcl8 \U000000DD -1 {} {}
+ iso8859-6 DD replace \uFFFD -1 {} {}
+ iso8859-6 DD strict {} 0 {} {}
+ iso8859-6 DE tcl8 \U000000DE -1 {} {}
+ iso8859-6 DE replace \uFFFD -1 {} {}
+ iso8859-6 DE strict {} 0 {} {}
+ iso8859-6 DF tcl8 \U000000DF -1 {} {}
+ iso8859-6 DF replace \uFFFD -1 {} {}
+ iso8859-6 DF strict {} 0 {} {}
+ iso8859-6 F3 tcl8 \U000000F3 -1 {} {}
+ iso8859-6 F3 replace \uFFFD -1 {} {}
+ iso8859-6 F3 strict {} 0 {} {}
+ iso8859-6 F4 tcl8 \U000000F4 -1 {} {}
+ iso8859-6 F4 replace \uFFFD -1 {} {}
+ iso8859-6 F4 strict {} 0 {} {}
+ iso8859-6 F5 tcl8 \U000000F5 -1 {} {}
+ iso8859-6 F5 replace \uFFFD -1 {} {}
+ iso8859-6 F5 strict {} 0 {} {}
+ iso8859-6 F6 tcl8 \U000000F6 -1 {} {}
+ iso8859-6 F6 replace \uFFFD -1 {} {}
+ iso8859-6 F6 strict {} 0 {} {}
+ iso8859-6 F7 tcl8 \U000000F7 -1 {} {}
+ iso8859-6 F7 replace \uFFFD -1 {} {}
+ iso8859-6 F7 strict {} 0 {} {}
+ iso8859-6 F8 tcl8 \U000000F8 -1 {} {}
+ iso8859-6 F8 replace \uFFFD -1 {} {}
+ iso8859-6 F8 strict {} 0 {} {}
+ iso8859-6 F9 tcl8 \U000000F9 -1 {} {}
+ iso8859-6 F9 replace \uFFFD -1 {} {}
+ iso8859-6 F9 strict {} 0 {} {}
+ iso8859-6 FA tcl8 \U000000FA -1 {} {}
+ iso8859-6 FA replace \uFFFD -1 {} {}
+ iso8859-6 FA strict {} 0 {} {}
+ iso8859-6 FB tcl8 \U000000FB -1 {} {}
+ iso8859-6 FB replace \uFFFD -1 {} {}
+ iso8859-6 FB strict {} 0 {} {}
+ iso8859-6 FC tcl8 \U000000FC -1 {} {}
+ iso8859-6 FC replace \uFFFD -1 {} {}
+ iso8859-6 FC strict {} 0 {} {}
+ iso8859-6 FD tcl8 \U000000FD -1 {} {}
+ iso8859-6 FD replace \uFFFD -1 {} {}
+ iso8859-6 FD strict {} 0 {} {}
+ iso8859-6 FE tcl8 \U000000FE -1 {} {}
+ iso8859-6 FE replace \uFFFD -1 {} {}
+ iso8859-6 FE strict {} 0 {} {}
+ iso8859-6 FF tcl8 \U000000FF -1 {} {}
+ iso8859-6 FF replace \uFFFD -1 {} {}
+ iso8859-6 FF strict {} 0 {} {}
+}; # iso8859-6
+
+# iso8859-6 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-6 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-6 \U000000A1 replace 1A -1 {} {}
+ iso8859-6 \U000000A1 strict {} 0 {} {}
+ iso8859-6 \U00000400 tcl8 1A -1 {} {}
+ iso8859-6 \U00000400 replace 1A -1 {} {}
+ iso8859-6 \U00000400 strict {} 0 {} {}
+ iso8859-6 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-6 \U0000D800 replace 1A -1 {} {}
+ iso8859-6 \U0000D800 strict {} 0 {} {}
+ iso8859-6 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-6 \U0000DC00 replace 1A -1 {} {}
+ iso8859-6 \U0000DC00 strict {} 0 {} {}
+ iso8859-6 \U00010000 tcl8 1A -1 {} {}
+ iso8859-6 \U00010000 replace 1A -1 {} {}
+ iso8859-6 \U00010000 strict {} 0 {} {}
+ iso8859-6 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-6 \U0010FFFF replace 1A -1 {} {}
+ iso8859-6 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-6
+
+#
+# iso8859-7 (generated from glibc-ISO_8859_7-2.3.3)
+
+test encoding-convertfrom-ucmCompare-iso8859-7 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-7 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5}
+} -result {}
+
+# iso8859-7 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ iso8859-7 AE tcl8 \U000000AE -1 {} {}
+ iso8859-7 AE replace \uFFFD -1 {} {}
+ iso8859-7 AE strict {} 0 {} {}
+ iso8859-7 D2 tcl8 \U000000D2 -1 {} {}
+ iso8859-7 D2 replace \uFFFD -1 {} {}
+ iso8859-7 D2 strict {} 0 {} {}
+ iso8859-7 FF tcl8 \U000000FF -1 {} {}
+ iso8859-7 FF replace \uFFFD -1 {} {}
+ iso8859-7 FF strict {} 0 {} {}
+}; # iso8859-7
+
+# iso8859-7 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-7 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-7 \U000000A1 replace 1A -1 {} {}
+ iso8859-7 \U000000A1 strict {} 0 {} {}
+ iso8859-7 \U00000400 tcl8 1A -1 {} {}
+ iso8859-7 \U00000400 replace 1A -1 {} {}
+ iso8859-7 \U00000400 strict {} 0 {} {}
+ iso8859-7 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-7 \U0000D800 replace 1A -1 {} {}
+ iso8859-7 \U0000D800 strict {} 0 {} {}
+ iso8859-7 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-7 \U0000DC00 replace 1A -1 {} {}
+ iso8859-7 \U0000DC00 strict {} 0 {} {}
+ iso8859-7 \U00010000 tcl8 1A -1 {} {}
+ iso8859-7 \U00010000 replace 1A -1 {} {}
+ iso8859-7 \U00010000 strict {} 0 {} {}
+ iso8859-7 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-7 \U0010FFFF replace 1A -1 {} {}
+ iso8859-7 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-7
+
+#
+# iso8859-8 (generated from glibc-ISO_8859_8-2.3.3)
+
+test encoding-convertfrom-ucmCompare-iso8859-8 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-8 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF}
+} -result {}
+
+# iso8859-8 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ iso8859-8 A1 tcl8 \U000000A1 -1 {} {}
+ iso8859-8 A1 replace \uFFFD -1 {} {}
+ iso8859-8 A1 strict {} 0 {} {}
+ iso8859-8 BF tcl8 \U000000BF -1 {} {}
+ iso8859-8 BF replace \uFFFD -1 {} {}
+ iso8859-8 BF strict {} 0 {} {}
+ iso8859-8 C0 tcl8 \U000000C0 -1 {} {}
+ iso8859-8 C0 replace \uFFFD -1 {} {}
+ iso8859-8 C0 strict {} 0 {} {}
+ iso8859-8 C1 tcl8 \U000000C1 -1 {} {}
+ iso8859-8 C1 replace \uFFFD -1 {} {}
+ iso8859-8 C1 strict {} 0 {} {}
+ iso8859-8 C2 tcl8 \U000000C2 -1 {} {}
+ iso8859-8 C2 replace \uFFFD -1 {} {}
+ iso8859-8 C2 strict {} 0 {} {}
+ iso8859-8 C3 tcl8 \U000000C3 -1 {} {}
+ iso8859-8 C3 replace \uFFFD -1 {} {}
+ iso8859-8 C3 strict {} 0 {} {}
+ iso8859-8 C4 tcl8 \U000000C4 -1 {} {}
+ iso8859-8 C4 replace \uFFFD -1 {} {}
+ iso8859-8 C4 strict {} 0 {} {}
+ iso8859-8 C5 tcl8 \U000000C5 -1 {} {}
+ iso8859-8 C5 replace \uFFFD -1 {} {}
+ iso8859-8 C5 strict {} 0 {} {}
+ iso8859-8 C6 tcl8 \U000000C6 -1 {} {}
+ iso8859-8 C6 replace \uFFFD -1 {} {}
+ iso8859-8 C6 strict {} 0 {} {}
+ iso8859-8 C7 tcl8 \U000000C7 -1 {} {}
+ iso8859-8 C7 replace \uFFFD -1 {} {}
+ iso8859-8 C7 strict {} 0 {} {}
+ iso8859-8 C8 tcl8 \U000000C8 -1 {} {}
+ iso8859-8 C8 replace \uFFFD -1 {} {}
+ iso8859-8 C8 strict {} 0 {} {}
+ iso8859-8 C9 tcl8 \U000000C9 -1 {} {}
+ iso8859-8 C9 replace \uFFFD -1 {} {}
+ iso8859-8 C9 strict {} 0 {} {}
+ iso8859-8 CA tcl8 \U000000CA -1 {} {}
+ iso8859-8 CA replace \uFFFD -1 {} {}
+ iso8859-8 CA strict {} 0 {} {}
+ iso8859-8 CB tcl8 \U000000CB -1 {} {}
+ iso8859-8 CB replace \uFFFD -1 {} {}
+ iso8859-8 CB strict {} 0 {} {}
+ iso8859-8 CC tcl8 \U000000CC -1 {} {}
+ iso8859-8 CC replace \uFFFD -1 {} {}
+ iso8859-8 CC strict {} 0 {} {}
+ iso8859-8 CD tcl8 \U000000CD -1 {} {}
+ iso8859-8 CD replace \uFFFD -1 {} {}
+ iso8859-8 CD strict {} 0 {} {}
+ iso8859-8 CE tcl8 \U000000CE -1 {} {}
+ iso8859-8 CE replace \uFFFD -1 {} {}
+ iso8859-8 CE strict {} 0 {} {}
+ iso8859-8 CF tcl8 \U000000CF -1 {} {}
+ iso8859-8 CF replace \uFFFD -1 {} {}
+ iso8859-8 CF strict {} 0 {} {}
+ iso8859-8 D0 tcl8 \U000000D0 -1 {} {}
+ iso8859-8 D0 replace \uFFFD -1 {} {}
+ iso8859-8 D0 strict {} 0 {} {}
+ iso8859-8 D1 tcl8 \U000000D1 -1 {} {}
+ iso8859-8 D1 replace \uFFFD -1 {} {}
+ iso8859-8 D1 strict {} 0 {} {}
+ iso8859-8 D2 tcl8 \U000000D2 -1 {} {}
+ iso8859-8 D2 replace \uFFFD -1 {} {}
+ iso8859-8 D2 strict {} 0 {} {}
+ iso8859-8 D3 tcl8 \U000000D3 -1 {} {}
+ iso8859-8 D3 replace \uFFFD -1 {} {}
+ iso8859-8 D3 strict {} 0 {} {}
+ iso8859-8 D4 tcl8 \U000000D4 -1 {} {}
+ iso8859-8 D4 replace \uFFFD -1 {} {}
+ iso8859-8 D4 strict {} 0 {} {}
+ iso8859-8 D5 tcl8 \U000000D5 -1 {} {}
+ iso8859-8 D5 replace \uFFFD -1 {} {}
+ iso8859-8 D5 strict {} 0 {} {}
+ iso8859-8 D6 tcl8 \U000000D6 -1 {} {}
+ iso8859-8 D6 replace \uFFFD -1 {} {}
+ iso8859-8 D6 strict {} 0 {} {}
+ iso8859-8 D7 tcl8 \U000000D7 -1 {} {}
+ iso8859-8 D7 replace \uFFFD -1 {} {}
+ iso8859-8 D7 strict {} 0 {} {}
+ iso8859-8 D8 tcl8 \U000000D8 -1 {} {}
+ iso8859-8 D8 replace \uFFFD -1 {} {}
+ iso8859-8 D8 strict {} 0 {} {}
+ iso8859-8 D9 tcl8 \U000000D9 -1 {} {}
+ iso8859-8 D9 replace \uFFFD -1 {} {}
+ iso8859-8 D9 strict {} 0 {} {}
+ iso8859-8 DA tcl8 \U000000DA -1 {} {}
+ iso8859-8 DA replace \uFFFD -1 {} {}
+ iso8859-8 DA strict {} 0 {} {}
+ iso8859-8 DB tcl8 \U000000DB -1 {} {}
+ iso8859-8 DB replace \uFFFD -1 {} {}
+ iso8859-8 DB strict {} 0 {} {}
+ iso8859-8 DC tcl8 \U000000DC -1 {} {}
+ iso8859-8 DC replace \uFFFD -1 {} {}
+ iso8859-8 DC strict {} 0 {} {}
+ iso8859-8 DD tcl8 \U000000DD -1 {} {}
+ iso8859-8 DD replace \uFFFD -1 {} {}
+ iso8859-8 DD strict {} 0 {} {}
+ iso8859-8 DE tcl8 \U000000DE -1 {} {}
+ iso8859-8 DE replace \uFFFD -1 {} {}
+ iso8859-8 DE strict {} 0 {} {}
+ iso8859-8 FB tcl8 \U000000FB -1 {} {}
+ iso8859-8 FB replace \uFFFD -1 {} {}
+ iso8859-8 FB strict {} 0 {} {}
+ iso8859-8 FC tcl8 \U000000FC -1 {} {}
+ iso8859-8 FC replace \uFFFD -1 {} {}
+ iso8859-8 FC strict {} 0 {} {}
+ iso8859-8 FF tcl8 \U000000FF -1 {} {}
+ iso8859-8 FF replace \uFFFD -1 {} {}
+ iso8859-8 FF strict {} 0 {} {}
+}; # iso8859-8
+
+# iso8859-8 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-8 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-8 \U000000A1 replace 1A -1 {} {}
+ iso8859-8 \U000000A1 strict {} 0 {} {}
+ iso8859-8 \U00000400 tcl8 1A -1 {} {}
+ iso8859-8 \U00000400 replace 1A -1 {} {}
+ iso8859-8 \U00000400 strict {} 0 {} {}
+ iso8859-8 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-8 \U0000D800 replace 1A -1 {} {}
+ iso8859-8 \U0000D800 strict {} 0 {} {}
+ iso8859-8 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-8 \U0000DC00 replace 1A -1 {} {}
+ iso8859-8 \U0000DC00 strict {} 0 {} {}
+ iso8859-8 \U00010000 tcl8 1A -1 {} {}
+ iso8859-8 \U00010000 replace 1A -1 {} {}
+ iso8859-8 \U00010000 strict {} 0 {} {}
+ iso8859-8 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-8 \U0010FFFF replace 1A -1 {} {}
+ iso8859-8 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-8
+
+#
+# iso8859-9 (generated from glibc-ISO_8859_9-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-9 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-9 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE}
+} -result {}
+
+# iso8859-9 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-9
+
+# iso8859-9 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-9 \U000000D0 tcl8 1A -1 {} {}
+ iso8859-9 \U000000D0 replace 1A -1 {} {}
+ iso8859-9 \U000000D0 strict {} 0 {} {}
+ iso8859-9 \U00000400 tcl8 1A -1 {} {}
+ iso8859-9 \U00000400 replace 1A -1 {} {}
+ iso8859-9 \U00000400 strict {} 0 {} {}
+ iso8859-9 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-9 \U0000D800 replace 1A -1 {} {}
+ iso8859-9 \U0000D800 strict {} 0 {} {}
+ iso8859-9 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-9 \U0000DC00 replace 1A -1 {} {}
+ iso8859-9 \U0000DC00 strict {} 0 {} {}
+ iso8859-9 \U00010000 tcl8 1A -1 {} {}
+ iso8859-9 \U00010000 replace 1A -1 {} {}
+ iso8859-9 \U00010000 strict {} 0 {} {}
+ iso8859-9 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-9 \U0010FFFF replace 1A -1 {} {}
+ iso8859-9 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-9
+
+#
+# iso8859-10 (generated from glibc-ISO_8859_10-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-10 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-10 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD}
+} -result {}
+
+# iso8859-10 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-10
+
+# iso8859-10 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-10 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-10 \U000000A1 replace 1A -1 {} {}
+ iso8859-10 \U000000A1 strict {} 0 {} {}
+ iso8859-10 \U00000400 tcl8 1A -1 {} {}
+ iso8859-10 \U00000400 replace 1A -1 {} {}
+ iso8859-10 \U00000400 strict {} 0 {} {}
+ iso8859-10 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-10 \U0000D800 replace 1A -1 {} {}
+ iso8859-10 \U0000D800 strict {} 0 {} {}
+ iso8859-10 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-10 \U0000DC00 replace 1A -1 {} {}
+ iso8859-10 \U0000DC00 strict {} 0 {} {}
+ iso8859-10 \U00010000 tcl8 1A -1 {} {}
+ iso8859-10 \U00010000 replace 1A -1 {} {}
+ iso8859-10 \U00010000 strict {} 0 {} {}
+ iso8859-10 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-10 \U0010FFFF replace 1A -1 {} {}
+ iso8859-10 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-10
+
+#
+# iso8859-11 (generated from glibc-ISO_8859_11-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-11 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-11 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB}
+} -result {}
+
+# iso8859-11 - invalid byte sequences
+lappend encInvalidBytes {*}{
+ iso8859-11 DB tcl8 \U000000DB -1 {} {}
+ iso8859-11 DB replace \uFFFD -1 {} {}
+ iso8859-11 DB strict {} 0 {} {}
+ iso8859-11 DC tcl8 \U000000DC -1 {} {}
+ iso8859-11 DC replace \uFFFD -1 {} {}
+ iso8859-11 DC strict {} 0 {} {}
+ iso8859-11 DD tcl8 \U000000DD -1 {} {}
+ iso8859-11 DD replace \uFFFD -1 {} {}
+ iso8859-11 DD strict {} 0 {} {}
+ iso8859-11 DE tcl8 \U000000DE -1 {} {}
+ iso8859-11 DE replace \uFFFD -1 {} {}
+ iso8859-11 DE strict {} 0 {} {}
+ iso8859-11 FC tcl8 \U000000FC -1 {} {}
+ iso8859-11 FC replace \uFFFD -1 {} {}
+ iso8859-11 FC strict {} 0 {} {}
+ iso8859-11 FD tcl8 \U000000FD -1 {} {}
+ iso8859-11 FD replace \uFFFD -1 {} {}
+ iso8859-11 FD strict {} 0 {} {}
+ iso8859-11 FE tcl8 \U000000FE -1 {} {}
+ iso8859-11 FE replace \uFFFD -1 {} {}
+ iso8859-11 FE strict {} 0 {} {}
+ iso8859-11 FF tcl8 \U000000FF -1 {} {}
+ iso8859-11 FF replace \uFFFD -1 {} {}
+ iso8859-11 FF strict {} 0 {} {}
+}; # iso8859-11
+
+# iso8859-11 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-11 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-11 \U000000A1 replace 1A -1 {} {}
+ iso8859-11 \U000000A1 strict {} 0 {} {}
+ iso8859-11 \U00000400 tcl8 1A -1 {} {}
+ iso8859-11 \U00000400 replace 1A -1 {} {}
+ iso8859-11 \U00000400 strict {} 0 {} {}
+ iso8859-11 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-11 \U0000D800 replace 1A -1 {} {}
+ iso8859-11 \U0000D800 strict {} 0 {} {}
+ iso8859-11 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-11 \U0000DC00 replace 1A -1 {} {}
+ iso8859-11 \U0000DC00 strict {} 0 {} {}
+ iso8859-11 \U00010000 tcl8 1A -1 {} {}
+ iso8859-11 \U00010000 replace 1A -1 {} {}
+ iso8859-11 \U00010000 strict {} 0 {} {}
+ iso8859-11 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-11 \U0010FFFF replace 1A -1 {} {}
+ iso8859-11 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-11
+
+#
+# iso8859-13 (generated from glibc-ISO_8859_13-2.3.3)
+
+test encoding-convertfrom-ucmCompare-iso8859-13 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-13 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5}
+} -result {}
+
+# iso8859-13 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-13
+
+# iso8859-13 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-13 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-13 \U000000A1 replace 1A -1 {} {}
+ iso8859-13 \U000000A1 strict {} 0 {} {}
+ iso8859-13 \U00000400 tcl8 1A -1 {} {}
+ iso8859-13 \U00000400 replace 1A -1 {} {}
+ iso8859-13 \U00000400 strict {} 0 {} {}
+ iso8859-13 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-13 \U0000D800 replace 1A -1 {} {}
+ iso8859-13 \U0000D800 strict {} 0 {} {}
+ iso8859-13 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-13 \U0000DC00 replace 1A -1 {} {}
+ iso8859-13 \U0000DC00 strict {} 0 {} {}
+ iso8859-13 \U00010000 tcl8 1A -1 {} {}
+ iso8859-13 \U00010000 replace 1A -1 {} {}
+ iso8859-13 \U00010000 strict {} 0 {} {}
+ iso8859-13 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-13 \U0010FFFF replace 1A -1 {} {}
+ iso8859-13 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-13
+
+#
+# iso8859-14 (generated from glibc-ISO_8859_14-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-14 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-14 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC}
+} -result {}
+
+# iso8859-14 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-14
+
+# iso8859-14 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-14 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-14 \U000000A1 replace 1A -1 {} {}
+ iso8859-14 \U000000A1 strict {} 0 {} {}
+ iso8859-14 \U00000400 tcl8 1A -1 {} {}
+ iso8859-14 \U00000400 replace 1A -1 {} {}
+ iso8859-14 \U00000400 strict {} 0 {} {}
+ iso8859-14 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-14 \U0000D800 replace 1A -1 {} {}
+ iso8859-14 \U0000D800 strict {} 0 {} {}
+ iso8859-14 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-14 \U0000DC00 replace 1A -1 {} {}
+ iso8859-14 \U0000DC00 strict {} 0 {} {}
+ iso8859-14 \U00010000 tcl8 1A -1 {} {}
+ iso8859-14 \U00010000 replace 1A -1 {} {}
+ iso8859-14 \U00010000 strict {} 0 {} {}
+ iso8859-14 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-14 \U0010FFFF replace 1A -1 {} {}
+ iso8859-14 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-14
+
+#
+# iso8859-15 (generated from glibc-ISO_8859_15-2.1.2)
+
+test encoding-convertfrom-ucmCompare-iso8859-15 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-15 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4}
+} -result {}
+
+# iso8859-15 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-15
+
+# iso8859-15 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-15 \U000000A4 tcl8 1A -1 {} {}
+ iso8859-15 \U000000A4 replace 1A -1 {} {}
+ iso8859-15 \U000000A4 strict {} 0 {} {}
+ iso8859-15 \U00000400 tcl8 1A -1 {} {}
+ iso8859-15 \U00000400 replace 1A -1 {} {}
+ iso8859-15 \U00000400 strict {} 0 {} {}
+ iso8859-15 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-15 \U0000D800 replace 1A -1 {} {}
+ iso8859-15 \U0000D800 strict {} 0 {} {}
+ iso8859-15 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-15 \U0000DC00 replace 1A -1 {} {}
+ iso8859-15 \U0000DC00 strict {} 0 {} {}
+ iso8859-15 \U00010000 tcl8 1A -1 {} {}
+ iso8859-15 \U00010000 replace 1A -1 {} {}
+ iso8859-15 \U00010000 strict {} 0 {} {}
+ iso8859-15 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-15 \U0010FFFF replace 1A -1 {} {}
+ iso8859-15 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-15
+
+#
+# iso8859-16 (generated from glibc-ISO_8859_16-2.3.3)
+
+test encoding-convertfrom-ucmCompare-iso8859-16 {Compare against ICU UCM} -body {
+ ucmConvertfromMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4}
+} -result {}
+
+test encoding-convertto-ucmCompare-iso8859-16 {Compare against ICU UCM} -body {
+ ucmConverttoMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4}
+} -result {}
+
+# iso8859-16 - invalid byte sequences
+lappend encInvalidBytes {*}{
+}; # iso8859-16
+
+# iso8859-16 - invalid byte sequences
+lappend encUnencodableStrings {*}{
+ iso8859-16 \U000000A1 tcl8 1A -1 {} {}
+ iso8859-16 \U000000A1 replace 1A -1 {} {}
+ iso8859-16 \U000000A1 strict {} 0 {} {}
+ iso8859-16 \U00000400 tcl8 1A -1 {} {}
+ iso8859-16 \U00000400 replace 1A -1 {} {}
+ iso8859-16 \U00000400 strict {} 0 {} {}
+ iso8859-16 \U0000D800 tcl8 1A -1 {} {}
+ iso8859-16 \U0000D800 replace 1A -1 {} {}
+ iso8859-16 \U0000D800 strict {} 0 {} {}
+ iso8859-16 \U0000DC00 tcl8 1A -1 {} {}
+ iso8859-16 \U0000DC00 replace 1A -1 {} {}
+ iso8859-16 \U0000DC00 strict {} 0 {} {}
+ iso8859-16 \U00010000 tcl8 1A -1 {} {}
+ iso8859-16 \U00010000 replace 1A -1 {} {}
+ iso8859-16 \U00010000 strict {} 0 {} {}
+ iso8859-16 \U0010FFFF tcl8 1A -1 {} {}
+ iso8859-16 \U0010FFFF replace 1A -1 {} {}
+ iso8859-16 \U0010FFFF strict {} 0 {} {}
+}; # iso8859-16
diff --git a/tests/if-old.test b/tests/if-old.test
index e537fea..378c8a6 100644
--- a/tests/if-old.test
+++ b/tests/if-old.test
@@ -6,9 +6,9 @@
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/if.test b/tests/if.test
index f718dcb..a1399a0 100644
--- a/tests/if.test
+++ b/tests/if.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/incr-old.test b/tests/incr-old.test
index 5d792e1..662fdc7 100644
--- a/tests/incr-old.test
+++ b/tests/incr-old.test
@@ -6,9 +6,9 @@
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -63,7 +63,7 @@ test incr-old-2.5 {incr errors} {
test incr-old-2.6 {incr errors} -body {
proc readonly args {error "variable is read-only"}
set x 123
- trace var x w readonly
+ trace add var x write readonly
list [catch {incr x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
diff --git a/tests/incr.test b/tests/incr.test
index af15f5e..04c3652 100644
--- a/tests/incr.test
+++ b/tests/incr.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} {
(reading increment)
invoked from within
"incr x 1a"}}
+test incr-2.32 {incr command (compiled): bad pure list increment} {
+ list [catch {incr x [list 1 2]} msg] $msg $::errorInfo
+} {1 {expected integer but got "1 2"} {expected integer but got "1 2"
+ (reading increment)
+ invoked from within
+"incr x [list 1 2]"}}
+test incr-2.33 {incr command (compiled): bad pure dict increment} {
+ list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo
+} {1 {expected integer but got "1 2"} {expected integer but got "1 2"
+ (reading increment)
+ invoked from within
+"incr x [dict create 1 2]"}}
test incr-3.1 {increment by wide amount: bytecode route} {
set x 0
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 6be0eb4..1cf782a 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -2,8 +2,8 @@
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -14,9 +14,10 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testindexobj [llength [info commands testindexobj]]
+testConstraint testgetintforindex [llength [info commands testgetintforindex]]
testConstraint testparseargs [llength [info commands testparseargs]]
test indexObj-1.1 {exact match} testindexobj {
@@ -109,7 +110,7 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj {
} {wrong # args: should be "mycmd foo"}
# Contrast this with test proc-3.6; they have to be like this because
# of [Bug 1066837] so Itcl won't break.
-test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj {
+test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} {
testwrongnumargs 2 "fee fi" "fo fum" foo bar
} {wrong # args: should be "fo fum foo fee fi"}
@@ -139,6 +140,10 @@ test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testi
set x ""
testgetindexfromobjstruct $x 0
} -returnCodes error -result {ambiguous dummy "": must be a, c, or ee}
+test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj {
+ set x ""
+ testgetindexfromobjstruct $x -1 32
+} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\""
test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
testparseargs
@@ -165,6 +170,58 @@ test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
+test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex {
+ testgetintforindex 0 0
+} 0
+test indexObj-8.2 {Tcl_GetIntForIndex integer} testgetintforindex {
+ testgetintforindex -1 0
+} -1
+test indexObj-8.3 {Tcl_GetIntForIndex integer} testgetintforindex {
+ testgetintforindex -2 0
+} -1
+test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex {
+ testgetintforindex 2147483647 0
+} 2147483647
+test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex {
+ testgetintforindex 2147483648 0
+} 2147483647
+test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex {
+ testgetintforindex end-1 2147483646
+} 2147483645
+test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex {
+ testgetintforindex end-1 2147483647
+} 2147483646
+test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex {
+ testgetintforindex end 2147483646
+} 2147483646
+test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex {
+ testgetintforindex end 2147483647
+} 2147483647
+test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex {
+ testgetintforindex end-1 -1
+} -2
+test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex {
+ testgetintforindex end-1 -2
+} -3
+test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex {
+ testgetintforindex end -1
+} -1
+test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex {
+ testgetintforindex end -2
+} -2
+test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex {
+ testgetintforindex end+1 -1
+} 2147483647
+test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex {
+ testgetintforindex end+1 -2
+} -1
+test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex {
+ testgetintforindex -1 -1
+} -2147483648
+test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex {
+ testgetintforindex -2 -1
+} -2147483648
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/info.test b/tests/info.test
index 69be6a3..ef41bdf 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -5,10 +5,10 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2006 ActiveState
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2006 ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,10 +19,10 @@ if {{::tcltest} ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
-
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
-
+source [file join [file dirname [info script]] tcltests.tcl]
+catch [list package require -exact tcl::test [info patchlevel]]
+testConstraint zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -33,7 +33,7 @@ namespace eval test_ns_info1 {
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
-
+
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
@@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body {
# Fix for problem tested for in info-2.5 caused problems when
# procedure body had no string rep (i.e. was not yet bytecode)
# causing an empty string to be returned [Bug #545644]
-test info-2.6 {info body option, returning list bodies} {
+test info-2.6 {info body option, returning list bodies} deprecated {
proc foo args [list subst bar]
list [string bytelength [info body foo]] \
[foo; string bytelength [info body foo]]
@@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} {
proc testinfocmdcount {} {
set x [info cmdcount]
set y 12345
- set z [info cm]
+ set z [info cmdc]
expr {$z-$x}
}
test info-3.1 {info cmdcount compiled} {
@@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} {
test info-3.2 {info cmdcount evaled} -body {
set x [info cmdcount]
set y 12345
- set z [info cm]
+ set z [info cmdc]
expr {$z-$x}
} -cleanup {unset x y z} -result 4
test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4
@@ -397,8 +397,8 @@ test info-10.3 {info library option} -body {
set tcl_library $savedLibrary; unset savedLibrary
test info-11.1 {info loaded option} -body {
- info loaded a b
-} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"}
+ info loaded a b c
+} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"}
test info-11.2 {info loaded option} -body {
info loaded {}; info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
@@ -655,7 +655,7 @@ test info-19.6 {info vars: Bug 1072654} -setup {
namespace delete x
} -result {}
-set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
+set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
# Check whether the extra testing functions are defined...
if {!([catch {expr {T1()}} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} {
set functions "T1 T2 T3 $functions" ;# A lazy way of prepending!
@@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
} -result {wrong # args: should be "info subcommand ?arg ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
info gorp
-} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
info c
-} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
info l
-} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
info s
-} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
##
# ### ### ### ######### ######### #########
@@ -1841,7 +1841,7 @@ test info-30.48 {Bug 2850901} testevalex {
# -------------------------------------------------------------------------
# literal sharing 2, bug 2933089
-test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup {
+test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup {
set result {}
proc print_one {} {}
@@ -2396,6 +2396,174 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
+namespace eval ::testinfocmdtype {
+ apply {cmds {
+ foreach c $cmds {rename $c {}}
+ } ::testinfocmdtype} [info commands ::testinfocmdtype::*]
+}
+test info-40.1 {info cmdtype: syntax} -body {
+ info cmdtype
+} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
+test info-40.2 {info cmdtype: syntax} -body {
+ info cmdtype foo bar
+} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
+test info-40.3 {info cmdtype: no such command} -body {
+ info cmdtype ::testinfocmdtype::foo
+} -returnCodes error -result {unknown command "::testinfocmdtype::foo"}
+test info-40.4 {info cmdtype: native commands} -body {
+ info cmdtype ::if
+} -result native
+test info-40.5 {info cmdtype: native commands} -body {
+ info cmdtype ::puts
+} -result native
+test info-40.6 {info cmdtype: native commands} -body {
+ info cmdtype ::yield
+} -result native
+test info-40.7 {info cmdtype: procedures} -setup {
+ proc ::testinfocmdtype::someproc {} {}
+} -body {
+ info cmdtype ::testinfocmdtype::someproc
+} -cleanup {
+ rename ::testinfocmdtype::someproc {}
+} -result proc
+test info-40.8 {info cmdtype: aliases} -setup {
+ interp alias {} ::testinfocmdtype::somealias {} ::puts
+} -body {
+ info cmdtype ::testinfocmdtype::somealias
+} -cleanup {
+ rename ::testinfocmdtype::somealias {}
+} -result alias
+test info-40.9 {info cmdtype: imports} -setup {
+ namespace eval ::testinfocmdtype {
+ namespace eval foo {
+ proc bar {} {}
+ namespace export bar
+ }
+ namespace import foo::bar
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::bar
+} -cleanup {
+ rename ::testinfocmdtype::bar {}
+ namespace delete ::testinfocmdtype::foo
+} -result import
+test info-40.10 {info cmdtype: interps} -setup {
+ apply {i {
+ rename $i ::testinfocmdtype::child
+ variable ::testinfocmdtype::child $i
+ }} [interp create]
+} -body {
+ info cmdtype ::testinfocmdtype::child
+} -cleanup {
+ interp delete $::testinfocmdtype::child
+} -result interp
+test info-40.11 {info cmdtype: objects} -setup {
+ apply {{} {
+ oo::object create obj
+ } ::testinfocmdtype}
+} -body {
+ info cmdtype ::testinfocmdtype::obj
+} -cleanup {
+ ::testinfocmdtype::obj destroy
+} -result object
+test info-40.12 {info cmdtype: objects} -setup {
+ apply {{} {
+ oo::object create obj
+ } ::testinfocmdtype}
+} -body {
+ info cmdtype [info object namespace ::testinfocmdtype::obj]::my
+} -cleanup {
+ ::testinfocmdtype::obj destroy
+} -result privateObject
+test info-40.13 {info cmdtype: ensembles} -setup {
+ namespace eval ::testinfocmdtype {
+ namespace eval ensmbl {
+ proc bar {} {}
+ namespace export *
+ namespace ensemble create
+ }
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::ensmbl
+} -cleanup {
+ namespace delete ::testinfocmdtype::ensmbl
+} -result ensemble
+test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup {
+ namespace eval ::testinfocmdtype {
+ rename [zlib stream gzip] zstream
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::zstream
+} -cleanup {
+ ::testinfocmdtype::zstream close
+} -result zlibStream
+test info-40.15 {info cmdtype: coroutines} -setup {
+ coroutine ::testinfocmdtype::coro eval yield
+} -body {
+ info cmdtype ::testinfocmdtype::coro
+} -cleanup {
+ ::testinfocmdtype::coro
+} -result coroutine
+test info-40.16 {info cmdtype: dynamic behavior} -setup {
+ proc ::testinfocmdtype::foo {} {}
+} -body {
+ namespace eval ::testinfocmdtype {
+ list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \
+ [namespace which foo] [rename foo bar] [namespace which bar] \
+ [catch {info cmdtype foo}] [catch {info cmdtype bar}]
+ }
+} -cleanup {
+ namespace eval ::testinfocmdtype {
+ catch {rename foo {}}
+ catch {rename bar {}}
+ }
+} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
+test info-40.17 {info cmdtype: aliases in child interpreters} -setup {
+ set i [interp create]
+} -body {
+ $i alias foo gorp
+ $i eval {
+ info cmdtype foo
+ }
+} -cleanup {
+ interp delete $i
+} -result alias
+test info-40.18 {info cmdtype: aliases in child interpreters} -setup {
+ set safe [interp create -safe]
+} -body {
+ $safe alias foo gorp
+ $safe eval {
+ info cmdtype foo
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {not allowed to invoke subcommand cmdtype of info}
+test info-40.19 {info cmdtype: aliases in child interpreters} -setup {
+ set safe [interp create -safe]
+} -body {
+ set inner [interp create [list $safe bar]]
+ interp alias $inner foo $safe gorp
+ $safe eval {
+ bar eval {
+ info cmdtype foo
+ }
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {not allowed to invoke subcommand cmdtype of info}
+test info-40.20 {info cmdtype: aliases in child interpreters} -setup {
+ set safe [interp create -safe]
+} -body {
+ $safe eval {
+ interp alias {} foo {} gorp
+ info cmdtype foo
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {not allowed to invoke subcommand cmdtype of info}
+namespace delete ::testinfocmdtype
+
+# -------------------------------------------------------------------------
unset -nocomplain res
test info-39.2 {Bug 4b61afd660} -setup {
diff --git a/tests/init.test b/tests/init.test
index 6aec865..ac80016 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -4,14 +4,14 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.3.4
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -155,7 +155,7 @@ foreach arg [subst -nocommands -novariables {
error stack cannot be uniquely determined.
foo bar
"}
- {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
+ {argument that contains non-ASCII character, €, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
}] { ;# emacs needs -> "
test init-4.$count.0 {::errorInfo produced by [unknown]} -setup {
diff --git a/tests/internals.tcl b/tests/internals.tcl
index 43cafd5..36dbc90 100644
--- a/tests/internals.tcl
+++ b/tests/internals.tcl
@@ -4,7 +4,7 @@
#
# source [file join [file dirname [info script]] internals.tcl]
#
-# Copyright (c) 2020 Sergey G. Brester (sebres).
+# Copyright © 2020 Sergey G. Brester (sebres).
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -93,4 +93,4 @@ namespace export test*
# for script path & as mark for loaded
proc scriptpath {} [list return [info script]]
-}}; # end of internals.
+}}; # end of internals. \ No newline at end of file
diff --git a/tests/interp.test b/tests/interp.test
index d742484..fa263e2 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -4,23 +4,23 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.1
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
-set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload}
foreach i [interp children] {
interp delete $i
@@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp cmd ?arg ...?"}
test interp-1.2 {options for interp command} -returnCodes error -body {
interp frobox
-} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.3 {options for interp command} {
interp delete
} ""
@@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body {
} -result {wrong # args: should be "interp children ?path?"}
test interp-1.7 {options for interp command} -returnCodes error -body {
interp hello
-} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.8 {options for interp command} -returnCodes error -body {
interp -froboz
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.9 {options for interp command} -returnCodes error -body {
interp -froboz -safe
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer}
test interp-1.10 {options for interp command} -returnCodes error -body {
interp target
} -result {wrong # args: should be "interp target path alias"}
@@ -1640,7 +1640,7 @@ test interp-20.50.1 {Bug 2486550} -setup {
} -cleanup {
unset -nocomplain m 0
interp delete child
-} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
+} -result {wrong # args: should be "coroutine name cmd ?arg ...?"
while executing
"coroutine"
invoked from within
@@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
} -cleanup {
interp delete a
-} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds]
+} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds]
test interp-24.1 {result resetting on error} -setup {
catch {interp delete a}
@@ -3524,7 +3524,7 @@ test interp-35.19 {interp limit syntax} -body {
interp limit $i time -seconds -1
} -cleanup {
interp delete $i
-} -returnCodes error -result {seconds must be at least 0}
+} -match glob -returnCodes error -result {seconds must be between 0 and *}
test interp-35.20 {interp limit syntax} -body {
set i [interp create]
interp limit $i time -millis foobar
@@ -3536,7 +3536,7 @@ test interp-35.21 {interp limit syntax} -body {
interp limit $i time -millis -1
} -cleanup {
interp delete $i
-} -returnCodes error -result {milliseconds must be at least 0}
+} -match glob -returnCodes error -result {milliseconds must be between 0 and *}
test interp-35.22 {interp time limits normalize milliseconds} -body {
set i [interp create]
interp limit $i time -seconds 1 -millis 1500
diff --git a/tests/io.test b/tests/io.test
index 50a6018..00ae8f86 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -6,19 +6,19 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
-namespace eval ::tcl::test::io {
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+}
- if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.5
- namespace import -force ::tcltest::*
- }
+namespace eval ::tcl::test::io {
+ namespace import ::tcltest::*
variable umaskValue
variable path
@@ -31,8 +31,8 @@ namespace eval ::tcl::test::io {
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
- set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+ package require -exact tcl::test [info patchlevel]
+ set ::tcltestlib [info loaded {} Tcltest]
}
source [file join [file dirname [info script]] tcltests.tcl]
@@ -79,7 +79,7 @@ set path(cat) [makeFile {
if {$argv != ""} {
set f [open [lindex $argv 0]]
}
- fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A
+ fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A"
fconfigure stdout -encoding binary -translation lf -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
@@ -110,14 +110,14 @@ set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
- puts -nonewline $f "a\u4E4D\x00"
+ puts -nonewline $f "a\x4D\x00"
close $f
contents $path(test1)
} "a\x4D\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
- puts -nonewline $f "a\u4e4d\x00"
+ puts -nonewline $f "a乍\x00"
close $f
contents $path(test1)
} "a\x93\xE1\x00"
@@ -274,7 +274,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -body {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
- fconfigure $f -encoding jis0208 -buffersize 16
+ fconfigure $f -encoding jis0208 -buffersize 16 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -288,7 +288,7 @@ test io-3.5 {WriteChars: saved != 0} -body {
# requested buffersize.
set f [open $path(test1) w]
- fconfigure $f -encoding jis0208 -buffersize 17
+ fconfigure $f -encoding jis0208 -buffersize 17 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -301,14 +301,14 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# in src to the beginning of that UTF-8 character and try again.
#
# Translate the first 16 bytes, produce 14 bytes of output, 2 left over
- # (first two bytes of \uFF21 in UTF-8). Given those two bytes try
+ # (first two bytes of A in UTF-8). Given those two bytes try
# translating them again, find that no bytes are read produced, and break
# to outer loop where those two bytes will have the remaining 4 bytes
- # (the last byte of \uFF21 plus the all of \uFF22) appended.
+ # (the last byte of A plus the all of B) appended.
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
- puts -nonewline $f "12345678901234\uFF21\uFF22"
+ puts -nonewline $f "12345678901234AB"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
@@ -321,7 +321,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body {
# of the next channel buffer.
set f [open $path(test1) w]
- fconfigure $f -encoding jis0208 -buffersize 17
+ fconfigure $f -encoding jis0208 -buffersize 17 -profile tcl8
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
@@ -468,7 +468,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} {
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
- puts $f "\x81\u1234\x00"
+ puts $f "\x81\x34\x00"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
@@ -486,7 +486,7 @@ test io-6.5 {Tcl_GetsObj: encoding != NULL} {
set x [list [gets $f line] $line]
close $f
set x
-} [list 2 "\u4E00\u4E01"]
+} [list 2 "一丁"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
@@ -519,17 +519,17 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
puts $f "abcdef\x1Aghijk\nwombat"
close $f
set f [open $path(test1)]
- fconfigure $f -eofchar \x1A
+ fconfigure $f -eofchar "\x1A \x1A"
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
- puts $f "abcdefghijk\nwom\u001Abat"
+ puts $f "abcdefghijk\nwom\x1Abat"
close $f
set f [open $path(test1)]
- fconfigure $f -eofchar \x1A
+ fconfigure $f -eofchar "\x1A \x1A"
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
@@ -940,7 +940,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
- fconfigure $f -encoding unicode
+ fconfigure $f -encoding utf-16
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
@@ -1038,7 +1038,7 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
puts -nonewline $f "123456\x1Ak9012345\r"
close $f
set f [open $path(test1)]
- fconfigure $f -eofchar \x1A
+ fconfigure $f -eofchar "\x1A \x1A"
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
@@ -1069,14 +1069,14 @@ test io-6.55 {Tcl_GetsObj: overconverted} {
set f [open $path(test1) w]
fconfigure $f -encoding iso2022-jp
- puts $f "there\u4E00ok\n\u4E01more bytes\nhere"
+ puts $f "there一ok\n丁more bytes\nhere"
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
-} [list 8 "there\u4E00ok" 11 "\u4E01more bytes" 4 "here"]
+} [list 8 "there一ok" 11 "丁more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
@@ -1103,14 +1103,14 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
- puts $f "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14\nend"
+ puts $f "123456789012301234\nend"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
set x
-} "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14"
+} "123456789012301234"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
@@ -1119,7 +1119,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
- fconfigure $f -encoding shiftjis
+ fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line [eof $f]]
close $f
set x
@@ -1130,13 +1130,13 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
- fconfigure $f -encoding shiftjis
+ fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
-} [list 16 "1234567890123\uFF10\uFF11\x82" 18 0 1 -1 ""]
+} [list 16 "123456789012301\x82" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
@@ -1155,7 +1155,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent
vwait [namespace which -variable x]
close $f
set x
-} [list -1 "" 1 17 "1234567890123\uFF10\uFF11\uFF12\uFF13" 0]
+} [list -1 "" 1 17 "12345678901230123" 0]
test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
@@ -1184,7 +1184,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
- fconfigure $f -encoding unicode -buffersize 16 -blocking 0
+ fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
@@ -1438,7 +1438,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} {
vwait [namespace which -variable x]
close $f
set x
-} [list "123456789012345" 1 "\u672C" 0]
+} [list "123456789012345" 1 "本" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
@@ -1471,70 +1471,70 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} {
vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
-} "{} timeout {} timeout \u7266 {} eof 0 {}"
+} "{} timeout {} timeout 牦 {} eof 0 {}"
test io-12.6 {ReadChars: too many chars read} {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat \uBEEF 20][string repeat . 20]]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat 뻯 20][string repeat . 20]]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
- read $c 15
+ read $c 15
}
close $c
} {}
test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat \uBEEF 10]....\uBEEF]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat 뻯 10]....뻯]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
while {![eof $c]} {
- read $c 7
+ read $c 7
}
close $c
} {}
@@ -1555,9 +1555,9 @@ test io-12.9 {ReadChars: multibyte chars split} -body {
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -buffersize 10
+ fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
set in [read $f]
- close $f
+ read $f
scan [string index $in end] %c
} -cleanup {
catch {close $f}
@@ -1568,7 +1568,21 @@ test io-12.10 {ReadChars: multibyte chars split} -body {
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -buffersize 11
+ fconfigure $f -encoding utf-8 -profile strict -buffersize 10
+ set in [read $f]
+ close $f
+ scan [string index $in end] %c
+} -cleanup {
+ catch {close $f}
+} -returnCodes 1 -match glob -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+test io-12.11 {ReadChars: multibyte chars split} -body {
+ set f [open $path(test1) w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [string repeat a 9]\xC2
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 11
set in [read $f]
close $f
scan [string index $in end] %c
@@ -1925,7 +1939,7 @@ test io-14.9 {reuse of stdio special channels} {stdio fileevent} {
file delete $path(test1)
set f [open $path(script) w]
puts $f {
- array set path [lindex $argv 0]
+ array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
close $f
@@ -2272,7 +2286,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
- set x "$x$x"
+ set x "$x$x"
}
set f [open $path(output) w]
close $f
@@ -2286,9 +2300,9 @@ test io-27.6 {FlushChannel, async flushing, async close} \
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
- set result "file size only [file size $path(output)]"
+ set result "file size only [file size $path(output)]"
} else {
- set result ok
+ set result ok
}
} ok
@@ -2347,7 +2361,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
- set x "$x$x"
+ set x "$x$x"
}
set f [open $path(output) w]
close $f
@@ -2362,9 +2376,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \
vwait [namespace which -variable counter]
}
if {$counter == 1000} {
- set result probably_broken
+ set result probably_broken
} else {
- set result ok
+ set result ok
}
} ok
test io-28.4 Tcl_Close testchannel {
@@ -2394,6 +2408,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
lsort $l
} {file1 file2}
+
+test io-28.6 {
+ close channel in write event handler
+
+ Should not produce a segmentation fault in a Tcl built with
+ --enable-symbols and -DPURIFY
+} debugpurify {
+ variable done
+ variable res
+ after 0 [list coroutine c1 apply [list {} {
+ variable done
+ set chan [chan create w {apply {args {
+ list initialize finalize watch write configure blocking
+ }}}]
+ chan configure $chan -blocking 0
+ while 1 {
+ chan event $chan writable [list [info coroutine]]
+ yield
+ close $chan
+ set done 1
+ return
+ }
+ } [namespace current]]]
+ vwait [namespace current]::done
+return success
+} success
+
+
+test io-28.7 {
+ close channel in read event handler
+
+ Should not produce a segmentation fault in a Tcl built with
+ --enable-symbols and -DPURIFY
+} debugpurify {
+ variable done
+ variable res
+ after 0 [list coroutine c1 apply [list {} {
+ variable done
+ set chan [chan create r {apply {{cmd chan args} {
+ switch $cmd {
+ blocking - finalize {
+ }
+ watch {
+ chan postevent $chan read
+ }
+ initialize {
+ list initialize finalize watch read write configure blocking
+ }
+ default {
+ error [list {unexpected command} $cmd]
+ }
+ }
+ }}}]
+ chan configure $chan -blocking 0
+ while 1 {
+ chan event $chan readable [list [info coroutine]]
+ yield
+ close $chan
+ set done 1
+ return
+ }
+ } [namespace current]]]
+ vwait [namespace current]::done
+return success
+} success
+
+
+
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
@@ -3316,7 +3398,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
puts -nonewline $f hello\nthere\nand\rhere\n\x1A
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set c [read $f]
close $f
set c
@@ -3328,11 +3410,11 @@ here
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set c [read $f]
close $f
set c
@@ -3349,7 +3431,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3369,7 +3451,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3447,7 +3529,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3461,7 +3543,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3475,7 +3557,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3489,7 +3571,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3503,7 +3585,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3517,7 +3599,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
puts $f $c
close $f
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set c [string length [read $f]]
set e [eof $f]
close $f
@@ -3850,7 +3932,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3865,11 +3947,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3889,7 +3971,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3907,7 +3989,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -3991,7 +4073,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4009,7 +4091,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4027,7 +4109,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4045,7 +4127,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4063,7 +4145,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4081,7 +4163,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
puts $f $s
close $f
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l ""
lappend l [gets $f]
lappend l [gets $f]
@@ -4484,29 +4566,29 @@ test io-33.10 {Tcl_Gets, exercising double buffering} {
} 300
test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) .......
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) .......
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
if {$n > 3} {set n 3}
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
} -body {
set c [chan create read [namespace which driver]]
@@ -4518,29 +4600,29 @@ test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
} -result {{} {} {} .......}
test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) .......
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) .......
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
if {$n > 3} {set n 3}
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
} -body {
set c [chan create read [namespace which driver]]
@@ -4552,30 +4634,30 @@ test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
} -result {{} {} {} .......}
test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [string repeat \
- [string repeat . 64]\n[string repeat . 25] 2]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- if {$n > 65} {set n 65}
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [string repeat \
+ [string repeat . 64]\n[string repeat . 25] 2]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {$n > 65} {set n 65}
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
} -body {
set c [chan create read [namespace which driver]]
@@ -4962,12 +5044,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio {
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -4976,12 +5058,12 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -4990,12 +5072,12 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5004,12 +5086,12 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5018,12 +5100,12 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5032,12 +5114,12 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5052,7 +5134,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5067,7 +5149,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5082,7 +5164,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5097,7 +5179,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5112,7 +5194,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5127,7 +5209,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [read $f]]
set e [eof $f]
close $f
@@ -5150,12 +5232,12 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
@@ -5164,12 +5246,12 @@ test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
file delete $path(test1)
set f [open $path(test1) w]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
puts $f {}
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
@@ -5198,7 +5280,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
@@ -5213,7 +5295,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
set l [string length [set in [read $f]]]
set e [eof $f]
close $f
@@ -5296,8 +5378,8 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} {
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
proc in {f} {
- variable l
- variable x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
@@ -5332,8 +5414,8 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
proc in {f} {
- variable l
- variable x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
@@ -5408,7 +5490,7 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
- fconfigure $chan -buffersize 10
+ fconfigure $chan -buffersize 10 -encoding utf-8
set var [read $chan 2]
fconfigure $chan -buffersize 32
append var [read $chan]
@@ -5596,7 +5678,7 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
set x [read $f]
close $f
set x
-} \u7266
+} 牦
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
@@ -5608,7 +5690,7 @@ test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
set x [read $f]
close $f
set x
-} \u7266
+} 牦
test io-39.16 {Tcl_SetChannelOption: -encoding (shortened to "-en"), errors} -body {
file delete $path(test1)
set f [open $path(test1) w]
@@ -5697,32 +5779,32 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
close $s2
set modes
} {auto crlf}
-test io-39.22 {Tcl_SetChannelOption, invariance} {unix} {
+test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix} -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l ""
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
- fconfigure $f1 -eofchar D
+ fconfigure $f1 -eofchar {D D}
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
-} {{{} {}} {O G} {D D}}
-test io-39.22a {Tcl_SetChannelOption, invariance} {
+} -result {{{} {}} {O G} {D D}}
+test io-39.22a {Tcl_SetChannelOption, invariance} -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l [list]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
- fconfigure $f1 -eofchar D
+ fconfigure $f1 -eofchar {D D}
lappend l [fconfigure $f1 -eofchar]
lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
close $f1
set l
-} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
+} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
- writable, it should still have valid -eofchar and -translation options } {
+ writable, it should still have valid -eofchar and -translation options } {
set l [list]
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
@@ -5730,7 +5812,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
set l
} {{{}} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
- writable so we can't change -eofchar or -translation } {
+ writable so we can't change -eofchar or -translation } {
set l [list]
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
fconfigure $sock -eofchar D -translation lf
@@ -5758,7 +5840,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix notWsl} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
- set x [format "0o%o" [expr {$stats(mode)&0o777}]]
+ set x [format "%#o" [expr {$stats(mode)&0o777}]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
@@ -6088,6 +6170,70 @@ test io-44.5 {FileEventProc procedure: end of file} -constraints {
} -result {initial foo eof}
close $f
+
+test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
+} -constraints {stdio fileevent openpipe} -body {
+
+ namespace eval refchan {
+ namespace ensemble create
+ namespace export *
+
+
+ proc finalize {chan args} {
+ namespace delete c_$chan
+ }
+
+ proc initialize {chan args} {
+ namespace eval c_$chan {}
+ namespace upvar c_$chan watching watching
+ set watching {}
+ list finalize initialize seek watch write
+ }
+
+
+ proc watch {chan args} {
+ namespace upvar c_$chan watching watching
+ foreach arg $args {
+ switch $arg {
+ write {
+ if {$arg ni $watching} {
+ lappend watching $arg
+ }
+ chan postevent $chan $arg
+ }
+ }
+ }
+ }
+
+
+ proc write {chan args} {
+ chan postevent $chan write
+ return 1
+ }
+ }
+ set f [chan create w [namespace which refchan]]
+ chan configure $f -blocking 0
+ set data "some data"
+ set x 0
+ chan event $f writable [namespace code {
+ puts $f $data
+ incr count [string length $data]
+ if {$count > 262144} {
+ chan event $f writable {}
+ set x done
+ }
+ }]
+ set token [after 10000 [namespace code {
+ set x timeout
+ }]]
+ vwait [namespace which -variable x]
+ return $x
+} -cleanup {
+ after cancel $token
+ catch {chan close $f}
+} -result done
+
+
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
@@ -6164,23 +6310,23 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent not
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- variable x 0
- after 100 {set x triggered}
- vwait [namespace which -variable x]
- set x
+ variable x 0
+ after 100 {set x triggered}
+ vwait [namespace which -variable x]
+ set x
}
} {triggered}
test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- set x 0
- after 10 {lappend x timer}
- after 30
- set result $x
- update idletasks
- lappend result $x
- update
- lappend result $x
+ set x 0
+ after 10 {lappend x timer}
+ after 30
+ set result $x
+ update idletasks
+ lappend result $x
+ update
+ lappend result $x
}
} {0 0 {0 timer}}
@@ -6197,7 +6343,7 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
lappend x [fileevent $f2 readable]
testfevent delete
lappend x [fileevent $f readable] [fileevent $f2 readable] \
- [fileevent $f3 readable]
+ [fileevent $f3 readable]
close $f
close $f2
close $f3
@@ -6213,11 +6359,11 @@ test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
testfevent share $f2
testfevent share $f3
testfevent cmd "fileevent $f2 readable {script 2}
- fileevent $f3 readable {script 3}"
+ fileevent $f3 readable {script 3}"
fileevent $f4 readable {script 4}
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
- [fileevent $f3 readable] [fileevent $f4 readable]]
+ [fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
@@ -6235,10 +6381,10 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
fileevent $f readable {script 1}
fileevent $f2 readable {script 2}
testfevent cmd "fileevent $f3 readable {script 3}
- fileevent $f4 readable {script 4}"
+ fileevent $f4 readable {script 4}"
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
- [fileevent $f3 readable] [fileevent $f4 readable]]
+ [fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
@@ -6254,8 +6400,8 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent
fileevent $f readable {script 2}
fileevent $f2 readable {script 3}
set x [list [fileevent $f2 readable] \
- [testfevent cmd "fileevent $f readable"] \
- [fileevent $f readable]]
+ [testfevent cmd "fileevent $f readable"] \
+ [fileevent $f readable]]
testfevent delete
close $f
close $f2
@@ -6269,7 +6415,7 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil
fileevent $f readable {script 2}
testfevent cmd "fileevent $f readable {}"
set x [list [testfevent cmd "fileevent $f readable"] \
- [fileevent $f readable]]
+ [fileevent $f readable]]
testfevent delete
close $f
set x
@@ -6282,7 +6428,7 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil
fileevent $f readable {script 2}
fileevent $f readable {}
set x [list [testfevent cmd "fileevent $f readable"] \
- [fileevent $f readable]]
+ [fileevent $f readable]]
testfevent delete
close $f
set x
@@ -6416,7 +6562,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6444,7 +6590,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6472,7 +6618,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6500,7 +6646,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6528,7 +6674,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6556,7 +6702,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation auto -eofchar \x1A
+ fconfigure $f -translation auto -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6584,7 +6730,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6612,7 +6758,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation lf -eofchar \x1A
+ fconfigure $f -translation lf -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6640,7 +6786,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6668,7 +6814,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation cr -eofchar \x1A
+ fconfigure $f -translation cr -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6696,7 +6842,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -6724,7 +6870,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee
set c 0
set l ""
set f [open $path(test1) r]
- fconfigure $f -translation crlf -eofchar \x1A
+ fconfigure $f -translation crlf -eofchar "\x1A \x1A"
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
@@ -7116,8 +7262,8 @@ test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation cr -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation cr -encoding iso8859-1 -blocking 0
set s0 [fcopy $f1 $f2]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
@@ -7125,7 +7271,7 @@ test io-52.3 {TclCopyChannel} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7157,8 +7303,8 @@ test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation lf -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
@@ -7166,7 +7312,7 @@ test io-52.5 {TclCopyChannel, all} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7174,8 +7320,8 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation lf -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
@@ -7183,7 +7329,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7191,8 +7337,8 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation lf -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
@@ -7200,7 +7346,7 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7208,8 +7354,8 @@ test io-52.6 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation lf -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
set s0 [fcopy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
@@ -7217,7 +7363,7 @@ test io-52.6 {TclCopyChannel} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7225,8 +7371,8 @@ test io-52.7 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation lf -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
set s1 [file size $thisScript]
@@ -7234,7 +7380,7 @@ test io-52.7 {TclCopyChannel} {fcopy} {
close $f1
close $f2
if {"$s1" == "$s2"} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7271,7 +7417,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
-puts $out "\u0410\u0410"
+puts $out "АА"
close $out
test io-52.9 {TclCopyChannel & encodings} {fcopy} {
# Copy kyrillic to UTF-8, using fcopy.
@@ -7303,7 +7449,7 @@ test io-52.9 {TclCopyChannel & encodings} {fcopy} {
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
-test io-52.10 {TclCopyChannel & encodings} {fcopy} {
+test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body {
# encoding to binary (=> implies that the
# internal utf-8 is written)
@@ -7315,15 +7461,16 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} {
fconfigure $out -translation binary
fcopy $in $out
- close $in
- close $out
file size $path(utf8-fcopy.txt)
-} 5
+} -cleanup {
+ close $in
+ close $out
+} -result 5
test io-52.11 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
- puts $out "\u0410\u0410"
+ puts $out "АА"
close $out
} -constraints {fcopy} -body {
# binary to encoding => the input has to be
@@ -7486,6 +7633,155 @@ test io-52.19 {coverage of eofChar handling} {
close $out
file size $path(test2)
} 8
+test io-52.20 {TclCopyChannel & encodings} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "Á"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding koi8-r -translation lf
+
+ fcopy $in $out
+} -cleanup {
+ close $in
+ close $out
+} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
+
+test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "AÁ"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding ascii -translation lf
+
+ fcopy $in $out
+} -cleanup {
+ close $in
+ close $out
+} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
+
+test io-52.21 {TclCopyChannel & encodings} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "Á"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means writing the "Á" gives an error
+ fconfigure $in -encoding utf-8
+ fconfigure $out -encoding ascii -translation lf -profile strict
+
+ fcopy $in $out
+} -cleanup {
+ close $in
+ close $out
+} -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character}
+
+test io-52.22 {TclCopyChannel & encodings} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "Á"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding koi8-r -translation lf
+ proc ::xxx args {
+ set ::s0 $args
+ }
+
+ fcopy $in $out -command ::xxx
+ vwait ::s0
+ set ::s0
+} -cleanup {
+ close $in
+ close $out
+ unset ::s0
+} -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}}
+
+test io-52.22.1 {TclCopyChannel & encodings & tell position} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "AÁ"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding koi8-r -translation lf
+ proc ::xxx args {
+ set ::s0 $args
+ }
+
+ fcopy $in $out -command ::xxx
+ vwait ::s0
+ list [tell $in] [tell $out] {*}[set ::s0]
+} -cleanup {
+ close $in
+ close $out
+ unset ::s0
+} -match glob -result {1 1 1 {error reading "file*": invalid or incomplete multibyte or wide character}}
+
+test io-52.23 {TclCopyChannel & encodings} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "Á"
+ close $out
+} -constraints {fcopy} -body {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # Using "-encoding ascii" means writing the "Á" gives an error
+ fconfigure $in -encoding utf-8
+ fconfigure $out -encoding ascii -translation lf -profile strict
+ proc ::xxx args {
+ set ::s0 $args
+ }
+
+ fcopy $in $out -command ::xxx
+ vwait ::s0
+ set ::s0
+} -cleanup {
+ close $in
+ close $out
+ unset ::s0
+} -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}}
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
@@ -7503,8 +7799,8 @@ test io-53.2 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- fconfigure $f1 -translation lf -blocking 0
- fconfigure $f2 -translation cr -blocking 0
+ fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ fconfigure $f2 -translation cr -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
variable s0
@@ -7514,7 +7810,7 @@ test io-53.2 {CopyData} {fcopy} {
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
- lappend result ok
+ lappend result ok
}
set result
} {0 0 ok}
@@ -7632,6 +7928,8 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} {
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
+ fconfigure $in -encoding utf-8
+ fconfigure $out -encoding utf-8
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if {![info exists fcopyTestDone]} {
@@ -7669,8 +7967,8 @@ proc doFcopy {in out {bytes 0} {error {}}} {
} elseif {[eof $in]} {
set fcopyTestDone 0
} else {
- # Delay next fcopy to wait for size>0 input bytes
- after 100 [list fcopy $in $out -size 1000 \
+ # Delay next fcopy to wait for size>0 input bytes
+ after 100 [list fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]]
}
}
@@ -7685,9 +7983,9 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
proc Write {count} {
puts -nonewline "1234567890"
if {[incr count -1]} {
- after 10 [list Write $count]
+ after 10 [list Write $count]
} else {
- set ::ready 1
+ set ::ready 1
}
}
fconfigure stdout -buffering none
@@ -7983,7 +8281,7 @@ test io-53.11 {Bug 2895565} -setup {
removeFile out
removeFile in
} -result {40 bytes copied}
-test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} {
+test io-53.12.0 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
@@ -8002,23 +8300,49 @@ test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fc
close $f1
list $::done $ch
} {ok A}
+test io-53.12.1 {
+ Issue 9ca87e6286262a62.
+ CopyData: foreground short reads via ReadChars().
+ Related to report 3096275 for ReadBytes().
+
+ Prior to the fix this test waited forever for read() to return.
+} {stdio unix fcopy} {
+ file delete $path(output)
+ set f1 [open $path(output) w]
+ puts -nonewline $f1 {
+ chan configure stdin -encoding iso8859-1 -translation lf -buffering none
+ fcopy stdin stdout
+ }
+ close $f1
+ set f1 [open "|[list [info nameofexecutable] $path(output)]" r+]
+ try {
+ chan configure $f1 -encoding utf-8 -buffering none
+ puts -nonewline $f1 A
+ set ch [read $f1 1]
+ } finally {
+ if {$f1 in [chan names]} {
+ close $f1
+ }
+ }
+ lindex $ch
+} A
test io-53.13 {TclCopyChannel: read error reporting} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- return {initialize finalize watch read}
- }
- finalize {
- return
- }
- watch {}
- read {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch read}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ read {
error FAIL
- }
- }
+ }
+ }
}
set outFile [makeFile {} out]
} -body {
@@ -8031,24 +8355,24 @@ test io-53.13 {TclCopyChannel: read error reporting} -setup {
catch {close $out}
removeFile out
rename driver {}
-} -result {error reading "*": *} -returnCodes error -match glob
+} -result {error reading "rc*": *} -returnCodes error -match glob
test io-53.14 {TclCopyChannel: write error reporting} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- return {initialize finalize watch write}
- }
- finalize {
- return
- }
- watch {}
- write {
- error FAIL
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch write}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ write {
+ error FAIL
+ }
+ }
}
set inFile [makeFile {aaa} in]
} -body {
@@ -8064,35 +8388,35 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup {
} -result {error writing "*": *} -returnCodes error -match glob
test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- variable blocked
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat a 100]]
- set blocked($chan) 1
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan) blocked($chan)
- return
- }
- watch {}
- read {
- if {$blocked($chan)} {
- set blocked($chan) [expr {!$blocked($chan)}]
- return -code error EAGAIN
- }
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8
@@ -8108,35 +8432,35 @@ test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
} -result 100
test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- variable blocked
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- [string repeat a 100]]
- set blocked($chan) 1
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan) blocked($chan)
- return
- }
- watch {}
- read {
- if {$blocked($chan)} {
- set blocked($chan) [expr {!$blocked($chan)}]
- return -code error EAGAIN
- }
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf
@@ -8152,29 +8476,29 @@ test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
} -result 100
test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
proc driver {cmd args} {
- variable buffer
- variable index
- set chan [lindex $args 0]
- switch -- $cmd {
- initialize {
- set index($chan) 0
- set buffer($chan) [encoding convertto utf-8 \
- line\n[string repeat a 100]line\n]
- return {initialize finalize watch read}
- }
- finalize {
- unset index($chan) buffer($chan)
- return
- }
- watch {}
- read {
- set n [lindex $args 1]
- set new [expr {$index($chan) + $n}]
- set result [string range $buffer($chan) $index($chan) $new-1]
- set index($chan) $new
- return $result
- }
- }
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ line\n[string repeat a 100]line\n]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
}
set c [chan create read [namespace which driver]]
chan configure $c -encoding utf-8 -translation lf -buffersize 107
@@ -8468,7 +8792,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# 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": invalid argument}}}
+} {1 {gets ABC catch {error writing "stdout": invalid or incomplete multibyte or wide character}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
@@ -8802,7 +9126,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup {
read $rfd
} -body {
set result [eof $rfd]
- puts -nonewline $wfd "more\u00C2\u00A0data"
+ puts -nonewline $wfd more\xC2\xA0data
lappend result [eof $rfd]
lappend result [read $rfd]
lappend result [eof $rfd]
@@ -8810,7 +9134,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup {
close $wfd
close $rfd
removeFile io-73.5
-} -result [list 1 1 more\u00A0data 1]
+} -result [list 1 1 more\xA0data 1]
test io-74.1 {[104f2885bb] improper cache validity check} -setup {
set fn [makeFile {} io-74.1]
@@ -8830,19 +9154,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
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.
-# TCL 8.6 only offers tolerant channel encoding, what is tested here.
-test io-75.1 {multibyte encoding error read results in raw bytes} -setup {
+test io-75.1 {multibyte encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.1]
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"
+ puts -nonewline $f A\xC0\x40
flush $f
seek $f 0
- fconfigure $f -encoding utf-8 -buffering none
+ fconfigure $f -encoding utf-8 -profile tcl8 -buffering none
} -body {
set d [read $f]
binary scan $d H* hd
@@ -8850,54 +9171,54 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup {
} -cleanup {
close $f
removeFile io-75.1
-} -result "41c040"
+} -result 41c040
-test io-75.2 {unrepresentable character write passes and is replaced by ?} -setup {
+test io-75.2 {unrepresentable character write passes and is replaced by ? (-profile tcl8)} -setup {
set fn [makeFile {} io-75.2]
set f [open $fn w+]
- fconfigure $f -encoding iso8859-1
+ fconfigure $f -encoding iso8859-1 -profile tcl8
} -body {
- puts -nonewline $f "A\u2022"
+ puts -nonewline $f A\u2022
flush $f
seek $f 0
read $f
} -cleanup {
close $f
removeFile io-75.2
-} -result "A?"
+} -result A?
# Incomplete sequence test.
# This error may IMHO only be detected with the close.
# But the read already returns the incomplete sequence.
-test io-75.3 {incomplete multibyte encoding read is ignored} -setup {
+test io-75.3 {incomplete multibyte encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.3]
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
+ fconfigure $f -encoding utf-8 -buffering none -profile tcl8
} -body {
set d [read $f]
- close $f
binary scan $d H* hd
set hd
} -cleanup {
+ close $f
removeFile io-75.3
-} -result "41c0"
+} -result 41c0
# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
-test io-75.4 {shiftjis encoding error read results in raw bytes} -setup {
+test io-75.4 {shiftjis encoding error read results in raw bytes (-profile tcl8)} -setup {
set fn [makeFile {} io-75.4]
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"
+ puts -nonewline $f A\x81\xFFA
flush $f
seek $f 0
- fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf
+ fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
binary scan $d H* hd
@@ -8905,29 +9226,498 @@ test io-75.4 {shiftjis encoding error read results in raw bytes} -setup {
} -cleanup {
close $f
removeFile io-75.4
-} -result "4181ff41"
+} -result 4181ff41
-test io-75.5 {incomplete shiftjis encoding read is ignored} -setup {
+test io-75.5 {invalid utf-8 encoding read is ignored (-profile tcl8)} -setup {
set fn [makeFile {} io-75.5]
set f [open $fn w+]
fconfigure $f -encoding binary
- # \x81 announces a two byte sequence.
- puts -nonewline $f "A\x81"
+ puts -nonewline $f A\x81
flush $f
seek $f 0
- fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf
+ fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -profile tcl8
} -body {
set d [read $f]
- close $f
binary scan $d H* hd
set hd
} -cleanup {
+ close $f
removeFile io-75.5
-} -result "4181"
+} -result 4181
+test io-75.6 {incomplete utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup {
+ set fn [makeFile {} io-75.6]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 is an incomplete byte sequence in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf -profile strict
+} -body {
+ gets $f
+} -cleanup {
+ close $f
+ removeFile io-75.6
+} -match glob -returnCodes 1 -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+
+test io-75.6.1 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup {
+ set fn [makeFile {} io-75.6.1]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
+ puts -nonewline $f A\xC3B
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf -profile strict
+} -body {
+ gets $f
+} -cleanup {
+ close $f
+ removeFile io-75.6.1
+} -match glob -returnCodes 1 -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+
+test io-75.6.2 {invalid utf-8 encoding, blocking gets is not ignored (-profile strict), recover functionality} -setup {
+ set fn [makeFile {} io-75.6.2]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
+ puts -nonewline $f A\xC3B
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf -profile strict
+} -body {
+ set l {}
+ lappend l [catch {gets $f}]
+ lappend l [tell $f]
+ fconfigure $f -encoding binary
+ lappend l [expr {[gets $f] eq "A\xC3B"}]
+} -cleanup {
+ close $f
+ removeFile io-75.6.2
+} -match glob -returnCodes 0 -result {1 0 1}
+
+# TCL ticket c4eb46a196: non blocking case had endless loop, so test it
+test io-75.6.3 {invalid utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup {
+ set fn [makeFile {} io-75.6.3]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # utf-8: \xC3 requires a 2nd byte > x80, but <x80 is delivered
+ puts -nonewline $f A\xC3B
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf -profile strict -blocking 0
+} -body {
+ gets $f
+} -cleanup {
+ close $f
+ removeFile io-75.6.3
+} -match glob -returnCodes 1 -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+
+test io-75.6.4 {incomplete utf-8 encoding, non blocking gets is not ignored (-profile strict)} -setup {
+ set fn [makeFile {} io-75.6.4]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 is an incomplete byte sequence in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf -profile strict -blocking 0
+} -body {
+ gets $f
+ # only the 2nd gets returns the error
+ gets $f
+} -cleanup {
+ close $f
+ removeFile io-75.6.4
+} -match glob -returnCodes 1 -result {error reading "file*":\
+ invalid or incomplete multibyte or wide character}
+
+test io-75.7 {
+ invalid utf-8 encoding read is not ignored (-profile strict)
+} -setup {
+ set fn [makeFile {} io-75.7]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 is invalid in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
+ -profile strict
+} -body {
+ list [catch {read $f} msg data] $msg [dict get $data -data]
+} -cleanup {
+ close $f
+ removeFile io-75.7
+ unset msg data f fn
+} -match glob -result {1 {error reading "file*":\
+ invalid or incomplete multibyte or wide character} A}
+
+test io-75.8 {invalid utf-8 encoding eof first handling (-profile strict)} -setup {
+ set fn [makeFile {} io-75.8]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes
+ # precedence.
+ puts -nonewline $f A\x1A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
+ -translation lf -profile strict
+} -body {
+ set d [read $f]
+ binary scan $d H* hd
+ lappend hd [eof $f]
+ lappend hd [read $f]
+ set hd
+} -cleanup {
+ close $f
+ removeFile io-75.8
+ unset f d hd
+} -result {41 1 {}}
+
+test io-75.8.eoflater {invalid utf-8 encoding eof after handling (-profile strict)} -setup {
+ set fn [makeFile {} io-75.8]
+ set f [open $fn w+]
+ # This also configures the channel encoding profile as strict.
+ fconfigure $f -encoding binary
+ # \x81 is invalid in utf-8. -eofchar is not detected, because it comes later.
+ puts -nonewline $f A\x81\x81\x1A
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
+ -translation lf -profile strict
+} -body {
+ set res [list [catch {read $f} msg data] [eof $f] [dict get $data -data]]
+ chan configure $f -encoding iso8859-1
+ lappend res [read $f 1]
+ chan configure $f -encoding utf-8
+ lappend res [catch {read $f 1} msg data] $msg [dict get $data -data]
+} -cleanup {
+ close $f
+ removeFile io-75.8
+ unset res msg data fn f
+} -match glob -result "1 0 A \x81 1 {error reading \"*\":\
+ invalid or incomplete multibyte or wide character} {}"
+
+
+test io-strict-multibyte-eof {
+ incomplete utf-8 sequence immediately prior to eof character
+
+ See issue 25cdcb7e8fb381fb
+} -setup {
+ set chan [file tempfile];
+ fconfigure $chan -encoding binary
+ puts -nonewline $chan \x81\x1A
+ flush $chan
+ seek $chan 0
+ chan configure $chan -encoding utf-8 -profile strict
+} -body {
+ list [catch {read $chan 1} msg data] $msg [dict get $data -data]
+} -cleanup {
+ close $chan
+ unset msg chan data
+} -match glob -result {1 {error reading "*":\
+ invalid or incomplete multibyte or wide character} {}}
+
+test io-75.9 {unrepresentable character write throws error in strict profile} -setup {
+ set fn [makeFile {} io-75.9]
+ set f [open $fn w+]
+ fconfigure $f -encoding iso8859-1 -profile strict
+} -body {
+ catch {puts -nonewline $f "A\u2022"} msg
+ flush $f
+ seek $f 0
+ list [read $f] $msg
+} -cleanup {
+ close $f
+ removeFile io-75.9
+ unset f
+} -match glob -result [list {A} {error writing "*":\
+ invalid or incomplete multibyte or wide character}]
+
+# Incomplete sequence test.
+# This error may IMHO only be detected with the close.
+# But the read already returns the incomplete sequence.
+test io-75.10 {incomplete multibyte encoding read is ignored} -setup {
+ set fn [makeFile {} io-75.10]
+ 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]
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ close $f
+ removeFile io-75.10
+ unset d hd
+} -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.11 {shiftjis encoding error read results in error (strict profile)} -setup {
+ set fn [makeFile {} io-75.11]
+ 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 -blocking 0 -eofchar {} -translation lf \
+ -profile strict
+} -body {
+ set d [read $f]
+ binary scan $d H* hd
+ lappend hd [catch {set d [read $f]} msg data] $msg [dict exists $data -data]
+} -cleanup {
+ close $f
+ removeFile io-75.11
+ unset d hd msg data f
+} -match glob -result {41 1 {error reading "file*":\
+ invalid or incomplete multibyte or wide character} 0}
+
+test io-75.12 {invalid utf-8 encoding read is ignored} -setup {
+ set fn [makeFile {} io-75.12]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ 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]
+ binary scan $d H* hd
+ set hd
+} -cleanup {
+ close $f
+ removeFile io-75.12
+} -result 4181
+test io-75.13 {
+ In nonblocking mode when there is an encoding error the data that has been
+ successfully read so far is returned first and then the error is returned
+ on the next call to [read].
+} -setup {
+ set fn [makeFile {} io-75.13]
+ set f [open $fn w+]
+ fconfigure $f -encoding binary
+ # \x81 is invalid in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \
+ -profile strict
+} -body {
+ set d [read $f]
+ binary scan $d H* hd
+ lappend hd [catch {read $f} msg data] $msg [dict exists $data -data]
+} -cleanup {
+ close $f
+ removeFile io-75.13
+ unset d hd msg data f fn
+} -match glob -result {41 1 {error reading "file*":\
+ invalid or incomplete multibyte or wide character} 0}
+
+test io-75.14 {
+ [gets] succesfully returns lines prior to error
+
+ invalid utf-8 encoding [gets] continues in non-strict mode after error
+} -setup {
+ set chan [file tempfile]
+ fconfigure $chan -encoding binary
+ # \xC0\n is an invalid utf-8 sequence
+ puts -nonewline $chan a\nb\nc\xC0\nd\n
+ flush $chan
+ seek $chan 0
+ fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \
+ -translation auto -profile strict
+} -body {
+ set res [gets $chan]
+ lappend res [gets $chan]
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ chan configure $chan -profile tcl8
+ lappend res [gets $chan]
+ lappend res [gets $chan]
+ return $res
+} -cleanup {
+ close $chan
+ unset chan res msg data
+} -match glob -result {a b 1 {error reading "*":\
+ invalid or incomplete multibyte or wide character} 0 cÀ d}
+
+test io-75.15 {
+ invalid utf-8 encoding strict
+ gets does not hang
+ gets succeeds for the first two lines
+} -setup {
+ set res {}
+ set chan [file tempfile]
+ fconfigure $chan -encoding binary
+ # \xC0\x40 is an invalid utf-8 sequence
+ puts $chan hello\nAB\nCD\xC0\x40EF\nGHI
+ seek $chan 0
+} -body {
+ #Now try to read it with [gets]
+ fconfigure $chan -encoding utf-8 -profile strict
+ lappend res [gets $chan]
+ lappend res [gets $chan]
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ chan configure $chan -translation binary
+ set data [read $chan 4]
+ foreach char [split $data {}] {
+ scan $char %c ord
+ lappend res [format %x $ord]
+ }
+ fconfigure $chan -encoding utf-8 -profile strict -translation auto
+ lappend res [gets $chan]
+ lappend res [gets $chan]
+ return $res
+} -cleanup {
+ close $chan
+ unset chan res msg data
+} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
+ 0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI}
# ### ### ### ######### ######### #########
+
+
+test io-76.0 {channel modes} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r]
+} -constraints testchannel -body {
+ testchannel mode $f
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {read {}}
+
+test io-76.1 {channel modes} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile w]
+} -constraints testchannel -body {
+ testchannel mode $f
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {{} write}
+
+test io-76.2 {channel modes} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r+]
+} -constraints testchannel -body {
+ testchannel mode $f
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {read write}
+
+test io-76.3 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r]
+} -constraints testchannel -body {
+ testchannel mremove-wr $f
+ list [testchannel mode $f] [testchannel maxmode $f]
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {{read {}} {read {}}}
+
+test io-76.4 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r]
+} -constraints testchannel -body {
+ testchannel mremove-rd $f
+} -returnCodes error -cleanup {
+ close $f
+ removeFile dummy
+} -match glob -result {Tcl_RemoveChannelMode error:\
+ Bad mode, would make channel inacessible. Channel: "*"}
+
+test io-76.5 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile w]
+} -constraints testchannel -body {
+ testchannel mremove-rd $f
+ list [testchannel mode $f] [testchannel maxmode $f]
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {{{} write} {{} write}}
+
+test io-76.6 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile w]
+} -constraints testchannel -body {
+ testchannel mremove-wr $f
+} -returnCodes error -cleanup {
+ close $f
+ removeFile dummy
+} -match glob -result {Tcl_RemoveChannelMode error:\
+ Bad mode, would make channel inacessible. Channel: "*"}
+
+test io-76.7 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r+]
+} -constraints testchannel -body {
+ testchannel mremove-rd $f
+ list [testchannel mode $f] [testchannel maxmode $f]
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {{{} write} {read write}}
+
+test io-76.8 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r+]
+} -constraints testchannel -body {
+ testchannel mremove-wr $f
+ list [testchannel mode $f] [testchannel maxmode $f]
+} -cleanup {
+ close $f
+ removeFile dummy
+} -result {{read {}} {read write}}
+
+test io-76.9 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r+]
+} -constraints testchannel -body {
+ testchannel mremove-wr $f
+ testchannel mremove-rd $f
+} -returnCodes error -cleanup {
+ close $f
+ removeFile dummy
+} -match glob -result {Tcl_RemoveChannelMode error:\
+ Bad mode, would make channel inacessible. Channel: "*"}
+
+test io-76.10 {channel mode dropping} -setup {
+ set datafile [makeFile {some characters} dummy]
+ set f [open $datafile r+]
+} -constraints testchannel -body {
+ testchannel mremove-rd $f
+ testchannel mremove-wr $f
+} -returnCodes error -cleanup {
+ close $f
+ removeFile dummy
+} -match glob -result {Tcl_RemoveChannelMode error:\
+ Bad mode, would make channel inacessible. Channel: "*"}
+
# 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] {
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index dae15af..2b9aed6 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -1,14 +1,15 @@
# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
-# fblocked, fconfigure, open, channel, fcopy
+# fblocked, fconfigure, open, channel, fcopy,
+# readFile, writeFile, foreachLine
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -20,7 +21,7 @@ if {"::tcltest" ni [namespace children]} {
source [file join [file dirname [info script]] tcltests.tcl]
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
@@ -153,10 +154,10 @@ test iocmd-4.11 {read command} {
test iocmd-4.12 {read command} -setup {
set f [open $path(test1)]
} -body {
- list [catch {read $f 12z} msg] $msg $::errorCode
+ read $f 12z
} -cleanup {
close $f
-} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}}
+} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER}
test iocmd-5.1 {seek command} -returnCodes error -body {
seek
@@ -205,83 +206,95 @@ test iocmd-7.5 {close command} -setup {
close $chan
} -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed"
-test iocmd-8.1 {fconfigure command} {
- list [catch {fconfigure} msg] $msg
-} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
-test iocmd-8.2 {fconfigure command} {
- list [catch {fconfigure a b c d e f} msg] $msg
-} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}}
-test iocmd-8.3 {fconfigure command} {
- list [catch {fconfigure a b} msg] $msg
-} {1 {can not find channel named "a"}}
-test iocmd-8.4 {fconfigure command} {
+proc expectedOpts {got extra} {
+ set basicOpts {
+ -blocking -buffering -buffersize -encoding -eofchar -profile -translation
+ }
+ set opts [list {*}$basicOpts {*}$extra]
+ lset opts end [string cat "or " [lindex $opts end]]
+ return [format {bad option "%s": should be one of %s} $got [join $opts ", "]]
+}
+test iocmd-8.1 {fconfigure command} -returnCodes error -body {
+ fconfigure
+} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
+test iocmd-8.2 {fconfigure command} -returnCodes error -body {
+ fconfigure a b c d e f
+} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"}
+test iocmd-8.3 {fconfigure command} -returnCodes error -body {
+ fconfigure a b
+} -result {can not find channel named "a"}
+test iocmd-8.4 {fconfigure command} -setup {
file delete $path(test1)
set f1 [open $path(test1) w]
- set x [list [catch {fconfigure $f1 froboz} msg] $msg]
+} -body {
+ fconfigure $f1 froboz
+} -returnCodes error -cleanup {
close $f1
- set x
-} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
-test iocmd-8.5 {fconfigure command} {
- list [catch {fconfigure stdin -buffering froboz} msg] $msg
-} {1 {bad value for -buffering: must be one of full, line, or none}}
-test iocmd-8.6 {fconfigure command} {
- list [catch {fconfigure stdin -translation froboz} msg] $msg
-} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
-test iocmd-8.7 {fconfigure command} {
+} -result [expectedOpts "froboz" -stat]
+test iocmd-8.5 {fconfigure command} -returnCodes error -body {
+ fconfigure stdin -buffering froboz
+} -result {bad value for -buffering: must be one of full, line, or none}
+test iocmd-8.6 {fconfigure command} -returnCodes error -body {
+ fconfigure stdin -translation froboz
+} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
+test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
- fconfigure $f1 -translation lf -eofchar {} -encoding unicode
- set x [fconfigure $f1]
- close $f1
- set x
-} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
-test iocmd-8.8 {fconfigure command} {
+ fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -profile tcl8
+ fconfigure $f1
+} -cleanup {
+ catch {close $f1}
+} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}
+test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
+ set x {}
+} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
- -eofchar {} -encoding unicode
- set x ""
+ -eofchar {} -encoding utf-16 -profile tcl8
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
- close $f1
- set x
-} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
-test iocmd-8.9 {fconfigure command} {
+} -cleanup {
+ catch {close $f1}
+} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf}}
+test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
+} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
- -eofchar {} -encoding binary
- set x [fconfigure $f1]
- close $f1
- set x
-} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
-test iocmd-8.10 {fconfigure command} {
- list [catch {fconfigure a b} msg] $msg
-} {1 {can not find channel named "a"}}
+ -eofchar {} -encoding binary -profile tcl8
+ fconfigure $f1
+} -cleanup {
+ catch {close $f1}
+} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -profile tcl8 -translation lf}
+test iocmd-8.10 {fconfigure command} -returnCodes error -body {
+ fconfigure a b
+} -result {can not find channel named "a"}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
-test iocmd-8.11 {fconfigure command} {
+test iocmd-8.11 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
- set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
- close $chan
- set res
-} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
-test iocmd-8.12 {fconfigure command} {
+ fconfigure $chan -froboz blarfo
+} -returnCodes error -cleanup {
+ catch {close $chan}
+} -result [expectedOpts "-froboz" {}]
+test iocmd-8.12 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
- set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
- close $chan
- set res
-} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
-test iocmd-8.13 {fconfigure command} {
+ fconfigure $chan -b blarfo
+} -returnCodes error -cleanup {
+ catch {close $chan}
+} -result [expectedOpts "-b" {}]
+test iocmd-8.13 {fconfigure command} -body {
set chan [open $path(fconfigure.dummy) r]
- set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
- close $chan
- set res
-} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+ fconfigure $chan -buffer blarfo
+} -returnCodes error -cleanup {
+ catch {close $chan}
+} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
-test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
+test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
@@ -293,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr
close $srv
unset cli srv port
rename iocmdSRV {}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname}
+} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nodelay -peername -sockname}]
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
@@ -336,7 +349,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl
if {$tty ne ""} {
close $tty
}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode}
+} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}]
test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup {
set tty ""
} -body {
@@ -347,9 +360,40 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable
if {$tty ne ""} {
close $tty
}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar}
+} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}]
+test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup {
+ # I don't know how else to open the console, but this is non-portable
+ set console stdin
+} -body {
+ fconfigure $console -blah blih
+} -returnCodes error -result [expectedOpts "-blah" {-inputmode}]
# TODO: Test parsing of serial channel options (nonPortable, since requires an
# open channel to work with).
+test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints {
+ deprecated obsolete
+} -setup {
+ # I don't know how else to open the console, but this is non-portable
+ set console stdin
+} -body {
+ fconfigure $console -nocomplainencoding 0
+} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed"
+test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup {
+ set console stdin
+ set oldprofile [fconfigure $console -profile]
+} -constraints {
+ obsolete
+} -body {
+ fconfigure $console -strictencoding 1
+ fconfigure $console -nocomplainencoding 0
+ fconfigure $console -nocomplainencoding
+} -cleanup {
+ fconfigure $console -strictencoding $oldmode
+} -result 0
+
+
+test iocmd-8.23 {fconfigure -profile badprofile} -body {
+ fconfigure stdin -profile froboz
+} -returnCodes error -result {bad profile name "froboz": must be replace, strict, or tcl8}
test iocmd-9.1 {eof command} {
list [catch {eof} msg] $msg $::errorCode
@@ -475,14 +519,14 @@ test iocmd-12.10 {POSIX open access modes: BINARY} {
} 5
test iocmd-12.11 {POSIX open access modes: BINARY} {
set f [open $path(test1) {WRONLY BINARY TRUNC}]
- puts $f \u0248 ;# gets truncated to \u0048
+ puts $f Ɉ ;# gets truncated to H
close $f
set f [open $path(test1) r]
fconfigure $f -translation binary
set result [read -nonewline $f]
close $f
set result
-} \u0048
+} H
test iocmd-13.1 {errors in open command} {
list [catch {open} msg] $msg
@@ -563,7 +607,28 @@ test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup {
} -cleanup {
removeFile $f
} -result 341234x6
-
+test ioCmd-13.12 {open file produces something that has fconfigure -stat} -setup {
+ set f [makeFile {} iocmd13_12]
+ set result {}
+} -body {
+ set fd [open $f wb]
+ set result [dict get [fconfigure $fd -stat] type]
+ fconfigure $fd -buffering none
+ puts -nonewline $fd abc
+ # Three ways of getting the size; all should agree!
+ lappend result [tell $fd] [file size $f] \
+ [dict get [fconfigure $fd -stat] size]
+ puts -nonewline $fd def
+ lappend result [tell $fd] [file size $f] \
+ [dict get [fconfigure $fd -stat] size]
+ puts -nonewline $fd ghi
+ lappend result [tell $fd] [file size $f] \
+ [dict get [fconfigure $fd -stat] size]
+ close $fd
+ return $result
+} -cleanup {
+ removeFile $f
+} -result {file 3 3 3 6 6 6 9 9 9}
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $::errorCode
@@ -911,6 +976,17 @@ proc onfinal {} {
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
+
+proc onwatch {} {
+ upvar args hargs
+ lassign $hargs watch chan eventspec
+ if {$watch ne "watch"} return
+ foreach spec $eventspec {
+ chan postevent $chan $spec
+ }
+ return
+}
+
}
# Set everything up in the main thread.
@@ -1018,7 +1094,7 @@ test iocmd-23.1 {chan read, regular data return} -match glob -body {
rename foo {}
set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
-test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
+test iocmd-23.2 {chan read, bad data return, too much} -match glob -body {
set res {}
proc foo {args} {
oninit; onfinal; track
@@ -1333,7 +1409,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body {
close $c
rename foo {}
set res
-} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo {args} {oninit cget cgetall; onfinal; track; return ""}
@@ -1342,7 +1418,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
close $c
rename foo {}
set res
-} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}}
test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo {args} {
@@ -1354,7 +1430,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
close $c
rename foo {}
set res
-} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
+} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *} -bar foo -snarf x}}
test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
@@ -1983,28 +2059,29 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
- note [fileevent $c readable {note TOCK}]
- set stop [after 15000 {note TIMEOUT}]
+ set tock {}
+ note [fileevent $c readable {lappend res TOCK; set tock 1}]
+ set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
- vwait ::res
+ vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
-} -result {{watch rc* read} {} TOCK {} {watch rc* {}}}
+} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
- note [fileevent $c writable {note TOCK}]
- set stop [after 15000 {note TIMEOUT}]
+ note [fileevent $c writable {lappend res TOCK; set tock 1}]
+ set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
- vwait ::res
+ vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
-} -result {{watch rc* write} {} TOCK {} {watch rc* {}}}
+} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
@@ -2017,6 +2094,31 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
rename foo {}
rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
+test iocmd-31.9 {
+ chan postevent
+
+ call to current coroutine
+
+ see 67a5eabbd3d1
+} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onwatch; onfinal; track; return}
+ set c [chan create {r w} foo]
+ after 0 [list ::apply [list c {
+ coroutine c1 ::apply [list c {
+ chan event $c readable [list [info coroutine]]
+ yield
+ set ::done READING
+ } [namespace current]] $c
+ } [namespace current]] $c]
+ set stop [after 10000 {set done TIMEOUT}]
+ vwait ::done
+ catch {after cancel $stop}
+ lappend res $done
+ close $c
+ rename foo {}
+ set res
+} -result {{watch rc* read} READING {watch rc* {}}}
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
@@ -2303,7 +2405,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body {
rename foo {}
set res
} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
-test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
+test iocmd.tf-23.2 {chan read, bad data return, too much} -match glob -body {
set res {}
proc foo {args} {
oninit; onfinal; track
@@ -2849,7 +2951,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body
rename foo {}
set res
} -constraints {testchannel thread} \
- -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+ -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}}
test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo {args} {oninit cget cgetall; onfinal; track; return ""}
@@ -2862,7 +2964,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
rename foo {}
set res
} -constraints {testchannel thread} \
- -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
+ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}}
test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
set res {}
proc foo {args} {
@@ -2878,7 +2980,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
rename foo {}
set res
} -constraints {testchannel thread} \
- -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
+ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}}
test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
set res {}
proc foo {args} {
@@ -3826,6 +3928,209 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
} -constraints {testchannel thread notValgrind} \
-result {Owner lost}
+# Tests of readFile
+
+set BIN_DATA "\u0000\u0001\u0002\u0003\u0004\u001a\u001b\u000d\u000a\u0000"
+
+test iocmd.readFile-1.1 "readFile procedure: syntax" -body {
+ readFile
+} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"}
+test iocmd.readFile-1.2 "readFile procedure: syntax" -body {
+ readFile a b c
+} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"}
+test iocmd.readFile-1.3 "readFile procedure: syntax" -body {
+ readFile gorp gorp2
+} -returnCodes error -result {bad mode "gorp2": must be binary or text}
+
+test iocmd.readFile-2.1 "readFile procedure: behaviour" -setup {
+ set f [makeFile "File\nContents" readFile21.txt]
+} -body {
+ readFile $f
+} -cleanup {
+ removeFile $f
+} -result "File\nContents\n"
+test iocmd.readFile-2.2 "readFile procedure: behaviour" -setup {
+ set f [makeFile "File\nContents" readFile22.txt]
+} -body {
+ readFile $f text
+} -cleanup {
+ removeFile $f
+} -result "File\nContents\n"
+test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" readFile23.bindata]
+ apply {filename {
+ global BIN_DATA
+ set ff [open $filename wb]
+ puts -nonewline $ff $BIN_DATA
+ close $ff
+ }} $f
+} -body {
+ list [binary scan [readFile $f binary] c* x] $x
+} -cleanup {
+ removeFile $f
+} -result {1 {0 1 2 3 4 26 27 13 10 0}}
+# Need to set up ahead of the test
+set f [makeFile "" readFile24.txt]
+removeFile $f
+test iocmd.readFile-2.4 "readFile procedure: behaviour" -body {
+ readFile $f
+} -returnCodes error -result "couldn't open \"$f\": no such file or directory"
+
+# Tests of writeFile
+
+test iocmd.writeFile-1.1 "writeFile procedure: syntax" -body {
+ writeFile
+} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"}
+test iocmd.writeFile-1.2 "writeFile procedure: syntax" -body {
+ writeFile a b c d
+} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"}
+test iocmd.writeFile-1.3 "writeFile procedure: syntax" -body {
+ writeFile gorp gorp2 gorp3
+} -returnCodes error -result {bad mode "gorp2": must be binary or text}
+
+test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile21.txt]
+ removeFile $f
+} -body {
+ list [writeFile $f "File\nContents\n"] [apply {filename {
+ set f [open $filename]
+ set text [read $f]
+ close $f
+ return $text
+ }} $f]
+} -cleanup {
+ file delete $f
+} -result [list {} "File\nContents\n"]
+test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile22.txt]
+ removeFile $f
+} -body {
+ writeFile $f text "File\nContents\n"
+ apply {filename {
+ set f [open $filename]
+ set text [read $f]
+ close $f
+ return $text
+ }} $f
+} -cleanup {
+ file delete $f
+} -result "File\nContents\n"
+test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile23.txt]
+ removeFile $f
+} -body {
+ writeFile $f binary $BIN_DATA
+ apply {filename {
+ set f [open $filename rb]
+ set bytes [read $f]
+ close $f
+ binary scan $bytes c* x
+ return $x
+ }} $f
+} -cleanup {
+ file delete $f
+} -result {0 1 2 3 4 26 27 13 10 0}
+
+# Tests of foreachLine
+
+test iocmd.foreachLine-1.1 "foreachLine procedure: syntax" -returnCodes error -body {
+ foreachLine
+} -result {wrong # args: should be "foreachLine varName filename body"}
+test iocmd.foreachLine-1.2 "foreachLine procedure: syntax" -returnCodes error -body {
+ foreachLine a b c d
+} -result {wrong # args: should be "foreachLine varName filename body"}
+test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup {
+ set f [makeFile "" foreachLine13.txt]
+} -body {
+ apply {filename {
+ array set b {1 1}
+ foreachLine b $filename {}
+ }} $f
+} -cleanup {
+ removeFile $f
+} -returnCodes error -result {can't set "line": variable is array}
+set f [makeFile "" foreachLine14.txt]
+removeFile $f
+test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body {
+ apply {filename {
+ foreachLine var $filename {}
+ }} $f
+} -returnCodes error -result "couldn't open \"$f\": no such file or directory"
+
+test iocmd.foreachLine-2.1 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nb\nc" foreachLine21.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {a b c}
+test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nc\ndd" foreachLine22.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] == 1} continue
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {bb dd}
+test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine23.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} break
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {a bb}
+test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} {
+ return $var
+ }
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {ccc}
+test iocmd.foreachLine-2.5 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine25.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} {
+ error "line too long"
+ }
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -returnCodes error -result {line too long}
+
# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 4eafb6b..45d2530 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -5,7 +5,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
+# Copyright © 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# See the file "license.terms" for information on usage and redistribution
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Custom constraints used in this file
testConstraint testchannel [llength [info commands testchannel]]
diff --git a/tests/iogt.test b/tests/iogt.test
index 68f9a5c..5692682 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -6,17 +6,17 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# Copyright (c) 2000 Ajuba Solutions.
-# Copyright (c) 2000 Andreas Kupries.
+# Copyright © 2000 Ajuba Solutions.
+# Copyright © 2000 Andreas Kupries.
# All rights reserved.
-if {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
- return
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
namespace eval ::tcl::test::iogt {
namespace import ::tcltest::*
diff --git a/tests/join.test b/tests/join.test
index 9ea554d..3573fbd 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/lindex.test b/tests/lindex.test
index 0b8c327..ffe0d9e 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -4,10 +4,10 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
set minus -
testConstraint testevalex [llength [info commands testevalex]]
@@ -51,22 +51,22 @@ test lindex-2.4 {malformed index list} testevalex {
# Indices that are integers or convertible to integers
-test lindex-3.1 {integer -1} testevalex {
+test lindex-3.1 {integer -1} -constraints testevalex -body {
set x ${minus}1
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
-} {{} {}}
-test lindex-3.2 {integer 0} testevalex {
+} -result {{} {}}
+test lindex-3.2 {integer 0} -constraints testevalex -body {
set x [string range 00 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
-} {a a}
-test lindex-3.3 {integer 2} testevalex {
+} -result {a a}
+test lindex-3.3 {integer 2} -constraints testevalex -body {
set x [string range 22 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
-} {c c}
-test lindex-3.4 {integer 3} testevalex {
+} -result {c c}
+test lindex-3.4 {integer 3} -constraints testevalex -body {
set x [string range 33 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
-} {{} {}}
+} -result {{} {}}
test lindex-3.5 {bad octal} -constraints testevalex -body {
set x 0o8
list [catch { testevalex {lindex {a b c} $x} } result] $result
@@ -75,19 +75,19 @@ test lindex-3.6 {bad octal} -constraints testevalex -body {
set x -0o9
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
-test lindex-3.7 {indexes don't shimmer wide ints} {
+test lindex-3.7 {indexes don't shimmer wide ints} -body {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
-} {2147483646 {} 2147483647 2147483648}
-test lindex-3.8 {compiled with static indices out of range, negative} {
+} -result {2147483646 {} 2147483647 2147483648}
+test lindex-3.8 {compiled with static indices out of range, negative} -body {
list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
-} [lrepeat 3 {}]
-test lindex-3.9 {compiled with calculated indices out of range, negative constant} {
+} -result [lrepeat 3 {}]
+test lindex-3.9 {compiled with calculated indices out of range, negative constant} -body {
list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
-} [lrepeat 3 {}]
-test lindex-3.10 {compiled with calculated indices out of range, after end} {
+} -result [lrepeat 3 {}]
+test lindex-3.10 {compiled with calculated indices out of range, after end} -body {
list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
-} [lrepeat 3 {}]
+} -result [lrepeat 3 {}]
# Indices relative to end
@@ -165,34 +165,38 @@ test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
-test lindex-8.1 {data reuse} testevalex {
+test lindex-8.1 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x $x}
-} {0}
-test lindex-8.2 {data reuse} testevalex {
+} -result 0
+test lindex-8.2 {data reuse} -constraints testevalex -body {
set a 0
testevalex {lindex $a $a $a}
-} 0
-test lindex-8.3 {data reuse} testevalex {
+} -result 0
+test lindex-8.3 {data reuse} -constraints {
+ testevalex
+} -body {
set a 1
testevalex {lindex $a $a $a}
-} {}
-test lindex-8.4 {data reuse} testevalex {
+} -result {}
+test lindex-8.4 {data reuse} -constraints testevalex -body {
set x [list 0 0]
testevalex {lindex $x $x}
-} {0}
-test lindex-8.5 {data reuse} testevalex {
+} -result 0
+test lindex-8.5 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x [list $x $x]}
-} {0}
-test lindex-8.6 {data reuse} testevalex {
+} -result 0
+test lindex-8.6 {data reuse} -constraints testevalex -body {
set x [list 1 1]
testevalex {lindex $x $x}
-} {}
-test lindex-8.7 {data reuse} testevalex {
+} -result {}
+test lindex-8.7 {data reuse} -constraints {
+ testevalex
+} -body {
set x 1
testevalex {lindex $x [list $x $x]}
-} {}
+} -result {}
#----------------------------------------------------------------------
@@ -381,79 +385,76 @@ test lindex-15.3 {quoted elements} {
} result
set result
} {c d " x}
-test lindex-15.4 {quoted elements} {
+test lindex-15.4 {quoted elements} -body {
catch {
lindex {a b {c d "e} {f g"}} 2
} result
set result
-} {c d "e}
+} -result {c d "e}
-test lindex-16.1 {data reuse} {
+test lindex-16.1 {data reuse} -body {
set x 0
catch {
lindex $x $x
} result
set result
-} {0}
-test lindex-16.2 {data reuse} {
+} -result {0}
+test lindex-16.2 {data reuse} -body {
set a 0
catch {
lindex $a $a $a
} result
set result
-} 0
-test lindex-16.3 {data reuse} {
+} -result 0
+test lindex-16.3 {data reuse} -body {
set a 1
catch {
lindex $a $a $a
} result
set result
-} {}
-test lindex-16.4 {data reuse} {
+} -result {}
+test lindex-16.4 {data reuse} -body {
set x [list 0 0]
catch {
lindex $x $x
} result
set result
-} {0}
-test lindex-16.5 {data reuse} {
+} -result {0}
+test lindex-16.5 {data reuse} -body {
set x 0
catch {
lindex $x [list $x $x]
} result
set result
-} {0}
-test lindex-16.6 {data reuse} {
+} -result {0}
+test lindex-16.6 {data reuse} -body {
set x [list 1 1]
catch {
lindex $x $x
} result
set result
-} {}
-test lindex-16.7 {data reuse} {
+} -result {}
+test lindex-16.7 {data reuse} -body {
set x 1
catch {
lindex $x [list $x $x]
} result
set result
-} {}
-
-test lindex-17.0 {Bug 1718580} {*}{
- -body {
- lindex {} end foo
- }
- -match glob
- -result {bad index "foo"*}
- -returnCodes 1
-}
-
-test lindex-17.1 {Bug 1718580} {*}{
- -body {
- lindex a end foo
- }
- -match glob
- -result {bad index "foo"*}
- -returnCodes 1
+} -result {}
+
+test lindex-17.0 {Bug 1718580} -body {
+ lindex {} end foo
+} -match glob -result {bad index "foo"*} -returnCodes 1
+test lindex-17.1 {Bug 1718580} -body {
+ lindex a end foo
+} -match glob -result {bad index "foo"*} -returnCodes 1
+
+test lindex-18.0 {nested bytecode execution} -setup {
+ proc demo {i} {lindex {a b c} $i}
+} -body {
+ demo 0+0x10000000000000000
+} -cleanup {
+ rename demo {}
}
catch { unset minus }
diff --git a/tests/link.test b/tests/link.test
index bd6a708..d515e42 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -4,9 +4,9 @@
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,9 +17,10 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testlink [llength [info commands testlink]]
+testConstraint testlinkarray [llength [info commands testlinkarray]]
foreach i {int real bool string} {
unset -nocomplain $i
@@ -68,9 +69,9 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup {
set long 34543
set ulong 567890
set float 1.0987654321
- set uwide 357357357357
+ set uwide 12345678901234567890
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
-} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357}
+} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 12345678901234567890 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890}
test link-2.2 {writing bad values into variables} -setup {
testlink delete
} -constraints {testlink} -body {
@@ -98,7 +99,7 @@ test link-2.5 {writing bad values into variables} -setup {
testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
list [catch {set wide gorp} msg] $msg $bool
-} -result {1 {can't set "wide": variable must have integer value} 1}
+} -result {1 {can't set "wide": variable must have wide integer value} 1}
test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
@@ -183,6 +184,27 @@ test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup {
set uwide 0
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}
+test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup {
+ testlink delete
+} -body {
+ testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+ testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ set int "0x"
+ set real "0b"
+ set bool 0
+ set string "0"
+ set wide "0D"
+ set char "0X"
+ set uchar "0B"
+ set short "0D"
+ set ushort "0x"
+ set uint "0b"
+ set long "0d"
+ set ulong "0X"
+ set float "0B"
+ set uwide "0D"
+ concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D}
test link-3.1 {read-only variables} -constraints {testlink} -setup {
testlink delete
@@ -352,7 +374,7 @@ test link-7.7 {access to linked variables via upvar} -setup {
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {}
list [catch x msg] $msg $wide
-} -result {1 {can't set "y": variable must have integer value} 778899}
+} -result {1 {can't set "y": variable must have wide integer value} 778899}
test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
@@ -362,11 +384,11 @@ test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
set x {}
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
- trace var int w x
+ trace add var int write x
testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
trace remove variable int write x
return $x
-} {{int {} w} 32 -2.0 0 xyzzy 995511}
+} {{int {} write} 32 -2.0 0 xyzzy 995511}
test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
global x int real bool string wide
@@ -376,7 +398,7 @@ test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
testlink delete
- trace var int w x
+ trace add var int write x
testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340
trace remove variable int write x
return $x
@@ -387,6 +409,477 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
+
+test link-9.1 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
+ testlinkarray
+} -result {wrong # args: should be "testlinkarray option args"}
+test link-9.2 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
+ testlinkarray x
+} -result {bad option "x": must be update, remove, or create}
+test link-9.3 {linkarray usage messages} -constraints testlinkarray -body {
+ testlinkarray update
+} -result {}
+test link-9.4 {linkarray usage messages} -constraints testlinkarray -body {
+ testlinkarray remove
+} -result {}
+test link-9.5 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
+ testlinkarray create
+} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"}
+test link-9.6 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
+ testlinkarray create xx 1 my
+} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary}
+test link-9.7 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
+ testlinkarray create char* 0 my
+} -result {wrong array size given}
+
+test link-10.1 {linkarray char*} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create char* 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{} {can't set "::my(var)": wrong size of char* value}}
+test link-10.2 {linkarray char*} -constraints testlinkarray -body {
+ testlinkarray create char* 4 ::my(var)
+ set ::my(var) x
+ catch {set ::my(var) xyzz} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": wrong size of char* value}
+test link-10.3 {linkarray char*} -constraints testlinkarray -body {
+ testlinkarray create -r char* 4 ::my(var)
+ catch {set ::my(var) x} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-11.1 {linkarray char} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create char 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1234} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}}
+test link-11.2 {linkarray char} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create char 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-11.3 {linkarray char} -constraints testlinkarray -body {
+ testlinkarray create -r char 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-12.1 {linkarray unsigned char} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uchar 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1234} msg
+ lappend mylist $msg
+ catch {set ::my(var) -1} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}}
+test link-12.2 {linkarray unsigned char} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uchar 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-12.3 {linkarray unsigned char} -constraints testlinkarray -body {
+ testlinkarray create -r uchar 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-13.1 {linkarray short} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create short 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 123456} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}}
+test link-13.2 {linkarray short} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create short 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-13.3 {linkarray short} -constraints testlinkarray -body {
+ testlinkarray create -r short 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-14.1 {linkarray unsigned short} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create ushort 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 123456} msg
+ lappend mylist $msg
+ catch {set ::my(var) -1} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}}
+test link-14.2 {linkarray unsigned short} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create ushort 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-14.3 {linkarray unsigned short} -constraints testlinkarray -body {
+ testlinkarray create -r ushort 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-15.1 {linkarray int} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create int 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e3} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}}
+test link-15.2 {linkarray int} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create int 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-15.3 {linkarray int} -constraints testlinkarray -body {
+ testlinkarray create -r int 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-16.1 {linkarray unsigned int} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uint 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} msg
+ lappend mylist $msg
+ catch {set ::my(var) -1} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain ::my
+} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}}
+test link-16.2 {linkarray unsigned int} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uint 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain ::my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-16.3 {linkarray unsigned int} -constraints testlinkarray -body {
+ testlinkarray create -r uint 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-17.1 {linkarray long} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create long 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} msg
+ lappend mylist $msg
+} -match glob -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}}
+test link-17.2 {linkarray long} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create long 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-17.3 {linkarray long} -constraints testlinkarray -body {
+ testlinkarray create -r long 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-18.1 {linkarray unsigned long} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create ulong 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} msg
+ lappend mylist $msg
+} -match glob -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}}
+test link-18.2 {linkarray unsigned long} -constraints testlinkarray -body {
+ testlinkarray create ulong 1 ::my(var)
+ set ::my(var) 120
+ catch {set ::my(var) -1} msg
+ return $msg
+} -match glob -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": variable must have unsigned * value}
+test link-18.3 {linkarray unsigned long} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create ulong 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-18.4 {linkarray unsigned long} -constraints testlinkarray -body {
+ testlinkarray create -r ulong 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-19.1 {linkarray wide} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create wide 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} msg
+ lappend mylist $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}}
+test link-19.2 {linkarray wide} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create wide 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-19.3 {linkarray wide} -constraints testlinkarray -body {
+ testlinkarray create -r wide 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-20.1 {linkarray unsigned wide} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uwide 1 ::my(var)
+ catch {set ::my(var) x} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 120]
+ catch {set ::my(var) 1e33} msg
+ lappend mylist $msg
+ lappend mylist [set ::my(var) 0xbabed00dbabed00d]
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d}
+test link-20.2 {linkarray unsigned wide} -constraints testlinkarray -body {
+ testlinkarray create uwide 1 ::my(var)
+ set ::my(var) 120
+ catch {set ::my(var) -1} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": variable must have unsigned wide int value}
+test link-20.3 {linkarray unsigned wide} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create uwide 4 ::my(var)
+ catch {set ::my(var) {1 2 3}} msg
+ lappend mylist $msg
+ set ::my(var) {1 2 3 4}
+ lappend mylist $my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
+test link-20.4 {linkarray unsigned wide} -constraints testlinkarray -body {
+ testlinkarray create -r uwide 2 ::my(var)
+ catch {set ::my(var) {1 2}} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-21.1 {linkarray string} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create string 1 ::my(var)
+ lappend mylist [set ::my(var) ""]
+ lappend mylist [set ::my(var) "xyz"]
+ lappend mylist $::my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{} xyz xyz}
+test link-21.2 {linkarray string} -constraints testlinkarray -body {
+ testlinkarray create -r string 4 ::my(var)
+ catch {set ::my(var) x} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
+
+test link-22.1 {linkarray binary} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create binary 1 ::my(var)
+ set ::my(var) x
+ catch {set ::my(var) xy} msg
+ lappend mylist $msg
+ lappend mylist $::my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong size of binary value} x}
+test link-22.2 {linkarray binary} -constraints testlinkarray -setup {
+ set mylist [list]
+} -body {
+ testlinkarray create binary 4 ::my(var)
+ catch {set ::my(var) abc} msg
+ lappend mylist $msg
+ catch {set ::my(var) abcde} msg
+ lappend mylist $msg
+ set ::my(var) abcd
+ lappend mylist $::my(var)
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd}
+test link-22.3 {linkarray binary} -constraints testlinkarray -body {
+ testlinkarray create -r binary 4 ::my(var)
+ catch {set ::my(var) xyzv} msg
+ return $msg
+} -cleanup {
+ testlinkarray remove ::my(var)
+ unset -nocomplain my
+} -result {can't set "::my(var)": linked variable is read-only}
catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0}
catch {testlink delete}
diff --git a/tests/linsert.test b/tests/linsert.test
index ddc56a9..16ade39 100644
--- a/tests/linsert.test
+++ b/tests/linsert.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/list.test b/tests/list.test
index 864fad0..905a3d3 100644
--- a/tests/list.test
+++ b/tests/list.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -45,23 +45,23 @@ test list-1.24 {basic tests} {list} {}
test list-1.25 {basic tests} {list # #} {{#} #}
test list-1.26 {basic tests} {list #\{ #\{} {\#\{ #\{}
test list-1.27 {basic null treatment} {
- set l [list "" "\0" "\0\0"]
- set e "{} \0 \0\0"
+ set l [list "" "\x00" "\x00\x00"]
+ set e "{} \x00 \x00\x00"
string equal $l $e
} 1
test list-1.28 {basic null treatment} {
- set result "\0a\0b"
+ set result "\x00a\x00b"
list $result [string length $result]
-} "\0a\0b 4"
+} "\x00a\x00b 4"
test list-1.29 {basic null treatment} {
- set result "\0a\0b"
+ set result "\x00a\x00b"
set srep "$result 4"
set lrep [list $result [string length $result]]
string equal $srep $lrep
} 1
test list-1.30 {basic null treatment} {
- set l [list "\0abc" "xyz"]
- set e "\0abc xyz"
+ set l [list "\x00abc" "xyz"]
+ set e "\x00abc xyz"
string equal $l $e
} 1
diff --git a/tests/listObj.test b/tests/listObj.test
index d60f13f..55fc089 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -5,8 +5,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,9 +17,10 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
+testConstraint memory [llength [info commands memory]]
catch {unset x}
test listobj-1.1 {Tcl_GetListObjType} emptyTest {
@@ -210,6 +211,106 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj
testobj bug3598580
} 123
+# Stolen from dict.test
+proc listobjmemcheck script {
+ set end [lindex [split [memory info] \n] 3 3]
+ for {set i 0} {$i < 5} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [lindex [split [memory info] \n] 3 3]
+ }
+ expr {$end - $tmp}
+}
+
+test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [lrepeat 1000 x]
+ set errorMessage [testlistobj indexmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [testlistrep new 1000 100 100]
+ set errorMessage [testlistobj indexmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [lseq 1000]
+ set errorMessage [testlistobj indexmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+
+test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [lrepeat 1000 x]
+ set errorMessage [testlistobj getelementsmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [testlistrep new 1000 100 100]
+ set errorMessage [testlistobj getelementsmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints {
+ testobj memory
+} -body {
+ list [listobjmemcheck {
+ testobj set 1 [lseq 1000]
+ set errorMessage [testlistobj getelementsmemcheck 1]
+ testobj freeallvars
+ }] $errorMessage
+} -result {0 {}}
+
+# Tests for Tcl_ListObjIndex as sematics are different from lindex for
+# out of bounds indices. Out of bounds should return a null pointer and
+# not empty string.
+test listobj-14.1 {Tcl_ListObjIndex out-of-bounds index for native lists} -constraints {
+ testobj
+} -setup {
+ testobj set 1 [list a b c]
+} -cleanup {
+ testobj freeallvars
+} -body {
+ list [testlistobj index 1 -1] [testlistobj index 1 3]
+} -result {null null}
+
+test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with spans} -constraints {
+ testobj
+} -setup {
+ testobj set 1 [testlistrep new 1000 100 100]
+} -cleanup {
+ testobj freeallvars
+} -body {
+ list [testlistobj index 1 -1] [testlistobj index 1 1000]
+} -result {null null}
+
+test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints {
+ testobj
+} -setup {
+ testobj set 1 [lseq 3]
+} -cleanup {
+ testobj freeallvars
+} -body {
+ list [testlistobj index 1 -1] [testlistobj index 1 3]
+} -result {null null}
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/listRep.test b/tests/listRep.test
new file mode 100644
index 0000000..02ff18f
--- /dev/null
+++ b/tests/listRep.test
@@ -0,0 +1,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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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()
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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)
+} -constraints testlistrep -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)
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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
+} -constraints testlistrep -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()
+} -constraints testlistrep -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
diff --git a/tests/llength.test b/tests/llength.test
index a2770c0..1122341 100644
--- a/tests/llength.test
+++ b/tests/llength.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/lmap.test b/tests/lmap.test
index d986ee2..f1cbd4b 100644
--- a/tests/lmap.test
+++ b/tests/lmap.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 2011 Trevor Davel
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 2011 Trevor Davel
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/load.test b/tests/load.test
index 78087bc..005c451 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1995 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
@@ -36,9 +36,9 @@ testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}]
set alreadyTotalLoaded [info loaded]
-# Certain tests require the 'teststaticpkg' command from tcltest
+# Certain tests require the 'teststaticlibrary' command from tcltest
-testConstraint teststaticpkg [llength [info commands teststaticpkg]]
+testConstraint teststaticlibrary [llength [info commands teststaticlibrary]]
# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest
@@ -47,28 +47,28 @@ testConstraint testsimplefilesystem \
test load-1.1 {basic errors} -returnCodes error -body {
load
-} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
+} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"}
test load-1.2 {basic errors} -returnCodes error -body {
load a b c d
-} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
+} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"}
test load-1.3 {basic errors} -returnCodes error -body {
load a b foobar
} -result {could not find interpreter "foobar"}
test load-1.4 {basic errors} -returnCodes error -body {
load -global {}
-} -result {must specify either file name or package name}
+} -result {must specify either file name or prefix}
test load-1.5 {basic errors} -returnCodes error -body {
load -lazy {} {}
-} -result {must specify either file name or package name}
+} -result {must specify either file name or prefix}
test load-1.6 {basic errors} -returnCodes error -body {
load {} Unknown
-} -result {package "Unknown" isn't loaded statically}
+} -result {no library with prefix "Unknown" is loaded statically}
test load-1.7 {basic errors} -returnCodes error -body {
load -abc foo
} -result {bad option "-abc": must be -global, -lazy, or --}
test load-1.8 {basic errors} -returnCodes error -body {
load -global
-} -result {couldn't figure out package name for -global}
+} -result {couldn't figure out prefix for -global}
test load-2.1 {basic loading, with guess for package name} \
[list $dll $loaded] {
@@ -84,17 +84,17 @@ test load-2.2 {loading into a safe interpreter, with package name conversion} \
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
- list [catch {load [file join $testDir pkgc$ext] Foo} msg] $msg $errorCode
+ list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode
} -match glob \
-result [list 1 {cannot find symbol "Foo_Init"*} \
{TCL LOOKUP LOAD_SYMBOL *Foo_Init}]
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
-} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
+} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}}
test load-3.1 {error in _Init procedure, same interpreter} \
[list $dll $loaded] {
- list [catch {load [file join $testDir pkge$ext] Pkge} msg] \
+ list [catch {load [file join $testDir pkge$ext] pkge} msg] \
$msg $::errorInfo $::errorCode
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
while executing
@@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \
invoked from within
"if 44 {open non_existent}"
invoked from within
-"load [file join $testDir pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}}
+"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
test load-3.2 {error in _Init procedure, child interpreter} \
[list $dll $loaded] {
catch {interp delete x}
interp create x
set ::errorCode foo
set ::errorInfo bar
- set result [list [catch {load [file join $testDir pkge$ext] Pkge x} msg] \
+ set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
$msg $::errorInfo $::errorCode]
interp delete x
set result
@@ -119,16 +119,16 @@ test load-3.2 {error in _Init procedure, child interpreter} \
invoked from within
"if 44 {open non_existent}"
invoked from within
-"load [file join $testDir pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}}
+"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
- list [catch {load [file join $testDir pkga$ext] Pkga} msg] $msg
+ list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
} {0 {}}
test load-4.2 {reloading package into same interpreter} -setup {
catch {load [file join $testDir pkga$ext] Pkga}
} -constraints [list $dll $loaded] -returnCodes error -body {
load [file join $testDir pkga$ext] Pkgb
-} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""
+} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\""
test load-5.1 {file name not specified and no static package: pick default} -setup {
catch {interp delete x}
@@ -150,78 +150,78 @@ test load-6.1 {errors loading file} [list $dll $loaded] {
catch {load foo foo}
} {1}
-test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
- teststaticpkg Test 1 0
- load {} Test
- load {} Test child
+ teststaticlibrary Test 1 0
+ load {} test
+ load {} test child
list [set x] [child eval set x]
} {loaded loaded}
-test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
- teststaticpkg Another 0 0
+ teststaticlibrary Another 0 0
load {} Another
child eval {set x "not loaded"}
list [catch {load {} Another child} msg] $msg \
[child eval set x] [set x]
-} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
-test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
+test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] {
set x "not loaded"
- teststaticpkg More 0 1
- load {} More
+ teststaticlibrary More 0 1
+ load {} more
set x
} {not loaded}
catch {load [file join $testDir pkga$ext] Pkga}
catch {load [file join $testDir pkgb$ext] Pkgb}
catch {load [file join $testDir pkge$ext] Pkge}
-set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]]
-test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup {
- teststaticpkg Test 1 0
- teststaticpkg Another 0 0
- teststaticpkg More 0 1
-} -constraints [list teststaticpkg $dll $loaded] -body {
- teststaticpkg Double 0 1
- teststaticpkg Double 0 1
+set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]]
+test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup {
+ teststaticlibrary Test 1 0
+ teststaticlibrary Another 0 0
+ teststaticlibrary More 0 1
+} -constraints [list teststaticlibrary $dll $loaded] -body {
+ teststaticlibrary Double 0 1
+ teststaticlibrary Double 0 1
info loaded
-} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]
+} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]
-testConstraint teststaticpkg_8.x 0
-if {[testConstraint teststaticpkg]} {
+testConstraint teststaticlibrary_8.x 0
+if {[testConstraint teststaticlibrary]} {
catch {
- teststaticpkg Test 1 1
- teststaticpkg Another 0 1
- teststaticpkg More 0 1
- teststaticpkg Double 0 1
- testConstraint teststaticpkg_8.x 1
+ teststaticlibrary Test 1 1
+ teststaticlibrary Another 0 1
+ teststaticlibrary More 0 1
+ teststaticlibrary Double 0 1
+ testConstraint teststaticlibrary_8.x 1
}
}
-test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
+test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] {
lsort -index 1 [info loaded]
-} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]]
-test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body {
+} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]]
+test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body {
info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
-test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
+test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] {
lsort -index 1 [info loaded {}]
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]]
-test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
+test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] {
lsort -index 1 [info loaded child]
} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
-test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
+test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] {
load [file join $testDir pkgb$ext] Pkgb
list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]]
} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
-test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup {
+test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup {
interp create child1
interp create child2
load {} Tcltest child1
load {} Tcltest child2
-} -constraints {teststaticpkg} -body {
- child1 eval { teststaticpkg Loadninepointone 0 1 }
- child2 eval { teststaticpkg Loadninepointone 0 1 }
+} -constraints {teststaticlibrary} -body {
+ child1 eval { teststaticlibrary Loadninepointone 0 1 }
+ child2 eval { teststaticlibrary Loadninepointone 0 1 }
list [child1 eval { info loaded {} }] \
[child2 eval { info loaded {} }]
} -match glob -cleanup {
diff --git a/tests/lpop.test b/tests/lpop.test
new file mode 100644
index 0000000..272c82f
--- /dev/null
+++ b/tests/lpop.test
@@ -0,0 +1,145 @@
+# Commands covered: lpop
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
+
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
+
+unset -nocomplain no; # following tests expecting var "no" does not exists
+test lpop-1.1 {error conditions} -returnCodes error -body {
+ lpop no
+} -result {can't read "no": no such variable}
+test lpop-1.2 {error conditions} -returnCodes error -body {
+ lpop no 0
+} -result {can't read "no": no such variable}
+test lpop-1.3 {error conditions} -returnCodes error -body {
+ set l "x {}x"
+ lpop l
+} -result {list element in braces followed by "x" instead of space}
+test lpop-1.4 {error conditions} -returnCodes error -body {
+ set l "x y"
+ lpop l -1
+} -result {index "-1" out of range}
+test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body {
+ set l "x y"
+ list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l
+} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}}
+test lpop-1.5 {error conditions} -returnCodes error -body {
+ set l "x y z"
+ lpop l 3
+} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX}
+test lpop-1.6 {error conditions} -returnCodes error -body {
+ set l "x y"
+ lpop l end+1
+} -result {index "end+1" out of range}
+test lpop-1.7 {error conditions} -returnCodes error -body {
+ set l "x y"
+ lpop l {}
+} -match glob -result {bad index *}
+test lpop-1.8 {error conditions} -returnCodes error -body {
+ set l "x y"
+ lpop l 0 0 0 0 1
+} -result {index "1" out of range}
+test lpop-1.9 {error conditions} -returnCodes error -body {
+ set l "x y"
+ lpop l {1 0}
+} -match glob -result {bad index *}
+
+test lpop-2.1 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l 0] $l
+} -result {x {y z}}
+test lpop-2.2 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l 1] $l
+} -result {y {x z}}
+test lpop-2.3 {basic functionality} -body {
+ set l "x y z"
+ list [lpop l] $l
+} -result {z {x y}}
+test lpop-2.4 {basic functionality} -body {
+ set l "x y z"
+ set l2 $l
+ list [lpop l] $l $l2
+} -result {z {x y} {x y z}}
+
+test lpop-3.1 {nested} -body {
+ set l "x y"
+ set l2 $l
+ list [lpop l 0 0 0 0] $l $l2
+} -result {x {{{{}}} y} {x y}}
+test lpop-3.2 {nested} -body {
+ set l "{x y} {a b}"
+ list [lpop l 0 1] $l
+} -result {y {x {a b}}}
+test lpop-3.3 {nested} -body {
+ set l "{x y} {a b}"
+ list [lpop l 1 0] $l
+} -result {a {{x y} b}}
+
+
+
+
+
+test lpop-99.1 {performance} -constraints perf -body {
+ set l [lrepeat 10000 x]
+ set l2 $l
+ set t1 [time {
+ while {[llength $l] >= 2} {
+ lpop l end
+ }
+ }]
+ set l [lrepeat 30000 x]
+ set l2 $l
+ set t2 [time {
+ while {[llength $l] >= 2} {
+ lpop l end
+ }
+ }]
+ regexp {\d+} $t1 ms1
+ regexp {\d+} $t2 ms2
+ set ratio [expr {double($ms2)/$ms1}]
+ # Deleting from end should have linear performance
+ expr {$ratio > 4 ? $ratio : 4}
+} -result {4}
+
+test lpop-99.2 {performance} -constraints perf -body {
+ set l [lrepeat 10000 x]
+ set l2 $l
+ set t1 [time {
+ while {[llength $l] >= 2} {
+ lpop l 1
+ }
+ }]
+ set l [lrepeat 30000 x]
+ set l2 $l
+ set t2 [time {
+ while {[llength $l] >= 2} {
+ lpop l 1
+ }
+ }]
+ regexp {\d+} $t1 ms1
+ regexp {\d+} $t2 ms2
+ set ratio [expr {double($ms2)/$ms1}]
+ expr {$ratio > 10 ? $ratio : 10}
+} -result {10}
+
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/lrange.test b/tests/lrange.test
index 6765038..695c370 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,10 +17,9 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
-
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
@@ -96,16 +95,15 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
-
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
-test lrange-3.4 {compiled with calculated indices out of range, after end} {
+test lrange-3.4 {compiled with calculated indices out of range, after end} -body {
list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
-} [lrepeat 4 {}]
+} -result [lrepeat 4 {}]
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
@@ -118,22 +116,22 @@ test lrange-3.7a {compiled on empty not canonical list (with static and dynamic
list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
[lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
-test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
+test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
[$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
-} [lrepeat 6 {}]
+} -result [lrepeat 6 {}]
# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
# (as before the fix [58c46e74b931d3a1]):
test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
-test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
+test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
-} [lrepeat 6 {}]
+} -result [lrepeat 6 {}]
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
@@ -148,6 +146,107 @@ test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
+test lrange-4.1 {lrange pure promise} -body {
+ set ll1 [list $tcl_version 2 3 4]
+ # Shared
+ set ll2 $ll1
+ # With string rep
+ string length $ll1
+ set rep1 [tcl::unsupported::representation $ll1]
+ # Get new pure object
+ set x [lrange $ll1 0 end]
+ set rep2 [tcl::unsupported::representation $x]
+ regexp {object pointer at (\S+)} $rep1 -> obj1
+ regexp {object pointer at (\S+)} $rep2 -> obj2
+ list $rep1 $rep2 [string equal $obj1 $obj2]
+ # Check for a new clean object
+} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
+
+test lrange-4.2 {lrange pure promise} -body {
+ set ll1 [list $tcl_version 2 3 4]
+ # Shared
+ set ll2 $ll1
+ # With string rep
+ string length $ll1
+ set rep1 [tcl::unsupported::representation $ll1]
+ # Get new pure object, not compiled
+ set x [[string cat l range] $ll1 0 end]
+ set rep2 [tcl::unsupported::representation $x]
+ regexp {object pointer at (\S+)} $rep1 -> obj1
+ regexp {object pointer at (\S+)} $rep2 -> obj2
+ list $rep1 $rep2 [string equal $obj1 $obj2]
+ # Check for a new clean object
+} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
+
+test lrange-4.3 {lrange pure promise} -body {
+ set ll1 [list $tcl_version 2 3 4]
+ # With string rep
+ string length $ll1
+ set rep1 [tcl::unsupported::representation $ll1]
+ # Get pure object, unshared
+ set ll2 [lrange $ll1[set ll1 {}] 0 end]
+ set rep2 [tcl::unsupported::representation $ll2]
+ regexp {object pointer at (\S+)} $rep1 -> obj1
+ regexp {object pointer at (\S+)} $rep2 -> obj2
+ list $rep1 $rep2 [string equal $obj1 $obj2]
+ # Internal optimisations should keep the same object
+} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
+
+test lrange-4.4 {lrange pure promise} -body {
+ set ll1 [list $tcl_version 2 3 4]
+ # With string rep
+ string length $ll1
+ set rep1 [tcl::unsupported::representation $ll1]
+ # Get pure object, unshared, not compiled
+ set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end]
+ set rep2 [tcl::unsupported::representation $ll2]
+ regexp {object pointer at (\S+)} $rep1 -> obj1
+ regexp {object pointer at (\S+)} $rep2 -> obj2
+ list $rep1 $rep2 [string equal $obj1 $obj2]
+ # Internal optimisations should keep the same object
+} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
+
+# Testing for compiled vs non-compiled behaviour, and shared vs non-shared.
+# Far too many variations to check with spelt-out tests.
+# Note that this *just* checks whether the different versions are the same
+# not whether any of them is correct.
+apply {{} {
+ set lss {{} {a} {a b c} {a b c d}}
+ set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
+ set lrange lrange
+
+ foreach ls $lss {
+ foreach a $idxs {
+ foreach b $idxs {
+ # Shared, uncompiled
+ set ls2 $ls
+ set expected [list [catch {$lrange $ls $a $b} m] $m]
+ # Shared, compiled
+ set tester [list lrange $ls $a $b]
+ set script [list catch $tester m]
+ set script "list \[$script\] \$m"
+ test lrange-5.[incr n].1 {lrange shared compiled} -body \
+ [list apply [list {} $script]] -result $expected
+ # Unshared, uncompiled
+ set tester [string map [list %l [list $ls] %a $a %b $b] {
+ [string cat l range] [lrange %l 0 end] %a %b
+ }]
+ set script [list catch $tester m]
+ set script "list \[$script\] \$m"
+ test lrange-5.$n.2 {lrange unshared uncompiled} -body \
+ [list apply [list {} $script]] -result $expected
+ # Unshared, compiled
+ set tester [string map [list %l [list $ls] %a $a %b $b] {
+ lrange [lrange %l 0 end] %a %b
+ }]
+ set script [list catch $tester m]
+ set script "list \[$script\] \$m"
+ test lrange-5.$n.3 {lrange unshared compiled} -body \
+ [list apply [list {} $script]] -result $expected
+ }
+ }
+ }
+}}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lrepeat.test b/tests/lrepeat.test
index f62f35f..c1c8b02 100644
--- a/tests/lrepeat.test
+++ b/tests/lrepeat.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2003 by Simon Geard.
+# Copyright © 2003 Simon Geard.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/lreplace.test b/tests/lreplace.test
index b7caf47..55b3ee3 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -111,27 +111,27 @@ test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
-test lreplace-2.1 {lreplace errors} {
+test lreplace-2.1 {lreplace errors} -body {
list [catch lreplace msg] $msg
-} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
-test lreplace-2.2 {lreplace errors} {
+} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
+test lreplace-2.2 {lreplace errors} -body {
list [catch {lreplace a b} msg] $msg
-} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
-test lreplace-2.3 {lreplace errors} {
+} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
+test lreplace-2.3 {lreplace errors} -body {
list [catch {lreplace x a 10} msg] $msg
-} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
-test lreplace-2.4 {lreplace errors} {
+} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
+test lreplace-2.4 {lreplace errors} -body {
list [catch {lreplace x 10 x} msg] $msg
-} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
-test lreplace-2.5 {lreplace errors} {
+} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
+test lreplace-2.5 {lreplace errors} -body {
list [catch {lreplace x 10 1x} msg] $msg
-} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
-test lreplace-2.6 {lreplace errors} {
+} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
+test lreplace-2.6 {lreplace errors} -body {
list [catch {lreplace x 3 2} msg] $msg
-} {0 x}
-test lreplace-2.7 {lreplace errors} {
+} -result {0 x}
+test lreplace-2.7 {lreplace errors} -body {
list [catch {lreplace x 2 2} msg] $msg
-} {0 x}
+} -result {0 x}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
@@ -228,8 +228,312 @@ apply {{} {
set tester [list lreplace $ls $a $b {*}$i]
set script [list catch $tester m]
set script "list \[$script\] \$m"
- test lreplace-6.[incr n] {lreplace battery} \
- [list apply [list {} $script]] $expected
+ test lreplace-6.[incr n] {lreplace battery} -body \
+ [list apply [list {} $script]] -result $expected
+ }
+ }
+ }
+ }
+}}
+
+# Essentially same tests as above but for ledit
+test ledit-1.1 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 0 a] $l
+} {{a 2 3 4 5} {a 2 3 4 5}}
+test ledit-1.2 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 1 1 a] $l
+} {{1 a 3 4 5} {1 a 3 4 5}}
+test ledit-1.3 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 2 a] $l
+} {{1 2 a 4 5} {1 2 a 4 5}}
+test ledit-1.4 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 3 a] $l
+} {{1 2 3 a 5} {1 2 3 a 5}}
+test ledit-1.5 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.6 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 4 5 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.7 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l -1 -1 a] $l
+} {{a 1 2 3 4 5} {a 1 2 3 4 5}}
+test ledit-1.8 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 end a b c d] $l
+} {{1 2 a b c d} {1 2 a b c d}}
+test ledit-1.9 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 3] $l
+} {5 5}
+test ledit-1.10 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 4] $l
+} {{} {}}
+test ledit-1.11 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 0 1] $l
+} {{3 4 5} {3 4 5}}
+test ledit-1.12 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 2 3] $l
+} {{1 2 5} {1 2 5}}
+test ledit-1.13 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 end] $l
+} {{1 2 3} {1 2 3}}
+test ledit-1.14 {ledit command} {
+ set l {1 2 3 4 5}
+ list [ledit l -1 4 a b c] $l
+} {{a b c} {a b c}}
+test ledit-1.15 {ledit command} {
+ set l {a b "c c" d e f}
+ list [ledit l 3 3] $l
+} {{a b {c c} e f} {a b {c c} e f}}
+test ledit-1.16 {ledit command} {
+ set l { 1 2 3 4 5}
+ list [ledit l 0 0 a] $l
+} {{a 2 3 4 5} {a 2 3 4 5}}
+test ledit-1.17 {ledit command} {
+ set l {1 2 3 4 "5 6"}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.18 {ledit command} {
+ set l {1 2 3 4 {5 6}}
+ list [ledit l 4 4 a] $l
+} {{1 2 3 4 a} {1 2 3 4 a}}
+test ledit-1.19 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l 2 end x y z] $l
+} {{1 2 x y z} {1 2 x y z}}
+test ledit-1.20 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end end a] $l
+} {{1 2 3 a} {1 2 3 a}}
+test ledit-1.21 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end 3 a] $l
+} {{1 2 3 a} {1 2 3 a}}
+test ledit-1.22 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end end] $l
+} {{1 2 3} {1 2 3}}
+test ledit-1.23 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l 2 -1 xy] $l
+} {{1 2 xy 3 4} {1 2 xy 3 4}}
+test ledit-1.24 {ledit command} {
+ set l {1 2 3 4}
+ list [ledit l end -1 z] $l
+} {{1 2 3 z 4} {1 2 3 z 4}}
+test ledit-1.25 {ledit command} {
+ set l {\}\ hello}
+ concat \"[ledit l end end]\" $l
+} {"\}\ " \}\ }
+test ledit-1.26 {ledit command} {
+ catch {unset foo}
+ set foo {a b}
+ list [ledit foo end end] $foo \
+ [ledit foo end end] $foo \
+ [ledit foo end end] $foo
+} {a a {} {} {} {}}
+test ledit-1.27 {lsubset command} -body {
+ set l x
+ list [ledit l 1 1] $l
+} -result {x x}
+test ledit-1.28 {ledit command} -body {
+ set l x
+ list [ledit l 1 1 y] $l
+} -result {{x y} {x y}}
+test ledit-1.29 {ledit command} -body {
+ set l x
+ ledit l 1 1 [error foo]
+} -returnCodes 1 -result {foo}
+test ledit-1.30 {ledit command} -body {
+ set l {not {}alist}
+ ledit l 0 0 [error foo]
+} -returnCodes 1 -result {foo}
+test ledit-1.31 {ledit command} -body {
+ unset -nocomplain arr
+ set arr(x) {a b}
+ list [ledit arr(x) 0 0 c] $arr(x)
+} -result {{c b} {c b}}
+
+test ledit-2.1 {ledit errors} -body {
+ list [catch ledit msg] $msg
+} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}}
+test ledit-2.2 {ledit errors} -body {
+ unset -nocomplain x
+ list [catch {ledit l b} msg] $msg
+} -result {1 {wrong # args: should be "ledit listVar first last ?element ...?"}}
+test ledit-2.3 {ledit errors} -body {
+ set x {}
+ list [catch {ledit x a 10} msg] $msg
+} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.4 {ledit errors} -body {
+ set l {}
+ list [catch {ledit l 10 x} msg] $msg
+} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.5 {ledit errors} -body {
+ set l {}
+ list [catch {ledit l 10 1x} msg] $msg
+} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
+test ledit-2.6 {ledit errors} -body {
+ set l x
+ list [catch {ledit l 3 2} msg] $msg
+} -result {0 x}
+test ledit-2.7 {ledit errors} -body {
+ set l x
+ list [catch {ledit l 2 2} msg] $msg
+} -result {0 x}
+test ledit-2.8 {ledit errors} -body {
+ unset -nocomplain l
+ ledit l 0 0 x
+} -returnCodes error -result {can't read "l": no such variable}
+test ledit-2.9 {ledit errors} -body {
+ unset -nocomplain arr
+ ledit arr(x) 0 0 x
+} -returnCodes error -result {can't read "arr(x)": no such variable}
+test ledit-2.10 {ledit errors} -body {
+ unset -nocomplain arr
+ set arr(y) y
+ ledit arr(x) 0 0 x
+} -returnCodes error -result {can't read "arr(x)": no such element in array}
+
+test ledit-3.1 {ledit won't modify shared argument objects} {
+ proc p {} {
+ set l "a b c"
+ ledit l 1 1 "x y"
+ # The literal in locals table should be unmodified
+ return [list "a b c" $l]
+ }
+ p
+} {{a b c} {a {x y} c}}
+
+# Following bugs were in lreplace. Make sure ledit does not have them
+test ledit-4.1 {Bug ccc2c2cc98: lreplace edge case} {
+ set l {}
+ list [ledit l 1 1] $l
+} {{} {}}
+test ledit-4.2 {Bug ccc2c2cc98: lreplace edge case} {
+ set l { }
+ list [ledit l 1 1] $l
+} {{} {}}
+test ledit-4.3 {lreplace edge case} {
+ set l {1 2 3}
+ ledit l 2 0
+} {1 2 3}
+test ledit-4.4 {ledit edge case} {
+ set l {1 2 3 4 5}
+ list [ledit l 3 1] $l
+} {{1 2 3 4 5} {1 2 3 4 5}}
+test ledit-4.5 {ledit edge case} {
+ lreplace {1 2 3 4 5} 3 0 _
+} {1 2 3 _ 4 5}
+test ledit-4.6 {ledit end-x: bug a4cb3f06c4} {
+ set l {0 1 2 3 4}
+ list [ledit l 0 end-2] $l
+} {{3 4} {3 4}}
+test ledit-4.6.1 {ledit end-x: bug a4cb3f06c4} {
+ set l {0 1 2 3 4}
+ list [ledit l 0 end-2 a b c] $l
+} {{a b c 3 4} {a b c 3 4}}
+test ledit-4.7 {ledit with two end-indexes: increasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-1] $l
+} {{0 1 4} {0 1 4}}
+test ledit-4.7.1 {ledit with two end-indexes: increasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-1 a b c] $l
+} {{0 1 a b c 4} {0 1 a b c 4}}
+test ledit-4.8 {ledit with two end-indexes: equal} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-2] $l
+} {{0 1 3 4} {0 1 3 4}}
+test ledit-4.8.1 {ledit with two end-indexes: equal} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.9 {ledit with two end-indexes: decreasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-3] $l
+} {{0 1 2 3 4} {0 1 2 3 4}}
+test ledit-4.9.1 {ledit with two end-indexes: decreasing} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 end-3 a b c] $l
+} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}}
+test ledit-4.10 {ledit with two equal indexes} {
+ set l {0 1 2 3 4}
+ list [ledit l 2 2] $l
+} {{0 1 3 4} {0 1 3 4}}
+test ledit-4.10.1 {ledit with two equal indexes} {
+ set l {0 1 2 3 4}
+ list [ledit l 2 2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.11 {ledit end index first} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 1 a b c] $l
+} {{0 1 a b c 2 3 4} {0 1 a b c 2 3 4}}
+test ledit-4.12 {ledit end index first} {
+ set l {0 1 2 3 4}
+ list [ledit l end-2 2 a b c] $l
+} {{0 1 a b c 3 4} {0 1 a b c 3 4}}
+test ledit-4.13 {ledit empty list} {
+ set l {}
+ list [ledit l 1 1 1] $l
+} {1 1}
+test ledit-4.14 {ledit empty list} {
+ set l {}
+ list [ledit l 2 2 2] $l
+} {2 2}
+
+test ledit-5.1 {compiled lreplace: Bug 47ac84309b} {
+ apply {x {
+ ledit x end 0
+ }} {a b c}
+} {a b c}
+test ledit-5.2 {compiled lreplace: Bug 47ac84309b} {
+ apply {x {
+ ledit x end 0 A
+ }} {a b c}
+} {a b A c}
+
+test ledit-bug-a366c6efee {Bug [a366c6efee]} -body {
+ apply {{} {
+ set l { }
+ string length [ledit l 1 1]; # Force string generation
+ set result foo
+ append result " " bar
+ }}
+} -result "foo bar"
+
+# Testing for compiled behaviour. Far too many variations to check with
+# spelt-out tests. Note that this *just* checks whether the compiled version
+# and the interpreted version are the same, not whether the interpreted
+# version is correct.
+apply {{} {
+ set lss {{} {a} {a b c} {a b c d}}
+ set ins {{} A {A B}}
+ set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
+ set lreplace lreplace
+
+ foreach ls $lss {
+ foreach a $idxs {
+ foreach b $idxs {
+ foreach i $ins {
+ set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
+ set tester [list ledit ls $a $b {*}$i]
+ set script [list catch $tester m]
+ set script "list \[$script\] \$m"
+ test ledit-6.[incr n] {ledit battery} -body \
+ [list apply [list {ls} $script] $ls] -result $expected
}
}
}
diff --git a/tests/lsearch.test b/tests/lsearch.test
index 27ae4aa..c913e60 100644
--- a/tests/lsearch.test
+++ b/tests/lsearch.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} {
} 1
test lsearch-2.10 {search modes} -returnCodes error -body {
lsearch -glib {b.x bx xy bcx} b.x
-} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-2.11 {search modes with -nocase} {
lsearch -exact -nocase {a b c A B C} A
} 0
@@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body {
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
test lsearch-3.3 {lsearch errors} -returnCodes error -body {
lsearch a b c
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.4 {lsearch errors} -returnCodes error -body {
lsearch a b c d
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.5 {lsearch errors} -returnCodes error -body {
lsearch "\{" b
} -result {unmatched open brace in list}
@@ -102,13 +102,13 @@ test lsearch-3.7 {lsearch errors} -returnCodes error -body {
} -result {-subindices cannot be used without -index option}
test lsearch-4.1 {binary data} {
- lsearch -exact [list foo one\000two bar] bar
+ lsearch -exact [list foo one\x00two bar] bar
} 2
test lsearch-4.2 {binary data} {
set x one
append x \x00
append x two
- lsearch -exact [list foo one\000two bar] $x
+ lsearch -exact [list foo one\x00two bar] $x
} 1
# Make a sorted list
@@ -432,19 +432,19 @@ test lsearch-17.11 {lsearch -index option, empty argument} {
} [lsearch [list \{] \{]
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
lsearch -index -2 a a
-} -returnCodes error -result {index "-2" cannot select an element from any list}
+} -returnCodes error -result {index "-2" out of range}
test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
lsearch -index -1-1 a a
-} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+} -returnCodes error -result {index "-1-1" out of range}
test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
lsearch -index end--1 a a
-} -returnCodes error -result {index "end--1" cannot select an element from any list}
+} -returnCodes error -result {index "end--1" out of range}
test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+1 a a
-} -returnCodes error -result {index "end+1" cannot select an element from any list}
+} -returnCodes error -result {index "end+1" out of range}
test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+2 a a
-} -returnCodes error -result {index "end+2" cannot select an element from any list}
+} -returnCodes error -result {index "end+2" out of range}
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
@@ -478,6 +478,9 @@ test lsearch-19.4 {lsearch -subindices option} {
test lsearch-19.5 {lsearch -subindices option} {
lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
} {{0 0 0} {1 0 0}}
+test lsearch-19.6 {lsearch -subindices option} {
+ lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {{0 1 0} {1 1 0}}
test lsearch-19.7 {lsearch -subindices option} {
lsearch -subindices -index end {{1 a}} a
} {0 1}
@@ -543,6 +546,152 @@ test lsearch-22.5 {lsearch -bisect, all equal} {
test lsearch-22.6 {lsearch -sorted, all equal} {
lsearch -sorted -integer {5 5 5 5} 5
} {0}
+
+test lsearch-23.1 {lsearch -stride option, errors} -body {
+ lsearch -stride {a b} a
+} -returnCodes error -result {"-stride" option must be followed by stride length}
+test lsearch-23.2 {lsearch -stride option, errors} -body {
+ lsearch -stride 0 {a b} a
+} -returnCodes error -match glob -result {stride length must be between 1 and *}
+test lsearch-23.3 {lsearch -stride option, errors} -body {
+ lsearch -stride 2 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.4 {lsearch -stride option, errors} -body {
+ lsearch -stride 5 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.5 {lsearch -stride option, errors} -body {
+ # Stride equal to length is ok
+ lsearch -stride 3 {a b c} a
+} -result 0
+
+test lsearch-24.1 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} d
+} -result -1
+test lsearch-24.2 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} e
+} -result 4
+test lsearch-24.3 {lsearch -stride option} -body {
+ lsearch -stride 3 {a b c d e f g h i} e
+} -result -1
+test lsearch-24.4 {lsearch -stride option} -body {
+ # Result points first in group
+ lsearch -stride 3 -index 1 {a b c d e f g h i} e
+} -result 3
+test lsearch-24.5 {lsearch -stride option} -body {
+ lsearch -inline -stride 2 {a b c d e f g h} d
+} -result {}
+test lsearch-24.6 {lsearch -stride option} -body {
+ # Inline result is a "single element" strided list
+ lsearch -inline -stride 2 {a b c d e f g h} e
+} -result "e f"
+test lsearch-24.7 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 {a b c d e f g h i} e
+} -result {}
+test lsearch-24.8 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e
+} -result "d e f"
+test lsearch-24.9 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e
+} -result "d e f g e i"
+test lsearch-24.10 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a
+} -result "a b c a e i"
+test lsearch-24.11 {lsearch -stride option} -body {
+ # Stride 1 is same as no stride
+ lsearch -stride 1 {a b c d e f g h} d
+} -result 3
+
+# 25* mimics 19* but with -inline added to -subindices
+test lsearch-25.1 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.2 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.3 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
+} {bb}
+test lsearch-25.4 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
+} {cb}
+test lsearch-25.5 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+test lsearch-25.6 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+
+# 26* mimics 19* but with -stride added
+test lsearch-26.1 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {3 0}
+test lsearch-26.2 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {2 0}
+test lsearch-26.3 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {1 1}
+test lsearch-26.4 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {0 1}
+test lsearch-26.5 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {{0 0} {3 0}}
+test lsearch-26.6 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {{1 0} {4 0}}
+
+# 27* mimics 25* but with -stride added
+test lsearch-27.1 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.2 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.3 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {bb}
+test lsearch-27.4 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {cb}
+test lsearch-27.5 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {a a}
+test lsearch-27.6 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {a a}
+
+test lsearch-28.1 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 5
+} -result 0
+test lsearch-28.2 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 3
+} -result -1
+test lsearch-28.3 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 7
+} -result 2
+test lsearch-28.4 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 8
+} -result -1
+test lsearch-28.5 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.6 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 2
+} -result -1
+test lsearch-28.7 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.8 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9
+} -result 5
+test lsearch-28.9 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9
+} -result 9
+test lsearch-28.10 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 4294967296 -index 1 -subindices -inline {3 5 8 7 2 9} 9
+} -returnCodes 1 -match glob -result {stride length must be between 1 and *}
+
# cleanup
catch {unset res}
diff --git a/tests/lseq.test b/tests/lseq.test
new file mode 100644
index 0000000..4c1f14b
--- /dev/null
+++ b/tests/lseq.test
@@ -0,0 +1,702 @@
+# Commands covered: lseq
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright © 2003 Simon Geard.
+#
+# 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::*
+}
+
+testConstraint arithSeriesDouble 1
+testConstraint arithSeriesShimmer 1
+testConstraint arithSeriesShimmerOk 1
+#testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
+#testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}]
+
+proc memusage {} {
+ set fd [open /proc/[pid]/statm]
+ set line [gets $fd]
+ if {[llength $line] != 7} {
+ error "Unexpected /proc/pid/statm format"
+ }
+ return [lindex $line 5]
+}
+testConstraint hasMemUsage [expr {![catch {memusage}]}]
+
+# Arg errors
+test lseq-1.1 {error cases} -body {
+ lseq
+} \
+ -returnCodes 1 \
+ -result {wrong # args: should be "lseq n ??op? n ??by? n??"}
+
+
+test lseq-1.2 {step magnitude} {
+ lseq 10 .. 1 by -2 ;# or this could be an error - or not
+} {10 8 6 4 2}
+
+test lseq-1.3 {synergy between int and double} -body {
+ set rl [lseq 25. to 5. by -5]
+ set il [lseq 25 to 5 by -5]
+ lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} }
+} -cleanup {
+ unset rl il
+} -result {1 1 1 1 1}
+
+test lseq-1.4 {integer decreasing} {
+ lseq 10 .. 1
+} {10 9 8 7 6 5 4 3 2 1}
+
+test lseq-1.5 {integer increasing} {
+ lseq 1 .. 10
+} {1 2 3 4 5 6 7 8 9 10}
+
+test lseq-1.6 {integer decreasing with step} {
+ lseq 10 .. 1 by -2
+} {10 8 6 4 2}
+
+test lseq-1.7 {real increasing lseq} arithSeriesDouble {
+ lseq 5.0 to 15.
+} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0}
+
+test lseq-1.8 {real increasing lseq with step} arithSeriesDouble {
+ lseq 5.0 to 25. by 5
+} {5.0 10.0 15.0 20.0 25.0}
+
+test lseq-1.9 {real decreasing with step} arithSeriesDouble {
+ lseq 25. to 5. by -5
+} {25.0 20.0 15.0 10.0 5.0}
+
+# note, 10 cannot be in such a list, but allowed
+test lseq-1.10 {integer lseq with step} {
+ lseq 1 to 10 by 2
+} {1 3 5 7 9}
+
+test lseq-1.11 {error case: increasing wrong step direction} {
+ lseq 1 to 10 by -2
+} {}
+
+test lseq-1.12 {decreasing lseq with step} arithSeriesDouble {
+ lseq 25. to -25. by -5
+} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
+
+test lseq-1.13 {count operation} {
+ -body {
+ lseq 5 count 5
+ }
+ -result {5 6 7 8 9}
+}
+
+test lseq-1.14 {count with step} {
+ -body {
+ lseq 5 count 5 by 2
+ }
+ -result {5 7 9 11 13}
+}
+
+test lseq-1.15 {count with decreasing step} {
+ -body {
+ lseq 5 count 5 by -2
+ }
+ -result {5 3 1 -1 -3}
+}
+
+test lseq-1.16 {large numbers} {
+ -body {
+ lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
+ }
+ -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
+}
+
+test lseq-1.17 {too many arguments} -body {
+ lseq 12 to 24 by 2 with feeling
+} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}
+
+test lseq-1.18 {too many arguments extra valid keyword} -body {
+ lseq 12 to 24 by 2 count
+} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}
+
+test lseq-1.19 {too many arguments extra numeric value} -body {
+ lseq 12 to 24 by 2 7
+} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"}
+
+test lseq-1.20 {bug: wrong length computed} {
+ lseq 1 to 10 -1
+} {}
+
+test lseq-1.21 {n n by n} {
+ lseq 66 84 by 3
+} {66 69 72 75 78 81 84}
+
+test lseq-1.22 {n n by -n} {
+ lseq 84 66 by -3
+} {84 81 78 75 72 69 66}
+
+#
+# Short-hand use cases
+#
+test lseq-2.2 {step magnitude} {
+ lseq 10 1 2 ;# this is an empty case since step has wrong sign
+} {}
+
+test lseq-2.3 {step wrong sign} arithSeriesDouble {
+ lseq 25. 5. 5 ;# ditto - empty list
+} {}
+
+test lseq-2.4 {integer decreasing} {
+ lseq 10 1
+} {10 9 8 7 6 5 4 3 2 1}
+
+test lseq-2.5 {integer increasing} {
+ lseq 1 10
+} {1 2 3 4 5 6 7 8 9 10}
+
+test lseq-2.6 {integer decreasing with step} {
+ lseq 10 1 by -2
+} {10 8 6 4 2}
+
+test lseq-2.7 {real increasing lseq} arithSeriesDouble {
+ lseq 5.0 15.
+} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0}
+
+
+test lseq-2.8 {real increasing lseq with step} arithSeriesDouble {
+ lseq 5.0 25. 5
+} {5.0 10.0 15.0 20.0 25.0}
+
+
+test lseq-2.9 {real decreasing with step} arithSeriesDouble {
+ lseq 25. 5. -5
+} {25.0 20.0 15.0 10.0 5.0}
+
+test lseq-2.10 {integer lseq with step} {
+ lseq 1 10 2
+} {1 3 5 7 9}
+
+test lseq-2.11 {error case: increasing wrong step direction} {
+ lseq 1 10 -2
+} {}
+
+test lseq-2.12 {decreasing lseq with step} arithSeriesDouble {
+ lseq 25. -25. -5
+} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
+
+test lseq-2.13 {count only operation} {
+ lseq 5
+} {0 1 2 3 4}
+
+test lseq-2.14 {count with step} {
+ lseq 5 count 5 2
+} {5 7 9 11 13}
+
+test lseq-2.15 {count with decreasing step} {
+ lseq 5 count 5 -2
+} {5 3 1 -1 -3}
+
+test lseq-2.16 {large numbers} {
+ lseq 1e6 2e6 1e5
+} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0}
+
+test lseq-2.17 {large numbers} arithSeriesDouble {
+ lseq 1e6 2e6 1e5
+} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0}
+
+# Covered: {10 1 2 } {1 10 2} {1 10 -2} {1 1 1} {1 1 1} {-5 17 3}
+# Missing: {- - +} {- - -} {- + -} {+ - -} {- - +} {+ + -}
+test lseq-2.18 {signs} {
+ list [lseq -10 -1 2] \
+ [lseq -10 -1 -1] \
+ [lseq -10 1 -3] \
+ [lseq 10 -1 -4] \
+ [lseq -10 -1 3] \
+ [lseq 10 1 -5]
+
+} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}}
+
+test lseq-3.1 {experiement} -body {
+ set ans {}
+ foreach factor [lseq 2.0 10.0] {
+ set start 1
+ set end 10
+ for {set step 1} {$step < 1e8} {} {
+ set l [lseq $start to $end by $step]
+ if {[llength $l] != 10} {
+ lappend ans $factor $step [llength $l] $l
+ }
+ set step [expr {$step * $factor}]
+ set end [expr {$end * $factor}]
+ }
+ }
+ if {$ans eq {}} {
+ set ans OK
+ }
+ set ans
+} -cleanup {
+ unset ans step end start factor l
+} -result {OK}
+
+test lseq-3.2 {error case} -body {
+ lseq foo
+} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by}
+
+test lseq-3.3 {error case} -body {
+ lseq 10 foo
+} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by}
+
+test lseq-3.4 {error case} -body {
+ lseq 25 or 6
+} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}
+
+test lseq-3.5 {simple count and step arguments} -body {
+ set s [lseq 25 by 6]
+ list $s length=[llength $s]
+} -cleanup {
+ unset s
+} -result {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25}
+
+test lseq-3.6 {error case} -body {
+ lseq 1 7 or 3
+} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}
+
+test lseq-3.7 {lmap lseq} -body {
+ lmap x [lseq 5] { expr {$x * $x} }
+} -cleanup {unset x} -result {0 1 4 9 16}
+
+test lseq-3.8 {lrange lseq} -body {
+ set r [lrange [lseq 1 100] 10 20]
+ set empty [lrange [lseq 1 100] 20 10]
+ list $r $empty [lindex [tcl::unsupported::representation $r] 3]
+} -cleanup {
+ unset r empty
+} -result {{11 12 13 14 15 16 17 18 19 20 21} {} arithseries}
+
+test lseq-3.9 {lassign lseq} -constraints arithSeriesShimmer -body {
+ set r [lseq 15]
+ set r2 [lassign $r a b]
+ list [lindex [tcl::unsupported::representation $r] 3] $a $b \
+ [lindex [tcl::unsupported::representation $r2] 3]
+} -cleanup {unset r r2 a b} -result {arithseries 0 1 arithseries}
+
+test lseq-3.10 {lsearch lseq must shimmer?} -constraints arithSeriesShimmer -body {
+ set r [lseq 15 0]
+ set a [lsearch $r 9]
+ list [lindex [tcl::unsupported::representation $r] 3] $a
+} -cleanup {unset r a} -result {arithseries 6}
+
+test lseq-3.11 {lreverse lseq} -body {
+ set r [lseq 15 0]
+ set a [lreverse $r]
+ join [list \
+ [lindex [tcl::unsupported::representation $r] 3] \
+ $r \
+ [lindex [tcl::unsupported::representation $a] 3] \
+ $a] \n
+} -cleanup {unset r a} -result {arithseries
+15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0
+arithseries
+0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15}
+
+test lseq-3.12 {in operator} -body {
+ set r [lseq 9]
+ set i [expr {7 in $r}]
+ set j [expr {10 ni $r}]
+ set k [expr {-1 in $r}]
+ set l [expr {4 ni $r}]
+ list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3]
+} -cleanup {
+ unset r i j k l
+} -result {1 1 0 0 arithseries}
+
+test lseq-3.13 {lmap lseq shimmer} -constraints arithSeriesShimmer -body {
+ set r [lseq 15]
+ set rep-before [lindex [tcl::unsupported::representation $r] 3]
+ set m [lmap i $r { expr {$i * 7} }]
+ set rep-after [lindex [tcl::unsupported::representation $r] 3]
+ set rep-m [lindex [tcl::unsupported::representation $m] 3]
+ list $r ${rep-before} ${rep-after} ${rep-m} $m
+} -cleanup {
+ unset r rep-before m rep-after rep-m
+} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}}
+
+test lseq-3.14 {array for shimmer} -constraints arithSeriesShimmerOk -body {
+ array set testarray {a Test for This great Function}
+ set vars [lseq 2]
+ set vars-rep [lindex [tcl::unsupported::representation $vars] 3]
+ array for $vars testarray {
+ lappend keys $0
+ lappend vals $1
+ }
+ # Since hash order is not guaranteed, have to validate content ignoring order
+ set valk [lmap k $keys {expr {$k in {a for great}}}]
+ set valv [lmap v $vals {expr {$v in {Test This Function}}}]
+ set vars-after [lindex [tcl::unsupported::representation $vars] 3]
+ list ${vars-rep} $valk $valv ${vars-after}
+} -cleanup {
+ unset testarray vars vars-rep 0 valk k valv v vars-after
+} -result {arithseries {1 1 1} {1 1 1} arithseries}
+
+test lseq-3.15 {join for shimmer} -constraints arithSeriesShimmer -body {
+ set r [lseq 3]
+ set rep-before [lindex [tcl::unsupported::representation $r] 3]
+ set str [join $r :]
+ set rep-after [lindex [tcl::unsupported::representation $r] 3]
+ list ${rep-before} $str ${rep-after}
+} -cleanup {
+ unset r rep-before str rep-after
+} -result {arithseries 0:1:2 arithseries}
+
+test lseq-3.16 {error case} -body {
+ lseq 16 to
+} -returnCodes 1 -result {missing "to" value.}
+
+test lseq-3.17 {error case} -body {
+ lseq 17 to 13 by
+} -returnCodes 1 -result {missing "by" value.}
+
+test lseq-3.18 {error case} -body {
+ lseq 18 count
+} -returnCodes 1 -result {missing "count" value.}
+
+test lseq-3.19 {edge case} -body {
+ lseq 1 count 5 by 0
+} -result {}
+# 1 1 1 1 1
+
+# My thought is that this is likely a user error, since they can always use lrepeat for this.
+
+test lseq-3.20 {edge case} -body {
+ lseq 1 to 1 by 0
+} -result {}
+
+# hmmm, I guess this is right, in a way, so...
+
+test lseq-3.21 {edge case} {
+ lseq 1 to 1 by 1
+} {1}
+
+test lseq-3.22 {edge case} {
+ lseq 1 1 1
+} {1}
+
+test lseq-3.23 {edge case} {
+ llength [lseq 1 1 1]
+} {1}
+
+test lseq-3.24 {edge case} {
+ llength [lseq 1 to 1 1]
+} {1}
+
+test lseq-3.25 {edge case} {
+ llength [lseq 1 to 1 by 1]
+} {1}
+
+test lseq-3.26 {lsort shimmer} -constraints arithSeriesShimmer -body {
+ set r [lseq 15 0]
+ set rep-before [lindex [tcl::unsupported::representation $r] 3]
+ set lexical_sort [lsort $r]
+ set rep-after [lindex [tcl::unsupported::representation $r] 3]
+ list ${rep-before} $lexical_sort ${rep-after}
+} -cleanup {
+ unset r rep-before lexical_sort rep-after
+} -result {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries}
+
+test lseq-3.27 {lreplace shimmer} -constraints arithSeriesShimmer -body {
+ set r [lseq 15 0]
+ set rep-before [lindex [tcl::unsupported::representation $r] 3]
+ set lexical_sort [lreplace $r 3 5 A B C]
+ set rep-after [lindex [tcl::unsupported::representation $r] 3]
+ list ${rep-before} $lexical_sort ${rep-after}
+} -cleanup {
+ unset r
+ unset rep-before
+ unset lexical_sort
+ unset rep-after
+} -result {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries}
+
+test lseq-3.28 {lreverse bug in ArithSeries} -body {
+ set r [lseq -5 17 3]
+ set rr [lreverse $r]
+ list $r $rr [string equal $r [lreverse $rr]]
+} -cleanup {
+ unset r rr
+} -result {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1}
+
+test lseq-3.29 {edge case: negative count} {
+ lseq -15
+} {}
+
+test lseq-3.30 {lreverse with double values} -constraints arithSeriesDouble -body {
+ set r [lseq 3.5 18.5 1.5]
+ set a [lreverse $r]
+ join [list \
+ [lindex [tcl::unsupported::representation $r] 3] \
+ $r \
+ [lindex [tcl::unsupported::representation $a] 3] \
+ $a] \n
+} -cleanup {
+ unset r a
+} -result {arithseries
+3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5
+arithseries
+18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5}
+
+test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble} {
+ lreverse [lseq 1.1 29.9 0.3]
+} {29.9 29.6 29.3 29.0 28.7 28.4 28.1 27.8 27.5 27.2 26.9 26.6 26.3 26.0 25.7 25.4 25.1 24.8 24.5 24.2 23.9 23.6 23.3 23.0 22.7 22.4 22.1 21.8 21.5 21.2 20.9 20.6 20.3 20.0 19.7 19.4 19.1 18.8 18.5 18.2 17.9 17.6 17.3 17.0 16.7 16.4 16.1 15.8 15.5 15.2 14.9 14.6 14.3 14.0 13.7 13.4 13.1 12.8 12.5 12.2 11.9 11.6 11.3 11.0 10.7 10.4 10.1 9.8 9.5 9.2 8.9 8.6 8.3 8.0 7.7 7.4 7.1 6.8 6.5 6.2 5.9 5.6 5.3 5.0 4.7 4.4 4.1 3.8 3.5 3.2 2.9 2.6 2.3 2.0 1.7 1.4 1.1}
+
+# lsearch -
+# -- should not shimmer lseq list
+# -- should not leak lseq elements
+test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body {
+ set srchlist {}
+ for {set i 5} {$i < 25} {incr i} {
+ lappend srchlist [lseq $i count 7 by 3]
+ }
+ set a [lsearch -all -inline -index 1 $srchlist 23]
+ set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
+ list [lindex [tcl::unsupported::representation $a] 3] $a $b \
+ [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3]
+} -cleanup {
+ unset srchlist i a b
+} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries}
+
+test lseq-4.1 {end expressions} -body {
+ set start 7
+ lseq $start $start+11
+} -cleanup {unset start} -result {7 8 9 10 11 12 13 14 15 16 17 18}
+
+test lseq-4.2 {start expressions} -body {
+ set base [clock seconds]
+ set tl [lseq $base-60 $base 10]
+ lmap t $tl {expr {$t - $base + 60}}
+} -cleanup {unset base tl t} -result {0 10 20 30 40 50 60}
+
+## lseq 1 to 10 by -2
+## # -> lseq: invalid step = -2 with a = 1 and b = 10
+
+test lseq-4.3 {TIP examples} -body {
+ set examples {# Examples from TIP-629
+ # --- Begin ---
+ lseq 10 .. 1
+ # -> 10 9 8 7 6 5 4 3 2 1
+ lseq 1 .. 10
+ # -> 1 2 3 4 5 6 7 8 9 10
+ lseq 10 .. 1 by 2
+ # ->
+ lseq 10 .. 1 by -2
+ # -> 10 8 6 4 2
+ lseq 5.0 to 15.
+ # -> 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0
+ lseq 5.0 to 25. by 5
+ # -> 5.0 10.0 15.0 20.0 25.0
+ lseq 25. to 5. by 5
+ # ->
+ lseq 25. to 5. by -5
+ # -> 25.0 20.0 15.0 10.0 5.0
+ lseq 1 to 10 by 2
+ # -> 1 3 5 7 9
+ lseq 25. to -25. by -5
+ # -> 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0
+ lseq 5 5
+ # -> 5
+ lseq 5 5 2
+ # -> 5
+ lseq 5 5 -2
+ # -> 5
+ }
+ set res {}
+ foreach {cmd expect} [split $examples \n] {
+ if {[string trim $cmd] ne ""} {
+ set cmd [string trimleft $cmd]
+ if {[string match {\#*} $cmd]} continue
+ set status [catch $cmd ans]
+ lappend res $ans
+ if {[regexp {\# -> (.*)$} $expect -> expected]} {
+ if {$expected ne $ans} {
+ lappend res [list Mismatch: $cmd -> $ans ne $expected]
+ }
+ }
+ }
+ }
+ set res
+} -cleanup {
+ unset res cmd status ans expect expected examples
+} -result {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5}
+
+#
+# Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case
+test lseq-4.4 {lseq corner case} -body {
+ set tcmd {
+ set res {}
+ set s [catch {lindex [lseq 10 100] 0} e]
+ lappend res $s $e
+ set s [catch {lindex [lseq 10 9223372036854775000] 0} e]
+ lappend res $s $e
+ set s [catch {llength [lseq 10 9223372036854775000]} e]
+ lappend res $s $e
+ set s [catch {lindex [lseq 10 2147483647] 0} e]
+ lappend res $s $e
+ set s [catch {llength [lseq 10 2147483647]} e]
+ lappend res $s $e
+ }
+ eval $tcmd
+} -cleanup {
+ unset res s e tcmd
+} -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638}
+
+# Ticket 99e834bf33 - lseq, lindex end off by one
+
+test lseq-4.5 {lindex off by one} -body {
+ lappend res [eval {lindex [lseq 1 4] end}]
+ lappend res [eval {lindex [lseq 1 4] end-1}]
+} -setup {
+ # Since 4.3 does not clean up and 4.4 may not run under constraint
+ set res {}
+} -cleanup {
+ unset res
+} -result {4 3}
+
+# Bad refcount on ResultObj
+test lseq-4.6 {lindex flat} -body {
+ set l [lseq 2 10]
+ set cmd lindex
+ set i 4
+ set c [lindex $l $i]
+ set d [$cmd $l $i]
+ set e [lindex [lseq 2 10] $i]
+ set f [$cmd [lseq 2 10] $i]
+ list $c $d $e $f
+} -cleanup {
+ unset l cmd i c d e f
+} -result [lrepeat 4 6]
+
+test lseq-4.7 {empty list} {
+ list [lseq 0] [join [lseq 0] {}] [join [lseq 1] {}]
+} {{} {} 0}
+
+test lseq-4.8 {error case lrange} -body {
+ lrange [lseq 1 5] fred ginger
+} -cleanup {
+ unset -nocomplain fred ginger
+} -returnCodes 1 -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?}
+
+test lseq-4.9 {lrange empty/partial sets} -body {
+ set res {}
+ foreach {fred ginger} {7 8 4 9 0 15 9 9 4 2} {
+ lappend res [lrange [lseq 1 5] $fred $ginger]
+ }
+ set res
+} -cleanup {unset res fred ginger} -result {{} 5 {1 2 3 4 5} {} {}}
+
+# Panic when using variable value?
+test lseq-4.10 {panic using variable index} -body {
+ set i 0
+ lindex [lseq 10] $i
+} -cleanup {unset i} -result {0}
+
+test lseq-4.11 {bug lseq / lindex discrepancies} -body {
+ lindex [lseq 0x7fffffff] 0x80000000
+} -result {}
+
+test lseq-4.12 {bug lseq} -body {
+ llength [lseq 0x100000000]
+} -returnCodes 1 -result {max length of a Tcl list exceeded}
+
+test lseq-4.13 {bug lseq} -constraints knownBug -body {
+ set l [lseq 0x7fffffffffffffff]
+ list \
+ [llength $l] \
+ [lindex $l end] \
+ [lindex $l 9223372036854775800]
+} -cleanup {unset l} -result {9223372036854775807 9223372036854775806 9223372036854775800}
+
+
+test lseq-4.14 {bug lseq - inconsistent rounding} {
+ # using a non-integer increment, [lseq] rounding seems to be not consistent:
+ lseq 4 40 0.1
+} {4.0 4.1 4.2 4.3 4.4 4.5 4.6 4.7 4.8 4.9 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.7 5.8 5.9 6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0}
+
+test lseq-4.15 {bug lseq - inconsistent rounding} {
+ # using a non-integer increment, [lseq] rounding seems to be not consistent:
+ lseq 6 40 0.1
+} {6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0}
+
+test lseq-4.16 {bug lseq - inconsistent rounding} {
+ # using a non-integer increment, [lseq] rounding seems to be not consistent:
+ set res {}
+ lappend res [lseq 4.07 6 0.1]
+ lappend res [lseq 4.03 4.208 0.013]
+} {{4.07 4.17 4.27 4.37 4.47 4.57 4.67 4.77 4.87 4.97 5.07 5.17 5.27 5.37 5.47 5.57 5.67 5.77 5.87 5.97} {4.03 4.043 4.056 4.069 4.082 4.095 4.108 4.121 4.134 4.147 4.16 4.173 4.186 4.199}}
+
+# Test abstract list in a concat
+# -- lseq list should not shimmer
+# -- lseq elements should not leak
+test lseq-4.17 {concat shimmer} -body {
+ set rng [lseq 8 15 2]
+ set pre [list A b C]
+ set pst [list x Y z]
+ list [concat $pre $rng $pst] \
+ [lindex [tcl::unsupported::representation $pre] 3] \
+ [lindex [tcl::unsupported::representation $rng] 3] \
+ [lindex [tcl::unsupported::representation $pst] 3]
+} -cleanup {unset rng pre pst} -result {{A b C 8 10 12 14 x Y z} list arithseries list}
+
+test lseq-4.18 {concat shimmer} -body {
+ set rng [lseq 8 15 2]
+ set pre [list A b C]
+ set pst [list x Y z]
+ list [concat $rng $pre $pst] \
+ [lindex [tcl::unsupported::representation $rng] 3] \
+ [lindex [tcl::unsupported::representation $pre] 3] \
+ [lindex [tcl::unsupported::representation $pst] 3]
+} -cleanup {unset rng pre pst} -result {{8 10 12 14 A b C x Y z} arithseries list list}
+
+# Test lseq elements as var names
+test lseq-4.19 {varnames} -body {
+ set plist {}
+ foreach v {auto_execok auto_load auto_qualify} {
+ lappend plist proc $v [info args $v] [info body $v]
+ }
+ set res {}
+ set varlist [lseq 1 to 4]
+ foreach $varlist $plist {
+ lappend res $2 [llength $3]
+ }
+ lappend res [lindex [tcl::unsupported::representation $varlist] 3]
+} -cleanup {
+ unset {*}$varlist res varlist v plist
+} -result {auto_execok 1 auto_load 2 auto_qualify 2 arithseries}
+
+test lseq-convertToList {does not result in a memory error} -body {
+ trace add variable var1 write [list ::apply [list args {
+ error {this is an error}
+ } [namespace current]]]
+ list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres
+} -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}}
+
+test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints {
+ hasMemUsage
+} -body {
+ set l [lseq 1000000]
+ proc p l {foreach x $l {}}
+ set premem [memusage]
+ p $l
+ set postmem [memusage]
+ expr {($postmem - $premem) < 10}
+} -result 1
+
+# cleanup
+::tcltest::cleanupTests
+
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/lset.test b/tests/lset.test
index 0ce1c6d..72d68ec 100644
--- a/tests/lset.test
+++ b/tests/lset.test
@@ -6,7 +6,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
proc failTrace {name1 name2 op} {
error "trace failed"
@@ -97,31 +97,31 @@ test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
list [catch {
testevalex {lset a [list -1] w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "-1" out of range}}
test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list 4] w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "4" out of range}}
test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end--2] w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end--2" out of range}}
test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end+2] w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end+2" out of range}}
test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end-3] w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end-3" out of range}}
test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex {
set a "x \{"
list [catch {
@@ -139,31 +139,31 @@ test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
list [catch {
testevalex {lset a -1 w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "-1" out of range}}
test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a 4 w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "4" out of range}}
test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end--2 w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end--2" out of range}}
test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end+2 w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end+2" out of range}}
test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end-3 w}
} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end-3" out of range}}
test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex {
list [catch {
@@ -281,43 +281,43 @@ test lset-8.4 {lset, not compiled, bad second index} testevalex {
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "-1" out of range}}
test lset-8.6 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 -1} h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "-1" out of range}}
test lset-8.7 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 3 h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "3" out of range}}
test lset-8.8 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 3} h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "3" out of range}}
test lset-8.9a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end--2 h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end--2" out of range}}
test lset-8.9b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end+2 h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end+2" out of range}}
test lset-8.10a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end--2} h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end--2" out of range}}
test lset-8.10b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end+2} h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end+2" out of range}}
test lset-8.11 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end-2 h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end-2" out of range}}
test lset-8.12 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end-2} h}} msg] $msg
-} {1 {list index out of range}}
+} {1 {index "end-2" out of range}}
test lset-9.1 {lset, not compiled, entire variable} testevalex {
set a x
diff --git a/tests/lsetComp.test b/tests/lsetComp.test
index d50e0b2..a719fe4 100644
--- a/tests/lsetComp.test
+++ b/tests/lsetComp.test
@@ -6,7 +6,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -219,7 +219,7 @@ test lsetComp-2.8 {lset, compiled, list of args, error } {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
-} "1 {list index out of range}"
+} {1 {index "5" out of range}}
test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
@@ -412,7 +412,7 @@ test lsetComp-3.8 {lset, compiled, flat args, error } {
set x { {1 2} {3 4} }
lset x 1 5 5
}
-} "1 {list index out of range}"
+} {1 {index "5" out of range}}
test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test
index 0a147f0..5a62a2a 100644
--- a/tests/macOSXFCmd.test
+++ b/tests/macOSXFCmd.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2003 Tcl Core Team.
+# Copyright © 2003 Tcl Core Team.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test
index e68c4bb..df35b8d 100644
--- a/tests/macOSXLoad.test
+++ b/tests/macOSXLoad.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -14,7 +14,6 @@ if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
-
set oldTSF $::tcltest::testSingleFile
set ::tcltest::testSingleFile false
diff --git a/tests/main.test b/tests/main.test
index 758a7d0..4aadd79 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -1,8 +1,8 @@
# This file contains a collection of tests for generic/tclMain.c.
-if {[catch {package require tcltest 2.0.2}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
- return
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::main {
@@ -11,12 +11,10 @@ namespace eval ::tcl::test::main {
# Is [exec] defined?
testConstraint exec [llength [info commands exec]]
- # Is the Tcltest package loaded?
- # - that is, the special C-coded testing commands in tclTest.c
- # - tests use testing commands introduced in Tcltest 8.4
- testConstraint Tcltest [expr {
- [llength [package provide Tcltest]]
- && [package vsatisfies [package provide Tcltest] 8.4]}]
+ # Is the tcl::test package loaded?
+ testConstraint tcl::test [expr {
+ [llength [package provide tcl::test]]
+ && [package vsatisfies [package provide tcl::test] 8.5-]}]
# Procedure to simulate interactive typing of commands, line by line
proc type {chan script} {
@@ -70,56 +68,56 @@ namespace eval ::tcl::test::main {
stdio
} -setup {
makeFile {puts [list $argv0 $argv $tcl_interactive]} script
- catch {set f [open "|[list [interpreter] script \u00c0]" r]}
+ catch {set f [open "|[list [interpreter] script À]" r]}
} -body {
read $f
} -cleanup {
close $f
removeFile script
} -result [list script [list [encoding convertfrom [encoding system] \
- [encoding convertto [encoding system] \u00c0]]] 0]\n
+ [encoding convertto [encoding system] À]]] 0]\n
test Tcl_Main-1.4 {
} -constraints {
stdio
} -setup {
makeFile {puts [list $argv0 $argv $tcl_interactive]} script
- catch {set f [open "|[list [interpreter] script \u20ac]" r]}
+ catch {set f [open "|[list [interpreter] script €]" r]}
} -body {
read $f
} -cleanup {
close $f
removeFile script
} -result [list script [list [encoding convertfrom [encoding system] \
- [encoding convertto [encoding system] \u20ac]]] 0]\n
+ [encoding convertto [encoding system] €]]] 0]\n
test Tcl_Main-1.5 {
} -constraints {
stdio
} -setup {
- makeFile {puts [list $argv0 $argv $tcl_interactive]} \u00c0
- catch {set f [open "|[list [interpreter] \u00c0]" r]}
+ makeFile {puts [list $argv0 $argv $tcl_interactive]} À
+ catch {set f [open "|[list [interpreter] À]" r]}
} -body {
read $f
} -cleanup {
close $f
- removeFile \u00c0
+ removeFile À
} -result [list [list [encoding convertfrom [encoding system] \
- [encoding convertto [encoding system] \u00c0]]] {} 0]\n
+ [encoding convertto [encoding system] À]]] {} 0]\n
test Tcl_Main-1.6 {
} -constraints {
stdio
} -setup {
- makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac
- catch {set f [open "|[list [interpreter] \u20ac]" r]}
+ makeFile {puts [list $argv0 $argv $tcl_interactive]} €
+ catch {set f [open "|[list [interpreter] €]" r]}
} -body {
read $f
} -cleanup {
close $f
- removeFile \u20ac
+ removeFile €
} -result [list [list [encoding convertfrom [encoding system] \
- [encoding convertto [encoding system] \u20ac]]] {} 0]\n
+ [encoding convertto [encoding system] €]]] {} 0]\n
test Tcl_Main-1.7 {
Tcl_Main: startup script - -encoding option
@@ -131,8 +129,8 @@ namespace eval ::tcl::test::main {
set f [open $script w]
chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
- puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]"
+ puts -nonewline $f {puts [string equal € }
+ puts $f "€]"
close $f
catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]}
} -body {
@@ -153,7 +151,7 @@ namespace eval ::tcl::test::main {
chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]"
+ puts $f "€]"
close $f
catch {set f [open "|[list [interpreter] -encoding iso8859-1 script]" r]}
} -body {
@@ -174,7 +172,7 @@ namespace eval ::tcl::test::main {
chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
- puts $f "\u20ac]"
+ puts $f "€]"
close $f
catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]}
} -body {
@@ -192,7 +190,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-2.1 {
Tcl_Main: appInitProc returns error
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {puts "In script"} script
} -body {
@@ -208,7 +206,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-2.2 {
Tcl_Main: appInitProc returns error
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} -appinitprocerror >& result
set f [open result]
@@ -221,7 +219,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-2.3 {
Tcl_Main: appInitProc deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {puts "In script"} script
} -body {
@@ -237,7 +235,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-2.4 {
Tcl_Main: appInitProc deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocdeleteinterp >& result
@@ -251,7 +249,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-2.5 {
Tcl_Main: appInitProc closes stderr
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {puts "In script"} \
-appinitprocclosestderr >& result
@@ -336,7 +334,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-3.5 {
Tcl_Main: startup script sets main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {
rename exit _exit
@@ -364,7 +362,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-3.6 {
Tcl_Main: startup script sets main loop and closes stdin
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {
close stdin
@@ -393,7 +391,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-3.7 {
Tcl_Main: startup script deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {
rename exit _exit
@@ -417,7 +415,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-3.8 {
Tcl_Main: startup script deletes interp and sets mainloop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
makeFile {
testsetmainloop
@@ -461,7 +459,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-4.1 {
Tcl_Main: rcFile evaluation deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
set rc [makeFile {testinterpdelete {}} rc]
} -body {
@@ -478,7 +476,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-4.2 {
Tcl_Main: rcFile evaluation closes stdin
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
set rc [makeFile {close stdin} rc]
} -body {
@@ -495,7 +493,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-4.3 {
Tcl_Main: rcFile evaluation closes stdin and sets main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
set rc [makeFile {
close stdin
@@ -523,7 +521,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-4.4 {
Tcl_Main: rcFile evaluation sets main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
set rc [makeFile {
testsetmainloop
@@ -550,7 +548,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-4.5 {
Tcl_Main: Bug 1481986
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
set rc [makeFile {
testsetmainloop
@@ -608,8 +606,8 @@ namespace eval ::tcl::test::main {
catch {set f [open "|[list [interpreter]]" w+]}
catch {chan configure $f -blocking 0}
} -body {
- type $f "chan configure stdin -eofchar \\032
- if 1 \{\n\032"
+ type $f "chan configure stdin -eofchar \"\\x1A {}\"
+ if 1 \{\n\x1A"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
@@ -698,7 +696,7 @@ namespace eval ::tcl::test::main {
Tcl_Main: interactive mode: close stdin
-> main loop & [exit] & exit handlers
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
@@ -722,7 +720,7 @@ namespace eval ::tcl::test::main {
Tcl_Main: interactive mode: delete interp
-> main loop & exit handlers, but no [exit]
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
@@ -745,7 +743,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-5.10 {
Tcl_Main: exit main loop in mid-interactive command
} -constraints {
- exec Tcltest
+ exec tcl::test
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
catch {chan configure $f -blocking 0}
@@ -766,7 +764,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-5.11 {
Tcl_Main: EOF in interactive main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
@@ -788,7 +786,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-5.12 {
Tcl_Main: close stdin in interactive main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
rename exit _exit
@@ -841,7 +839,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-6.2 {
Tcl_Main: prompt deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
set tcl_prompt1 {testinterpdelete {}}
@@ -893,7 +891,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-6.5 {
Tcl_Main: interactive entry to main loop
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
set tcl_interactive 1
@@ -943,7 +941,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-7.1 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
proc exit args {}
@@ -959,7 +957,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-7.2 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
proc exit args {}
@@ -979,7 +977,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.1 {
StdinProc: handles non-blocking stdin
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -996,7 +994,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.2 {
StdinProc: handles stdin EOF
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1018,7 +1016,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.3 {
StdinProc: handles interactive stdin EOF
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1039,7 +1037,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.4 {
StdinProc: handles stdin close
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1062,7 +1060,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.5 {
StdinProc: handles interactive stdin close
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1086,7 +1084,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.6 {
StdinProc: handles event loop re-entry
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1105,7 +1103,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.7 {
StdinProc: handling of errors
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1122,7 +1120,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.8 {
StdinProc: handling of errors, closed stderr
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1140,7 +1138,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.9 {
StdinProc: interactive output
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1156,7 +1154,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.10 {
StdinProc: interactive output, closed stdout
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1174,7 +1172,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.11 {
StdinProc: prompt deletes interp
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1190,7 +1188,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.12 {
StdinProc: prompt closes stdin
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << {
testsetmainloop
@@ -1209,7 +1207,7 @@ namespace eval ::tcl::test::main {
test Tcl_Main-8.13 {
Bug 1775878
} -constraints {
- exec Tcltest
+ exec tcl::test
} -body {
exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result
set f [open result]
diff --git a/tests/mathop.test b/tests/mathop.test
index 3a46314..3c25a2b 100644
--- a/tests/mathop.test
+++ b/tests/mathop.test
@@ -4,14 +4,14 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 2006 Donal K. Fellows
-# Copyright (c) 2006 Peter Spjuth
+# Copyright © 2006 Donal K. Fellows
+# Copyright © 2006 Peter Spjuth
#
# 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.1
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -95,7 +95,7 @@ proc TestOp {op args} {
}
return [lindex $results 0]
}
-
+
# start of tests
namespace eval ::testmathop {
@@ -114,22 +114,22 @@ namespace eval ::testmathop {
test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.11 {compiled +: errors} -returnCodes error -body {
+ x 0
- } -result {can't use non-numeric string as operand of "+"}
+ } -result {can't use non-numeric string "x" as operand of "+"}
test mathop-1.12 {compiled +: errors} -returnCodes error -body {
+ nan 0
- } -result {can't use non-numeric floating-point value as operand of "+"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "+"}
test mathop-1.13 {compiled +: errors} -returnCodes error -body {
+ 0 x
- } -result {can't use non-numeric string as operand of "+"}
+ } -result {can't use non-numeric string "x" as operand of "+"}
test mathop-1.14 {compiled +: errors} -returnCodes error -body {
+ 0 nan
- } -result {can't use non-numeric floating-point value as operand of "+"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "+"}
test mathop-1.15 {compiled +: errors} -returnCodes error -body {
+ 0o8 0
- } -result {can't use invalid octal number as operand of "+"}
+ } -result {can't use invalid octal number "0o8" as operand of "+"}
test mathop-1.16 {compiled +: errors} -returnCodes error -body {
+ 0 0o8
- } -result {can't use invalid octal number as operand of "+"}
+ } -result {can't use invalid octal number "0o8" as operand of "+"}
test mathop-1.17 {compiled +: errors} -returnCodes error -body {
+ 0 [error expectedError]
} -result expectedError
@@ -152,22 +152,22 @@ namespace eval ::testmathop {
test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.29 {interpreted +: errors} -returnCodes error -body {
$op x 0
- } -result {can't use non-numeric string as operand of "+"}
+ } -result {can't use non-numeric string "x" as operand of "+"}
test mathop-1.30 {interpreted +: errors} -returnCodes error -body {
$op nan 0
- } -result {can't use non-numeric floating-point value as operand of "+"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "+"}
test mathop-1.31 {interpreted +: errors} -returnCodes error -body {
$op 0 x
- } -result {can't use non-numeric string as operand of "+"}
+ } -result {can't use non-numeric string "x" as operand of "+"}
test mathop-1.32 {interpreted +: errors} -returnCodes error -body {
$op 0 nan
- } -result {can't use non-numeric floating-point value as operand of "+"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "+"}
test mathop-1.33 {interpreted +: errors} -returnCodes error -body {
$op 0o8 0
- } -result {can't use invalid octal number as operand of "+"}
+ } -result {can't use invalid octal number "0o8" as operand of "+"}
test mathop-1.34 {interpreted +: errors} -returnCodes error -body {
$op 0 0o8
- } -result {can't use invalid octal number as operand of "+"}
+ } -result {can't use invalid octal number "0o8" as operand of "+"}
test mathop-1.35 {interpreted +: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
@@ -189,22 +189,22 @@ namespace eval ::testmathop {
test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.11 {compiled *: errors} -returnCodes error -body {
* x 0
- } -result {can't use non-numeric string as operand of "*"}
+ } -result {can't use non-numeric string "x" as operand of "*"}
test mathop-2.12 {compiled *: errors} -returnCodes error -body {
* nan 0
- } -result {can't use non-numeric floating-point value as operand of "*"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "*"}
test mathop-2.13 {compiled *: errors} -returnCodes error -body {
* 0 x
- } -result {can't use non-numeric string as operand of "*"}
+ } -result {can't use non-numeric string "x" as operand of "*"}
test mathop-2.14 {compiled *: errors} -returnCodes error -body {
* 0 nan
- } -result {can't use non-numeric floating-point value as operand of "*"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "*"}
test mathop-2.15 {compiled *: errors} -returnCodes error -body {
* 0o8 0
- } -result {can't use invalid octal number as operand of "*"}
+ } -result {can't use invalid octal number "0o8" as operand of "*"}
test mathop-2.16 {compiled *: errors} -returnCodes error -body {
* 0 0o8
- } -result {can't use invalid octal number as operand of "*"}
+ } -result {can't use invalid octal number "0o8" as operand of "*"}
test mathop-2.17 {compiled *: errors} -returnCodes error -body {
* 0 [error expectedError]
} -result expectedError
@@ -227,22 +227,22 @@ namespace eval ::testmathop {
test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.29 {interpreted *: errors} -returnCodes error -body {
$op x 0
- } -result {can't use non-numeric string as operand of "*"}
+ } -result {can't use non-numeric string "x" as operand of "*"}
test mathop-2.30 {interpreted *: errors} -returnCodes error -body {
$op nan 0
- } -result {can't use non-numeric floating-point value as operand of "*"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "*"}
test mathop-2.31 {interpreted *: errors} -returnCodes error -body {
$op 0 x
- } -result {can't use non-numeric string as operand of "*"}
+ } -result {can't use non-numeric string "x" as operand of "*"}
test mathop-2.32 {interpreted *: errors} -returnCodes error -body {
$op 0 nan
- } -result {can't use non-numeric floating-point value as operand of "*"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "*"}
test mathop-2.33 {interpreted *: errors} -returnCodes error -body {
$op 0o8 0
- } -result {can't use invalid octal number as operand of "*"}
+ } -result {can't use invalid octal number "0o8" as operand of "*"}
test mathop-2.34 {interpreted *: errors} -returnCodes error -body {
$op 0 0o8
- } -result {can't use invalid octal number as operand of "*"}
+ } -result {can't use invalid octal number "0o8" as operand of "*"}
test mathop-2.35 {interpreted *: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
@@ -261,7 +261,7 @@ namespace eval ::testmathop {
test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0
test mathop-3.8 {compiled !: errors} -body {
! foobar
- } -returnCodes error -result {can't use non-numeric string as operand of "!"}
+ } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"}
test mathop-3.9 {compiled !: errors} -body {
! 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
@@ -278,7 +278,7 @@ namespace eval ::testmathop {
test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0
test mathop-3.18 {interpreted !: errors} -body {
$op foobar
- } -returnCodes error -result {can't use non-numeric string as operand of "!"}
+ } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"}
test mathop-3.19 {interpreted !: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
@@ -287,10 +287,10 @@ namespace eval ::testmathop {
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.21 {compiled !: error} -returnCodes error -body {
! NaN
- } -result {can't use non-numeric floating-point value as operand of "!"}
+ } -result {can't use non-numeric floating-point value "NaN" as operand of "!"}
test mathop-3.22 {interpreted !: error} -returnCodes error -body {
$op NaN
- } -result {can't use non-numeric floating-point value as operand of "!"}
+ } -result {can't use non-numeric floating-point value "NaN" as operand of "!"}
test mathop-4.1 {compiled ~} {~ 0} -1
test mathop-4.2 {compiled ~} {~ 1} -2
@@ -301,7 +301,7 @@ namespace eval ::testmathop {
test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001
test mathop-4.8 {compiled ~: errors} -body {
~ foobar
- } -returnCodes error -result {can't use non-numeric string as operand of "~"}
+ } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"}
test mathop-4.9 {compiled ~: errors} -body {
~ 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
@@ -310,10 +310,10 @@ namespace eval ::testmathop {
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.11 {compiled ~: errors} -returnCodes error -body {
~ 0.0
- } -result {can't use floating-point value as operand of "~"}
+ } -result {can't use floating-point value "0.0" as operand of "~"}
test mathop-4.12 {compiled ~: errors} -returnCodes error -body {
~ NaN
- } -result {can't use non-numeric floating-point value as operand of "~"}
+ } -result {can't use non-numeric floating-point value "NaN" as operand of "~"}
set op ~
test mathop-4.13 {interpreted ~} {$op 0} -1
test mathop-4.14 {interpreted ~} {$op 1} -2
@@ -324,7 +324,7 @@ namespace eval ::testmathop {
test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001
test mathop-4.20 {interpreted ~: errors} -body {
$op foobar
- } -returnCodes error -result {can't use non-numeric string as operand of "~"}
+ } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"}
test mathop-4.21 {interpreted ~: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
@@ -333,10 +333,10 @@ namespace eval ::testmathop {
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.23 {interpreted ~: errors} -returnCodes error -body {
$op 0.0
- } -result {can't use floating-point value as operand of "~"}
+ } -result {can't use floating-point value "0.0" as operand of "~"}
test mathop-4.24 {interpreted ~: errors} -returnCodes error -body {
$op NaN
- } -result {can't use non-numeric floating-point value as operand of "~"}
+ } -result {can't use non-numeric floating-point value "NaN" as operand of "~"}
test mathop-5.1 {compiled eq} {eq {} a} 0
test mathop-5.2 {compiled eq} {eq a a} 1
@@ -377,32 +377,32 @@ namespace eval ::testmathop {
test mathop-6.4 {compiled &} { & 3 7 6 } 2
test mathop-6.5 {compiled &} -returnCodes error -body {
& 1.0 2 3
- } -result {can't use floating-point value as operand of "&"}
+ } -result {can't use floating-point value "1.0" as operand of "&"}
test mathop-6.6 {compiled &} -returnCodes error -body {
& 1 2 3.0
- } -result {can't use floating-point value as operand of "&"}
+ } -result {can't use floating-point value "3.0" as operand of "&"}
test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2
test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85
test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2
test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85
test mathop-6.11 {compiled &: errors} -returnCodes error -body {
& x 0
- } -result {can't use non-numeric string as operand of "&"}
+ } -result {can't use non-numeric string "x" as operand of "&"}
test mathop-6.12 {compiled &: errors} -returnCodes error -body {
& nan 0
- } -result {can't use non-numeric floating-point value as operand of "&"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "&"}
test mathop-6.13 {compiled &: errors} -returnCodes error -body {
& 0 x
- } -result {can't use non-numeric string as operand of "&"}
+ } -result {can't use non-numeric string "x" as operand of "&"}
test mathop-6.14 {compiled &: errors} -returnCodes error -body {
& 0 nan
- } -result {can't use non-numeric floating-point value as operand of "&"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "&"}
test mathop-6.15 {compiled &: errors} -returnCodes error -body {
& 0o8 0
- } -result {can't use invalid octal number as operand of "&"}
+ } -result {can't use invalid octal number "0o8" as operand of "&"}
test mathop-6.16 {compiled &: errors} -returnCodes error -body {
& 0 0o8
- } -result {can't use invalid octal number as operand of "&"}
+ } -result {can't use invalid octal number "0o8" as operand of "&"}
test mathop-6.17 {compiled &: errors} -returnCodes error -body {
& 0 [error expectedError]
} -result expectedError
@@ -419,32 +419,32 @@ namespace eval ::testmathop {
test mathop-6.22 {interpreted &} { $op 3 7 6 } 2
test mathop-6.23 {interpreted &} -returnCodes error -body {
$op 1.0 2 3
- } -result {can't use floating-point value as operand of "&"}
+ } -result {can't use floating-point value "1.0" as operand of "&"}
test mathop-6.24 {interpreted &} -returnCodes error -body {
$op 1 2 3.0
- } -result {can't use floating-point value as operand of "&"}
+ } -result {can't use floating-point value "3.0" as operand of "&"}
test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2
test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85
test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2
test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85
test mathop-6.29 {interpreted &: errors} -returnCodes error -body {
$op x 0
- } -result {can't use non-numeric string as operand of "&"}
+ } -result {can't use non-numeric string "x" as operand of "&"}
test mathop-6.30 {interpreted &: errors} -returnCodes error -body {
$op nan 0
- } -result {can't use non-numeric floating-point value as operand of "&"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "&"}
test mathop-6.31 {interpreted &: errors} -returnCodes error -body {
$op 0 x
- } -result {can't use non-numeric string as operand of "&"}
+ } -result {can't use non-numeric string "x" as operand of "&"}
test mathop-6.32 {interpreted &: errors} -returnCodes error -body {
$op 0 nan
- } -result {can't use non-numeric floating-point value as operand of "&"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "&"}
test mathop-6.33 {interpreted &: errors} -returnCodes error -body {
$op 0o8 0
- } -result {can't use invalid octal number as operand of "&"}
+ } -result {can't use invalid octal number "0o8" as operand of "&"}
test mathop-6.34 {interpreted &: errors} -returnCodes error -body {
$op 0 0o8
- } -result {can't use invalid octal number as operand of "&"}
+ } -result {can't use invalid octal number "0o8" as operand of "&"}
test mathop-6.35 {interpreted &: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
@@ -487,32 +487,32 @@ namespace eval ::testmathop {
test mathop-7.4 {compiled |} { | 3 7 6 } 7
test mathop-7.5 {compiled |} -returnCodes error -body {
| 1.0 2 3
- } -result {can't use floating-point value as operand of "|"}
+ } -result {can't use floating-point value "1.0" as operand of "|"}
test mathop-7.6 {compiled |} -returnCodes error -body {
| 1 2 3.0
- } -result {can't use floating-point value as operand of "|"}
+ } -result {can't use floating-point value "3.0" as operand of "|"}
test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110
test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503
test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110
test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.11 {compiled |: errors} -returnCodes error -body {
| x 0
- } -result {can't use non-numeric string as operand of "|"}
+ } -result {can't use non-numeric string "x" as operand of "|"}
test mathop-7.12 {compiled |: errors} -returnCodes error -body {
| nan 0
- } -result {can't use non-numeric floating-point value as operand of "|"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "|"}
test mathop-7.13 {compiled |: errors} -returnCodes error -body {
| 0 x
- } -result {can't use non-numeric string as operand of "|"}
+ } -result {can't use non-numeric string "x" as operand of "|"}
test mathop-7.14 {compiled |: errors} -returnCodes error -body {
| 0 nan
- } -result {can't use non-numeric floating-point value as operand of "|"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "|"}
test mathop-7.15 {compiled |: errors} -returnCodes error -body {
| 0o8 0
- } -result {can't use invalid octal number as operand of "|"}
+ } -result {can't use invalid octal number "0o8" as operand of "|"}
test mathop-7.16 {compiled |: errors} -returnCodes error -body {
| 0 0o8
- } -result {can't use invalid octal number as operand of "|"}
+ } -result {can't use invalid octal number "0o8" as operand of "|"}
test mathop-7.17 {compiled |: errors} -returnCodes error -body {
| 0 [error expectedError]
} -result expectedError
@@ -529,32 +529,32 @@ namespace eval ::testmathop {
test mathop-7.22 {interpreted |} { $op 3 7 6 } 7
test mathop-7.23 {interpreted |} -returnCodes error -body {
$op 1.0 2 3
- } -result {can't use floating-point value as operand of "|"}
+ } -result {can't use floating-point value "1.0" as operand of "|"}
test mathop-7.24 {interpreted |} -returnCodes error -body {
$op 1 2 3.0
- } -result {can't use floating-point value as operand of "|"}
+ } -result {can't use floating-point value "3.0" as operand of "|"}
test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110
test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503
test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110
test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.29 {interpreted |: errors} -returnCodes error -body {
$op x 0
- } -result {can't use non-numeric string as operand of "|"}
+ } -result {can't use non-numeric string "x" as operand of "|"}
test mathop-7.30 {interpreted |: errors} -returnCodes error -body {
$op nan 0
- } -result {can't use non-numeric floating-point value as operand of "|"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "|"}
test mathop-7.31 {interpreted |: errors} -returnCodes error -body {
$op 0 x
- } -result {can't use non-numeric string as operand of "|"}
+ } -result {can't use non-numeric string "x" as operand of "|"}
test mathop-7.32 {interpreted |: errors} -returnCodes error -body {
$op 0 nan
- } -result {can't use non-numeric floating-point value as operand of "|"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "|"}
test mathop-7.33 {interpreted |: errors} -returnCodes error -body {
$op 0o8 0
- } -result {can't use invalid octal number as operand of "|"}
+ } -result {can't use invalid octal number "0o8" as operand of "|"}
test mathop-7.34 {interpreted |: errors} -returnCodes error -body {
$op 0 0o8
- } -result {can't use invalid octal number as operand of "|"}
+ } -result {can't use invalid octal number "0o8" as operand of "|"}
test mathop-7.35 {interpreted |: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
@@ -597,32 +597,32 @@ namespace eval ::testmathop {
test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2
test mathop-8.5 {compiled ^} -returnCodes error -body {
^ 1.0 2 3
- } -result {can't use floating-point value as operand of "^"}
+ } -result {can't use floating-point value "1.0" as operand of "^"}
test mathop-8.6 {compiled ^} -returnCodes error -body {
^ 1 2 3.0
- } -result {can't use floating-point value as operand of "^"}
+ } -result {can't use floating-point value "3.0" as operand of "^"}
test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110
test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333
test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.11 {compiled ^: errors} -returnCodes error -body {
^ x 0
- } -result {can't use non-numeric string as operand of "^"}
+ } -result {can't use non-numeric string "x" as operand of "^"}
test mathop-8.12 {compiled ^: errors} -returnCodes error -body {
^ nan 0
- } -result {can't use non-numeric floating-point value as operand of "^"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "^"}
test mathop-8.13 {compiled ^: errors} -returnCodes error -body {
^ 0 x
- } -result {can't use non-numeric string as operand of "^"}
+ } -result {can't use non-numeric string "x" as operand of "^"}
test mathop-8.14 {compiled ^: errors} -returnCodes error -body {
^ 0 nan
- } -result {can't use non-numeric floating-point value as operand of "^"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "^"}
test mathop-8.15 {compiled ^: errors} -returnCodes error -body {
^ 0o8 0
- } -result {can't use invalid octal number as operand of "^"}
+ } -result {can't use invalid octal number "0o8" as operand of "^"}
test mathop-8.16 {compiled ^: errors} -returnCodes error -body {
^ 0 0o8
- } -result {can't use invalid octal number as operand of "^"}
+ } -result {can't use invalid octal number "0o8" as operand of "^"}
test mathop-8.17 {compiled ^: errors} -returnCodes error -body {
^ 0 [error expectedError]
} -result expectedError
@@ -639,32 +639,32 @@ namespace eval ::testmathop {
test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2
test mathop-8.23 {interpreted ^} -returnCodes error -body {
$op 1.0 2 3
- } -result {can't use floating-point value as operand of "^"}
+ } -result {can't use floating-point value "1.0" as operand of "^"}
test mathop-8.24 {interpreted ^} -returnCodes error -body {
$op 1 2 3.0
- } -result {can't use floating-point value as operand of "^"}
+ } -result {can't use floating-point value "3.0" as operand of "^"}
test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110
test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333
test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.29 {interpreted ^: errors} -returnCodes error -body {
$op x 0
- } -result {can't use non-numeric string as operand of "^"}
+ } -result {can't use non-numeric string "x" as operand of "^"}
test mathop-8.30 {interpreted ^: errors} -returnCodes error -body {
$op nan 0
- } -result {can't use non-numeric floating-point value as operand of "^"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "^"}
test mathop-8.31 {interpreted ^: errors} -returnCodes error -body {
$op 0 x
- } -result {can't use non-numeric string as operand of "^"}
+ } -result {can't use non-numeric string "x" as operand of "^"}
test mathop-8.32 {interpreted ^: errors} -returnCodes error -body {
$op 0 nan
- } -result {can't use non-numeric floating-point value as operand of "^"}
+ } -result {can't use non-numeric floating-point value "nan" as operand of "^"}
test mathop-8.33 {interpreted ^: errors} -returnCodes error -body {
$op 0o8 0
- } -result {can't use invalid octal number as operand of "^"}
+ } -result {can't use invalid octal number "0o8" as operand of "^"}
test mathop-8.34 {interpreted ^: errors} -returnCodes error -body {
$op 0 0o8
- } -result {can't use invalid octal number as operand of "^"}
+ } -result {can't use invalid octal number "0o8" as operand of "^"}
test mathop-8.35 {interpreted ^: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
@@ -775,13 +775,13 @@ test mathop-20.6 { one arg, error } {
# skipping - for now, knownbug...
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op {*}$vals]
- lappend exp "can't use non-numeric string as operand of \"$op\"\
+ lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\
ARITH DOMAIN {non-numeric string}"
}
}
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op NaN 1]
- lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\
+ lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\
ARITH DOMAIN {non-numeric floating-point value}"
}
expr {$res eq $exp ? 0 : $res}
@@ -850,15 +850,15 @@ test mathop-21.5 { unary ops, bad values } {
set res {}
set exp {}
lappend res [TestOp / x]
- lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp - x]
- lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ x]
- lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ! x]
- lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ 5.0]
- lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}"
+ lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}"
expr {$res eq $exp ? 0 : $res}
} 0
test mathop-21.6 { unary ops, too many } {
@@ -965,9 +965,9 @@ test mathop-22.4 { unary ops, bad values } {
set exp {}
foreach op {& | ^} {
lappend res [TestOp $op x 5]
- lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 5 x]
- lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
expr {$res eq $exp ? 0 : $res}
} 0
@@ -1080,15 +1080,15 @@ test mathop-24.3 { binary ops, bad values } {
set exp {}
foreach op {% << >>} {
lappend res [TestOp $op x 1]
- lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 1 x]
- lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
foreach op {% << >>} {
lappend res [TestOp $op 5.0 1]
- lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}"
+ lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}"
lappend res [TestOp $op 1 5.0]
- lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}"
+ lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}"
}
foreach op {in ni} {
lappend res [TestOp $op 5 "a b \{ c"]
@@ -1266,9 +1266,9 @@ test mathop-25.41 { exp operator errors } {
lappend res [TestOp ** $huge 2.1]
lappend exp "Inf"
lappend res [TestOp ** 2 foo]
- lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ** foo 2]
- lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}"
+ lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}"
expr {$res eq $exp ? 0 : $res}
} 0
@@ -1342,6 +1342,46 @@ test mathop-26.2 { misc ops, corner cases } {
set res
} [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616]
+test mathop-27.1 {lt operator} {::tcl::mathop::lt} 1
+test mathop-27.2 {lt operator} {::tcl::mathop::lt a} 1
+test mathop-27.3 {lt operator} {::tcl::mathop::lt a b} 1
+test mathop-27.4 {lt operator} {::tcl::mathop::lt b a} 0
+test mathop-27.5 {lt operator} {::tcl::mathop::lt a a} 0
+test mathop-27.6 {lt operator} {::tcl::mathop::lt a b c} 1
+test mathop-27.7 {lt operator} {::tcl::mathop::lt b a c} 0
+test mathop-27.8 {lt operator} {::tcl::mathop::lt a c b} 0
+test mathop-27.9 {lt operator} {::tcl::mathop::lt 012 0x0} 1
+
+test mathop-28.1 {le operator} {::tcl::mathop::le} 1
+test mathop-28.2 {le operator} {::tcl::mathop::le a} 1
+test mathop-28.3 {le operator} {::tcl::mathop::le a b} 1
+test mathop-28.4 {le operator} {::tcl::mathop::le b a} 0
+test mathop-28.5 {le operator} {::tcl::mathop::le a a} 1
+test mathop-28.6 {le operator} {::tcl::mathop::le a b c} 1
+test mathop-28.7 {le operator} {::tcl::mathop::le b a c} 0
+test mathop-28.8 {le operator} {::tcl::mathop::le a c b} 0
+test mathop-28.9 {le operator} {::tcl::mathop::le 012 0x0} 1
+
+test mathop-29.1 {gt operator} {::tcl::mathop::gt} 1
+test mathop-29.2 {gt operator} {::tcl::mathop::gt a} 1
+test mathop-29.3 {gt operator} {::tcl::mathop::gt a b} 0
+test mathop-29.4 {gt operator} {::tcl::mathop::gt b a} 1
+test mathop-29.5 {gt operator} {::tcl::mathop::gt a a} 0
+test mathop-29.6 {gt operator} {::tcl::mathop::gt c b a} 1
+test mathop-29.7 {gt operator} {::tcl::mathop::gt b a c} 0
+test mathop-29.8 {gt operator} {::tcl::mathop::gt a c b} 0
+test mathop-29.9 {gt operator} {::tcl::mathop::gt 0x0 012} 1
+
+test mathop-30.1 {ge operator} {::tcl::mathop::ge} 1
+test mathop-30.2 {ge operator} {::tcl::mathop::ge a} 1
+test mathop-30.3 {ge operator} {::tcl::mathop::ge a b} 0
+test mathop-30.4 {ge operator} {::tcl::mathop::ge b a} 1
+test mathop-30.5 {ge operator} {::tcl::mathop::ge a a} 1
+test mathop-30.6 {ge operator} {::tcl::mathop::ge c b a} 1
+test mathop-30.7 {ge operator} {::tcl::mathop::ge b a c} 0
+test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0
+test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1
+
if 0 {
# Compare ops to expr bytecodes
namespace import ::tcl::mathop::*
@@ -1354,7 +1394,7 @@ if 0 {
_X 3 4 5
set ::tcl_traceCompile 0
}
-
+
# cleanup
namespace delete ::testmathop
namespace delete ::testmathop2
diff --git a/tests/misc.test b/tests/misc.test
index 8f8516e..3fce454 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -5,9 +5,9 @@
# tests are pathological cases that caused bugs in earlier Tcl
# releases.
#
-# Copyright (c) 1992-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1992-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testhashsystemhash [llength [info commands testhashsystemhash]]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index d34a483..6d2ba2c 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -2,8 +2,8 @@
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998 Mark Harrison.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1998 Mark Harrison.
+# Copyright © 1998-1999 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
@@ -16,7 +16,6 @@ if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
-
if {[catch {package require msgcat 1.6}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test."
return
@@ -55,8 +54,13 @@ namespace eval ::msgcat::test {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
+if {[package vsatisfies [package provide msgcat] 1.7]} {
+ set result [string tolower \
+ [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]]
+} else {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
+}
} else {
if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
@@ -194,6 +198,28 @@ namespace eval ::msgcat::test {
mclocale looks/ok/../../../../but/is/path/to/evil/code
} -returnCodes error -match glob -result {invalid newLocale value *}
+ test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
+ variable locale [mclocale]
+ mclocale en
+ mcpreferences fr en {}
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {fr en {}}
+
+ test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
+ -setup {
+ variable locale [mclocale]
+ mcpreferences fr en {}
+ mclocale en
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {en {}}
+
+
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
test msgcat-2.1 {mcset, global scope} {
@@ -666,18 +692,18 @@ namespace eval ::msgcat::test {
set msgdir3 [makeDirectory msgdir3]
makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\
l2.msg $msgdir2
- makeFile {::msgcat::mcflset k3 v3} l2.msg $msgdir3
+ makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3
# chained mcload
- test msgcat-8.2 {mcflset} -setup {
+ test msgcat-8.2 {mcflset/mcflmset} -setup {
variable locale [mclocale]
mclocale l2
mcload $msgdir2
} -cleanup {
mclocale $locale
} -body {
- return [mc k2][mc k3]
- } -result v2v3
+ return [mc k2][mc k3]--[mc k4][mc k5]
+ } -result v2v3--v4v5
removeFile l2.msg $msgdir2
removeDirectory msgdir2
@@ -688,7 +714,7 @@ namespace eval ::msgcat::test {
test msgcat-9.1 {mcexists no parameter} -body {
mcexists
} -returnCodes 1\
- -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
+ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
test msgcat-9.2 {mcexists unknown option} -body {
mcexists -unknown src
@@ -724,12 +750,34 @@ namespace eval ::msgcat::test {
mcset foo k1 v1
} -cleanup {
mclocale $locale
+ namespace delete ::foo
} -body {
- namespace eval ::msgcat::test::sub {
+ namespace eval ::foo {
list [::msgcat::mcexists k1]\
- [::msgcat::mcexists -exactnamespace k1]
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
}
- } -result {1 0}
+ } -result {0 1}
+
+ test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo_bar
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ namespace delete ::foo
+ } -body {
+ namespace eval ::foo {
+ list [::msgcat::mcexists k1]\
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
+ }
+ } -result {0 1}
+
+ test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
+ mcexists -namespace src
+ } -returnCodes 1\
+ -result {Argument missing for switch "-namespace"}
+
# Tests msgcat-10.*: [mcloadedlocales]
@@ -811,13 +859,18 @@ namespace eval ::msgcat::test {
test msgcat-12.1 {mcpackagelocale no subcommand} -body {
mcpackagelocale
} -returnCodes 1\
- -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
+ -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
mcpackagelocale junk
} -returnCodes 1\
-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
+ test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
+ mcpackagelocale set a b
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcpackagelocale set ?locale?"}
+
test msgcat-12.3 {mcpackagelocale set} -setup {
variable locale [mclocale]
} -cleanup {
@@ -922,6 +975,30 @@ namespace eval ::msgcat::test {
list [mcpackagelocale present foo] [mcpackagelocale present bar]
} -result {0 1}
+ test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [list [mcpackagelocale preferences]]
+ mcpackagelocale preferences bar {}
+ lappend res [mcpackagelocale preferences]
+ } -result {{foo {}} {bar {}}}
+
+ test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ mcpackagelocale preferences
+ mcpackagelocale isset
+ } -result {0}
+
+
# Tests msgcat-13.*: [mcpackageconfig subcmds]
test msgcat-13.1 {mcpackageconfig no subcommand} -body {
@@ -1073,8 +1150,212 @@ namespace eval ::msgcat::test {
} -returnCodes 1\
-result {fail}
+
+ # Tests msgcat-15.*: tcloo coverage
+
+ # There are 4 use-cases, where 3 must be tested now:
+ # - namespace defined, in class definition, class defined oo, classless
+
+ test msgcat-15.1 {mc in class setup} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mc con2
+ } -result con2bar
+
+ test msgcat-15.2 {mc in class} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {::msgcat::mc con2}
+ }
+ # full namespace is ::msgcat::test:baz
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.3 {mc in classless object} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.4 {mc in classless object with explicite namespace eval}\
+ -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ ::msgcat::mc con2
+ }
+ }
+ }
+ namespace eval baz {
+ ::msgcat::mcset foo_BAR con2 con2baz
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace eval baz {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result con2baz
+
+ # Test msgcat-16.*: command mcpackagenamespaceget
+
+ test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
+ namespace eval baz {msgcat::mcpackagenamespaceget}
+ } -result ::msgcat::test::baz
+
+ test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur variable a
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mcpackagenamespaceget
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.5\
+ {mcpackagenamespaceget in classless object with explicite namespace eval}\
+ -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ msgcat::mcpackagenamespaceget
+ }
+ }
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::baz
+
+
+ # Test msgcat-17.*: mcn command
+
+ test msgcat-17.1 {mcn no parameters} -body {
+ mcn
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcn ns src ?arg ...?"}
+
+ test msgcat-17.2 {mcn} -setup {
+ namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ ::msgcat::mcn [namespace current]::bar con1
+ } -result con1bar
+
+
interp bgerror {} $bgerrorsaved
+ # Tests msgcat-18.*: [mcutil]
+
+ test msgcat-18.1 {mcutil - no argument} -body {
+ mcutil
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
+
+ test msgcat-18.2 {mcutil - wrong argument} -body {
+ mcutil junk
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
+
+ test msgcat-18.3 {mcutil - partial argument} -body {
+ mcutil getsystem
+ } -returnCodes 1\
+ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
+
+ test msgcat-18.4 {mcutil getpreferences - no argument} -body {
+ mcutil getpreferences
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getpreferences locale"}
+
+ test msgcat-18.5 {mcutil getpreferences - DE_de} -body {
+ mcutil getpreferences DE_de
+ } -result {de_de de {}}
+
+ test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body {
+ mcutil getsystemlocale DE_de
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getsystemlocale"}
+
+ # The result is system dependent
+ # So just test if it runs
+ # The environment variable version was test with test 0.x
+ test msgcat-18.7 {mcutil getsystemlocale} -body {
+ mcutil getsystemlocale
+ set ok ok
+ } -result {ok}
+
+
cleanupTests
}
namespace delete ::msgcat::test
diff --git a/tests/namespace-old.test b/tests/namespace-old.test
index a67ec14..468c648 100644
--- a/tests/namespace-old.test
+++ b/tests/namespace-old.test
@@ -7,15 +7,15 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1997 Lucent Technologies
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 1997 Lucent Technologies
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.2
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
diff --git a/tests/namespace.test b/tests/namespace.test
index 08531e4..c98ad4a 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -6,8 +6,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} {
testConstraint memory [llength [info commands memory]]
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
#
# REMARK: the tests for 'namespace upvar' are not done here. They are to be
@@ -182,8 +182,8 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns}
} {}
test namespace-7.7 {Bug 1655305} -setup {
interp create child
- # Can't invoke through the ensemble, since deleting the global namespace
- # (indirectly, via deleting ::tcl) deletes the ensemble.
+ # Can't invoke through the ensemble, since deleting ::tcl
+ # (indirectly, via deleting the global namespace) deletes the ensemble.
child eval {rename ::tcl::info::commands ::infocommands}
child hide infocommands
child eval {
@@ -207,10 +207,72 @@ test namespace-7.8 {Bug ba1419303b4c} -setup {
namespace delete ns1
}
} -body {
- # No segmentation fault given --enable-symbols=mem.
+ # No segmentation fault given --enable-symbols.
namespace delete ns1
} -result {}
+
+test namespace-7.9 {
+ Bug e39cb3f462631a99
+
+ A namespace being deleted should not be removed from other namespace paths
+ until the contents of the namespace are entirely removed.
+} -setup {
+
+
+
+
+} -body {
+
+ variable res {}
+
+
+ namespace eval ns1 {
+ proc p1 caller {
+ lappend [namespace parent]::res $caller
+ }
+ }
+
+
+ namespace eval ns1a {
+ namespace path [namespace parent]::ns1
+
+ proc t1 {old new op} {
+ $old t1
+ }
+ }
+
+ namespace eval ns2 {
+ proc p1 caller {
+ lappend [namespace parent]::res $caller
+ }
+ }
+
+ namespace eval ns2a {
+ namespace path [namespace parent]::ns2
+
+ proc t1 {old new op} {
+ [namespace tail $old] t2
+ }
+ }
+
+
+ trace add command ns1::p1 delete ns1a::t1
+ namespace delete ns1
+
+ trace add command ns2::p1 delete ns2a::t1
+ namespace delete ns2
+
+ return $res
+
+} -cleanup {
+ namespace delete ns1a
+ namespace delete ns2a
+ unset res
+} -result {t1 t2}
+
+
+
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
@@ -2741,7 +2803,11 @@ test namespace-51.12 {name resolution path control} -body {
catch {namespace delete ::test_ns_3}
catch {namespace delete ::test_ns_4}
}
-test namespace-51.13 {name resolution path control} -body {
+test namespace-51.13 {
+ name resolution path control
+ when the trace fires, ns_2 is being deleted but isn't gone yet, and is
+ still visible for the trace
+} -body {
set ::result {}
namespace eval ::test_ns_1 {
proc foo {} {lappend ::result 1}
@@ -2764,8 +2830,7 @@ test namespace-51.13 {name resolution path control} -body {
}
bar
}
- # Should the result be "2 {} {2 3 2 1}" instead?
-} -result {2 {} {2 3 1 1}} -cleanup {
+} -result {2 {} {2 3 2 1}} -cleanup {
catch {namespace delete ::test_ns_1}
catch {namespace delete ::test_ns_2}
catch {namespace delete ::test_ns_3}
@@ -3362,12 +3427,16 @@ test namespace-56.6 {
Namespace deletion traces on both the original routine and the imported
routine should run without any memory error under a debug build.
} -body {
- variable res 0
+ variable res {}
proc ondelete {old new op} {
- $old
+ variable res
+ set tail [namespace tail $old]
+ set up [namespace tail [namespace qualifiers $old]]
+ lappend res [list $up $tail]
}
+
namespace eval ns1 {} {
namespace export *
proc p1 {} {
@@ -3378,17 +3447,18 @@ test namespace-56.6 {
}
namespace eval ns2 {} {
- namespace import ::ns1::p1
+ namespace import [namespace parent]::ns1::p1
trace add command p1 delete ondelete
}
namespace delete ns1
namespace delete ns2
+ after 1
return $res
} -cleanup {
unset res
rename ondelete {}
-} -result 2
+} -result {{ns1 p1} {ns2 p1}}
test namespace-57.0 {
diff --git a/tests/notify.test b/tests/notify.test
index 7375f83..840ad31 100644
--- a/tests/notify.test
+++ b/tests/notify.test
@@ -8,7 +8,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
+# Copyright © 2003 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testevent [llength [info commands testevent]]
diff --git a/tests/nre.test b/tests/nre.test
index 7cf06d1..8296569 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -4,7 +4,7 @@
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
-# Copyright (c) 2008 by Miguel Sofer.
+# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
diff --git a/tests/obj.test b/tests/obj.test
index e49a908..64a1d5b 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -5,8 +5,8 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,21 +17,21 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint testobj [llength [info commands testobj]]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
-test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
+test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {testobj deprecated} {
set r 1
foreach {t} {
- {array search}
bytearray
bytecode
cmdName
dict
- end-offset
regexp
string
} {
@@ -53,15 +53,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
lappend result [testobj refcount 1]
} {{} 12 12 bytearray 3}
-test obj-3.1 {Tcl_ConvertToType error} testobj {
- list [testdoubleobj set 1 12.34] \
- [catch {testobj convert 1 end-offset} msg] \
- $msg
-} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
-test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
- list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
-} {{} 1 {bad index "": must be end?[+-]integer?}}
-
test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
set result ""
lappend result [testobj freeallvars]
@@ -262,10 +253,10 @@ test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} testobj
} {{} 1 {expected boolean value but got ""}}
test obj-13.8 {SetBooleanFromAny, unicode strings} testobj {
set result ""
- lappend result [teststringobj set 1 1\u7777]
+ lappend result [teststringobj set 1 1睷]
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
-} "1\u7777 1 {expected boolean value but got \"1\u7777\"}"
+} "1睷 1 {expected boolean value but got \"1睷\"}"
test obj-14.1 {UpdateStringOfBoolean} testobj {
set result ""
@@ -487,11 +478,11 @@ test obj-26.1 {UpdateStringOfInt} testobj {
lappend result [testintobj get 1] ;# must update string rep
} {512 5120 5120}
-test obj-27.1 {Tcl_NewLongObj} testobj {
+test obj-27.1 {Tcl_NewWideObj} testobj {
set result ""
lappend result [testobj freeallvars]
- testintobj setmaxlong 1
- lappend result [testintobj ismaxlong 1]
+ testintobj setmax 1
+ lappend result [testintobj ismax 1]
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 1 int 1}
@@ -500,7 +491,7 @@ test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testobj newobj 1]
- lappend result [testintobj setlong 1 77] ;# makes existing obj long int
+ lappend result [testintobj setint 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} {} 77 int 2}
@@ -508,32 +499,32 @@ test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj {
set result ""
lappend result [testobj freeallvars]
lappend result [testdoubleobj set 1 12.34]
- lappend result [testintobj setlong 1 77] ;# makes existing obj long int
+ lappend result [testintobj setint 1 77] ;# makes existing obj int
lappend result [testobj type 1]
lappend result [testobj refcount 1]
} {{} 12.34 77 int 2}
-test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj {
+test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj {
set result ""
- lappend result [testintobj setlong 1 22]
- lappend result [testintobj mult10 1] ;# gets existing long int rep
+ lappend result [testintobj setint 1 22]
+ lappend result [testintobj mult10 1] ;# gets existingint rep
} {22 220}
-test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj {
+test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj {
set result ""
- lappend result [testintobj setlong 1 477]
+ lappend result [testintobj setint 1 477]
lappend result [testintobj div10 1] ;# must convert to bool
lappend result [testobj type 1]
} {477 47 int}
-test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj {
+test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj {
set result ""
lappend result [teststringobj set 1 abc]
- lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
+ lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
lappend result $msg
} {abc 1 {expected integer but got "abc"}}
-test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj {
+test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj {
set result ""
lappend result [testobj newobj 1]
- lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int
+ lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int
lappend result $msg
} {{} 1 {expected integer but got ""}}
@@ -551,44 +542,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj {
lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 int 3 2}
-
-test obj-31.1 {regenerate string rep of "end"} testobj {
- testobj freeallvars
- teststringobj set 1 end
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end
-test obj-31.2 {regenerate string rep of "end-1"} testobj {
- testobj freeallvars
- teststringobj set 1 end-0x1
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end-1
-test obj-31.3 {regenerate string rep of "end--1"} testobj {
- testobj freeallvars
- teststringobj set 1 end--0x1
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--1
-test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj {
- testobj freeallvars
- teststringobj set 1 end-0x7fffffff
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end-2147483647
-test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj {
- testobj freeallvars
- teststringobj set 1 end--0x7fffffff
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--2147483647
-test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} {
- testobj freeallvars
- teststringobj set 1 end--0x80000000
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--2147483648
-
test obj-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
@@ -597,34 +550,34 @@ test obj-32.1 {freeing very large object trees} {
unset x
} {}
-test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
-test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
-} {0 4294967296}
-test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+} {1 4294967296}
+test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
-test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
-test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-33.7 {integer overflow on input} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
-} {0 -4294967296}
+} {1 -4294967296}
test obj-34.1 {mp_iseven} testobj {
set result ""
diff --git a/tests/oo.test b/tests/oo.test
index abd5d31..cf8b710 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2,24 +2,22 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 2006-2013 Donal K. Fellows
+# 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 TclOO 1.1.0
+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
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
-
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
@@ -40,14 +38,14 @@ if {[testConstraint memory]} {
test oo-0.1 {basic test of OO's ability to clean up its initial state} {
interp create t
t eval {
- package require TclOO
+ package require tcl::oo
}
interp delete t
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
set i [interp create]
interp eval $i {
- package require TclOO
+ package require tcl::oo
namespace delete ::
}
interp delete $i
@@ -81,7 +79,7 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup {
interp create t
} -body {
t eval {
- package require TclOO
+ package require tcl::oo
namespace path oo
list [catch {class destroy} m] $m [catch {object destroy} m] $m
}
@@ -92,7 +90,7 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup {
interp create t
} -body {
t eval {
- package require TclOO
+ package require tcl::oo
namespace path oo
list [catch {object destroy} m] $m [catch {class destroy} m] $m
}
@@ -111,10 +109,10 @@ test oo-0.8 {leak in variable management} -setup {
} -cleanup {
foo destroy
} -result 0
-test oo-0.9 {various types of presence of the TclOO package} {
- list [lsearch -nocase -all -inline [package names] tcloo] \
- [package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}]
-} [list TclOO $::oo::patchlevel 1]
+test oo-0.9 {various types of presence of the tcl::oo package} {
+ list [lsearch -nocase -all -inline [package names] tcl::oo] \
+ [package present tcl::oo] [expr {$::oo::patchlevel in [package versions tcl::oo]}]
+} [list tcl::oo $::oo::patchlevel 1]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
@@ -131,11 +129,11 @@ test oo-1.1 {basic test of OO functionality: no classes} {
} {::foo {} a b c 3 {} {}}
test oo-1.2 {basic test of OO functionality: no classes} -body {
oo::define oo::object method missingArgs
-} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\""
test oo-1.3 {basic test of OO functionality: no classes} {
catch {oo::define oo::object method missingArgs}
set errorInfo
-} "wrong # args: should be \"oo::define oo::object method name args body\"
+} "wrong # args: should be \"oo::define oo::object method name ?option? args body\"
while executing
\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
@@ -365,26 +363,27 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
set fresh [interp create]
} -body {
lmap x [$fresh eval {
+ set initials {::oo::object ::oo::class ::oo::Slot}
foreach cmd {instances subclasses mixins superclass} {
- foreach initial {object class Slot} {
- lappend x [info class $cmd ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info class $cmd $initial]
}
}
- foreach initial {object class Slot} {
- lappend x [info object class ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info object class $initial]
}
return $x
- }] {lsort $x}
+ }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
-} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
subinterp eval {
- package require TclOO
+ package require tcl::oo
}
} -body {
subinterp eval {
@@ -515,7 +514,7 @@ test oo-3.1 {basic test of OO functionality: destructor} -setup {
# modifying the root object class's constructor
interp create subinterp
subinterp eval {
- package require TclOO
+ package require tcl::oo
}
} -body {
subinterp eval {
@@ -535,7 +534,7 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup {
# we're modifying the root object class's constructor
interp create subinterp
subinterp eval {
- package require TclOO
+ package require tcl::oo
}
} -body {
subinterp eval {
@@ -814,6 +813,76 @@ test oo-4.6 {export creates proper method entries} -setup {
} -cleanup {
testClass destroy
} -result ok
+test oo-4.7 {basic test of OO functionality: method -export flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method Foo {} {
+ lappend ::result Foo
+ return foo
+ }
+ method Bar -export {} {
+ lappend ::result Bar
+ return bar
+ }
+ }
+ lappend result [catch {$o Foo} msg] $msg
+ lappend result [$o Bar]
+} -cleanup {
+ $o destroy
+} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar}
+test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -unexport {} {
+ lappend ::result bar
+ return Bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}}
+test oo-4.9 {basic test of OO functionality: method -private flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -private {} {
+ lappend ::result bar
+ return Bar
+ }
+ export eval
+ method gorp {} {
+ my bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+ lappend result [catch {$o eval my bar} msg] $msg
+ lappend result [$o gorp]
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar}
+test oo-4.10 {basic test of OO functionality: method flag parsing} -setup {
+ set o [oo::object new]
+} -body {
+ oo::objdefine $o method foo -gorp xyz {return Foo}
+} -returnCodes error -cleanup {
+ $o destroy
+} -result {bad export flag "-gorp": must be -export, -private, or -unexport}
test oo-5.1 {OO: manipulation of classes as objects} -setup {
set obj [oo::object new]
@@ -1616,9 +1685,7 @@ test oo-11.5 {OO: cleanup} {
return done
} done
-test oo-11.6.1 {
- OO: cleanup of when an class is mixed into itself
-} -constraints memory -body {
+test oo-11.6.1 {OO: cleanup of when an class is mixed into itself} -constraints memory -body {
leaktest {
interp create interp1
oo::class create obj1
@@ -1626,13 +1693,8 @@ test oo-11.6.1 {
rename obj1 {}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.2 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.2 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
leaktest {
interp create interp1
interp1 eval {
@@ -1643,13 +1705,8 @@ test oo-11.6.2 {
}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.3 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.3 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
leaktest {
interp create interp1
interp1 eval {
@@ -1662,18 +1719,13 @@ test oo-11.6.3 {
}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.4 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -body {
+} -result 0
+test oo-11.6.4 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body {
oo::class create obj1
- ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+ ::oo::define obj1 {self mixin [self]}
::oo::copy obj1 obj2
- ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]}
+ ::oo::objdefine obj2 {mixin [self]}
::oo::copy obj2 obj3
rename obj3 {}
@@ -2149,6 +2201,31 @@ test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
}
[cls new] test
} -result {mix cls}
+test oo-14.9 {OO: class mixins must be unique in list} -setup {
+ oo::class create parent
+} -body {
+ oo::class create A {superclass parent}
+ oo::class create B {
+ superclass parent
+ mixin A
+ }
+ oo::define B mixin -append A
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {class should only be a direct mixin once}
+test oo-14.10 {OO: instance mixins must be unique in list} -setup {
+ oo::class create parent
+} -body {
+ oo::class create A {superclass parent}
+ oo::class create B {
+ superclass parent
+ constructor {} {oo::objdefine [self] mixin A}
+ }
+ B create obj
+ oo::objdefine obj {mixin -append A}
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {class should only be a direct mixin once}
test oo-15.1 {OO: object cloning} {
oo::class create Aclass
@@ -2389,7 +2466,7 @@ test oo-16.2 {OO: object introspection} -body {
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
@@ -2519,6 +2596,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup {
} -cleanup {
meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
+test oo-16.15 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ info object creationid [cls new]
+} -cleanup {
+ cls destroy
+} -result {^\d+$} -match regexp
+test oo-16.16 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set obj [cls new]
+ set id [info object creationid $obj]
+ rename $obj gorp
+ set id2 [info object creationid gorp]
+ list $id $id2
+} -cleanup {
+ cls destroy
+} -result {^(\d+) \1$} -match regexp
+test oo-16.17 {OO: object introspection: creationid #500} -body {
+ info object creationid nosuchobject
+} -returnCodes error -result {nosuchobject does not refer to an object}
+test oo-16.18 {OO: object introspection: creationid #500} -body {
+ info object creationid
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.18.1 {OO: object introspection: creationid #500} -body {
+ info object creationid oo::object gorp
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.19 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ set id2 [info object creationid [set o2 [cls new]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
+test oo-16.20 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ $o1 destroy
+ set id2 [info object creationid [set o2 [cls new]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
+test oo-16.21 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ set id2 [info object creationid [set o2 [oo::copy $o1]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
test oo-17.1 {OO: class introspection} -body {
info class
@@ -2541,7 +2685,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -2640,6 +2784,7 @@ test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup {
c destroy
} -result $stdmethods
+
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
@@ -3824,7 +3969,7 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup {
} -result {v t}
test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
oo::class create Super
- oo::class create parent {
+ oo::class create Parent {
superclass Super
variable member1 member2
constructor {} {
@@ -3850,7 +3995,7 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
method result {} {return $result}
}
} -body {
- [[parent new] getChild] result
+ [[Parent new] getChild] result
} -cleanup {
Super destroy
} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2}
@@ -3957,6 +4102,11 @@ proc SampleSlotSetup script {
lappend ops [info level] Set $lst
return
}
+ method Resolve {lst} {
+ variable ops
+ lappend ops [info level] Resolve $lst
+ return $lst
+ }
}
}
append script0 \n$script
@@ -3991,7 +4141,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
@@ -3999,7 +4149,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-}] -result {0 {} {d e f} {1 Set {d e f}}}
+}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
@@ -4007,7 +4157,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}}
+test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+ SampleSlot create sampleSlot
+}] -body {
+ list [info level] [sampleSlot -prepend g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+ rename sampleSlot {}
+}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
+test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+ SampleSlot create sampleSlot
+}] -body {
+ list [info level] [sampleSlot -remove c a] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+ rename sampleSlot {}
+}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
@@ -4030,7 +4196,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup [SampleSlotCleanup {
rename $s {}
-}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
@@ -4039,7 +4205,20 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
}] -result \
- {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+ {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
+test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
+ set s [SampleSlot new]
+}] -body {
+ list \
+ [$s -clear
+ $s contents] \
+ [$s -append p q r
+ $s contents] \
+ [$s -appendifnew q s r t p
+ $s contents]
+} -cleanup [SampleSlotCleanup {
+ rename $s {}
+}] -result {{} {p q r} {p q r s t}}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -4062,32 +4241,75 @@ test oo-34.1 {TIP 380: slots - presence} -setup {
} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
test oo-34.2 {TIP 380: slots - presence} {
lsort [info class instances oo::Slot]
-} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
list [lsort [info object methods $obj -all]] \
[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
getMethods oo::define::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
getMethods oo::define::mixin
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
getMethods oo::define::superclass
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
getMethods oo::define::variable
-} {{-append -clear -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
getMethods oo::objdefine::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
getMethods oo::objdefine::mixin
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
-} {{-append -clear -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
+test oo-34.10 {TIP 516: slots - resolution} -setup {
+ oo::class create parent
+ set result {}
+ oo::class create 516a { superclass parent }
+ oo::class create 516b { superclass parent }
+ oo::class create 516c { superclass parent }
+ namespace eval 516test {
+ oo::class create 516a { superclass parent }
+ oo::class create 516b { superclass parent }
+ oo::class create 516c { superclass parent }
+ }
+} -body {
+ # Must find the right classes when making the mixin
+ namespace eval 516test {
+ oo::define 516a {
+ mixin 516b 516c
+ }
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must not remove class with just simple name match
+ oo::define 516test::516a {
+ mixin -remove 516b
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must remove class with resolved name match
+ oo::define 516test::516a {
+ mixin -remove 516test::516c
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must remove class with resolved name match even after renaming, but only
+ # with the renamed name; it is a slot of classes, not strings!
+ rename 516test::516b 516test::516d
+ oo::define 516test::516a {
+ mixin -remove 516test::516b
+ }
+ lappend result [info class mixin 516test::516a]
+ oo::define 516test::516a {
+ mixin -remove 516test::516d
+ }
+ lappend result [info class mixin 516test::516a]
+} -cleanup {
+ parent destroy
+} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}}
test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
oo::class create fruit {
@@ -4159,8 +4381,6 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly}
} -cleanup {
base destroy
} -result {{c d e} {c d e}}
-
-
test oo-35.6 {
Bug : teardown of an object that is a class that is an instance of itself
} -setup {
@@ -4183,11 +4403,1110 @@ test oo-35.6 {
rename obj {}
} -result done
+test oo-36.1 {TIP #470: introspection within oo::define} {
+ oo::define oo::object self
+} ::oo::object
+test oo-36.2 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+} -body {
+ oo::define Cls self
+} -cleanup {
+ Cls destroy
+} -result ::Cls
+test oo-36.3 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.4 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self {}]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result {}
+test oo-36.5 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self self]
+ }
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ ::set ::result [self]
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self anything
+ }
+} -returnCodes error -cleanup {
+ Cls destroy
+} -result {wrong # args: should be "self"}
+test oo-36.9 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::define::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ list [oo::define Cls testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::define::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}}
+test oo-36.10 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::objdefine::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ Cls create obj
+ list [oo::objdefine obj testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::objdefine::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
+
+test oo-37.1 {TIP 500: private command propagates errors} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private ::error "this is an error"
+ }
+} -cleanup {
+ cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.2 {TIP 500: private command propagates errors} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private {
+ ::error "this is an error"
+ }
+ }
+} -cleanup {
+ cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.3 {TIP 500: private command propagates errors} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ private ::error "this is an error"
+ }
+} -cleanup {
+ obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.4 {TIP 500: private command propagates errors} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ private {
+ ::error "this is an error"
+ }
+ }
+} -cleanup {
+ obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
+ oo::define::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
+ oo::objdefine::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+
+test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ private variable x
+ constructor {} {
+ set x 1
+ }
+ method getA {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ private {
+ variable x
+ }
+ constructor {} {
+ set x 2
+ next
+ }
+ method getB {} {
+ return $x
+ }
+ }
+ oo::class create clsC {
+ superclass clsB
+ variable x
+ constructor {} {
+ set x 3
+ next
+ }
+ method getC {} {
+ return $x
+ }
+ }
+ clsC create obj
+ oo::objdefine obj {
+ private {
+ variable x
+ }
+ method setup {} {
+ set x 4
+ }
+ method getO {} {
+ return $x
+ }
+ }
+ obj setup
+ list [obj getA] [obj getB] [obj getC] [obj getO] \
+ [lsort [string map [list [info object creationid clsA] CLASS-A \
+ [info object creationid clsB] CLASS-B \
+ [info object creationid obj] OBJ] \
+ [info object vars obj]]]
+} -cleanup {
+ parent destroy
+} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
+test oo-38.2 {TIP 500: private variables introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ private {
+ variable x1
+ variable x2
+ }
+ variable y1 y2
+ }
+ cls create obj
+ oo::objdefine obj {
+ private variable a1 a2
+ variable b1 b2
+ }
+ list [lsort [info class variables cls]] \
+ [lsort [info class variables cls -private]] \
+ [lsort [info object variables obj]] \
+ [lsort [info object variables obj -private]]
+} -cleanup {
+ parent destroy
+} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
+test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ private {
+ variable x
+ }
+ method getx {} {
+ set x 1
+ my varname x
+ }
+ method readx {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method gety {} {
+ set x 1
+ my varname x
+ }
+ method ready {} {
+ return $x
+ }
+ }
+ clsB create obj
+ set [obj getx] 2
+ set [obj gety] 3
+ list [obj readx] [obj ready]
+} -cleanup {
+ parent destroy
+} -result {2 3}
+test oo-38.4 {TIP 500: private variables introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ private {
+ variable x1 x2
+ }
+ variable y1 y2
+ constructor {} {
+ variable z boo
+ set x1 a
+ set y1 c
+ }
+ method list {} {
+ variable z
+ set ok 1
+ list [info locals] [lsort [info vars]] [info exist x2]
+ }
+ }
+ cls create obj
+ oo::objdefine obj {
+ private variable a1 a2
+ variable b1 b2
+ method init {} {
+ # Because we don't have a constructor to do this setup for us
+ set a1 p
+ set b1 r
+ }
+ method list {} {
+ variable z
+ set yes 1
+ list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
+ }
+ }
+ obj init
+ obj list
+} -cleanup {
+ parent destroy
+} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
+test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ private variable x
+ method abc val {
+ my variable x
+ set x $val
+ }
+ method def val {
+ my variable y
+ set y $val
+ }
+ method get1 {} {
+ my variable x y
+ return [list $x $y]
+ }
+ }
+ oo::class create cls2 {
+ superclass cls1
+ private variable x
+ method x-exists {} {
+ return [info exists x],[uplevel 1 {info exists x}]
+ }
+ method ghi x {
+ # Additional instrumentation to show that we're not using the
+ # resolved variable until we ask for it; the argument nixed that
+ # happening by default.
+ set val $x
+ set before [my x-exists]
+ unset x
+ set x $val
+ set mid [my x-exists]
+ unset x
+ set mid2 [my x-exists]
+ my variable x
+ set x $val
+ set after [my x-exists]
+ return "$before;$mid;$mid2;$after"
+ }
+ method jkl val {
+ my variable y
+ set y $val
+ }
+ method get2 {} {
+ my variable x y
+ return [list $x $y]
+ }
+ }
+ cls2 create a
+ a abc 123
+ a def 234
+ set tmp [a ghi 345]
+ a jkl 456
+ list $tmp [a get1] [a get2]
+} -cleanup {
+ parent destroy
+} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}
+
+test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ my step
+ my step
+ return
+ }
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ method x {} {
+ return $x
+ }
+ }
+ clsA create obj
+ obj act
+ list [obj x] [catch {obj step} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {7 1 {unknown method "step": must be act, destroy or x}}
+test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ my step
+ my step
+ return
+ }
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ method x {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method step {} {
+ incr x 5
+ }
+ }
+ clsB create obj
+ obj act
+ list [obj x] [obj step]
+} -cleanup {
+ parent destroy
+} -result {7 12}
+test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my Step
+ my Step
+ my Step
+ return
+ }
+ method x {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method Step {} {
+ incr x 5
+ }
+ }
+ clsB create obj
+ obj act
+ set result [obj x]
+ oo::define clsA {
+ private {
+ method Step {} {
+ incr x 2
+ }
+ }
+ }
+ obj act
+ lappend result [obj x]
+} -cleanup {
+ parent destroy
+} -result {16 22}
+test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ return
+ }
+ method step {} {
+ incr x
+ }
+ method x {} {
+ return $x
+ }
+ }
+ clsA create obj
+ obj act
+ set result [obj x]
+ oo::objdefine obj {
+ variable x
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ }
+ obj act
+ lappend result [obj x]
+ oo::objdefine obj {
+ method act {} {
+ my step
+ next
+ }
+ }
+ obj act
+ lappend result [obj x]
+} -cleanup {
+ parent destroy
+} -result {2 3 6}
+test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {$x == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ cls create c 1
+ list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
+test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {$x == [$other y]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {[[self] y] == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {[my y] == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
+test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ method equal {other} {
+ expr {[my y] == [$other x]}
+ }
+ }
+ cls2 create a 1
+ cls2 create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ method equal {other} {
+ expr {[my x] == [$other x]}
+ }
+ }
+ cls2 create a 1
+ cls2 create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method chain {} {
+ return [self call]
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ private method chain {} {
+ next
+ }
+ method chain2 {} {
+ my chain
+ }
+ method chain3 {} {
+ [self] chain
+ }
+ }
+ cls create a
+ cls2 create b
+ list [a chain] [b chain] [b chain2] [b chain3]
+} -cleanup {
+ parent destroy
+} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
+test oo-39.12 {TIP 500: private methods; introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method chain {} {
+ return [self call]
+ }
+ private method abc {} {}
+ }
+ oo::class create cls2 {
+ superclass cls
+ method chain2 {} {
+ my chain
+ }
+ method chain3 {} {
+ [self] chain
+ }
+ private method def {} {}
+ unexport chain3
+ }
+ cls create a
+ cls2 create b
+ oo::objdefine b {
+ private method ghi {} {}
+ method ABC {} {}
+ method foo {} {}
+ }
+ set scopes {public unexported private}
+ list a: [lmap s $scopes {info object methods a -scope $s}] \
+ b: [lmap s $scopes {info object methods b -scope $s}] \
+ cls: [lmap s $scopes {info class methods cls -scope $s}] \
+ cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
+} -cleanup {
+ parent destroy
+} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
+
+test oo-40.1 {TIP 500: private and self} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ self {
+ private {
+ variable a
+ }
+ variable b
+ }
+ private {
+ self {
+ variable c
+ }
+ variable d
+ }
+ variable e
+ }
+ list \
+ [lsort [info class variables cls]] \
+ [lsort [info class variables cls -private]] \
+ [lsort [info object variables cls]] \
+ [lsort [info object variables cls -private]]
+} -cleanup {
+ cls destroy
+} -result {e d b {a c}}
+test oo-40.2 {TIP 500: private and export} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private method foo {} {}
+ }
+ set result [lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+ oo::define cls {
+ export foo
+ }
+ lappend result {*}[lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+} -cleanup {
+ cls destroy
+} -result {{} {} foo foo {} {}}
+test oo-40.3 {TIP 500: private and unexport} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private method foo {} {}
+ }
+ set result [lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+ oo::define cls {
+ unexport foo
+ }
+ lappend result {*}[lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+} -cleanup {
+ cls destroy
+} -result {{} {} foo {} foo {}}
+
+test oo-41.1 {TIP 478: myclass command, including class morphing} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method count {} {
+ my variable c
+ incr c
+ }
+ method act {} {
+ myclass count
+ }
+ }
+ cls1 create x
+ lappend result [x act] [x act]
+ cls1 create y
+ lappend result [y act] [y act] [x act]
+ oo::class create cls2 {
+ superclass cls1
+ self method count {} {
+ my variable d
+ expr {1.0 * [incr d]}
+ }
+ }
+ oo::objdefine x {class cls2}
+ lappend result [x act] [y act] [x act] [y act]
+} -cleanup {
+ parent destroy
+} -result {1 2 3 4 5 1.0 6 2.0 7}
+test oo-41.2 {TIP 478: myclass command cleanup} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method hi {} {
+ return "this is [self]"
+ }
+ method hi {} {
+ return "this is [self]"
+ }
+ }
+ cls1 create x
+ rename [info object namespace x]::my foo
+ rename [info object namespace x]::myclass bar
+ lappend result [cls1 hi] [x hi] [foo hi] [bar hi]
+ x destroy
+ lappend result [catch {foo hi}] [catch {bar hi}]
+} -cleanup {
+ parent destroy
+} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1}
+test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method Hi {} {
+ return "this is [self]"
+ }
+ forward poke myclass Hi
+ }
+ cls1 create x
+ lappend result [catch {cls1 Hi}] [x poke]
+} -cleanup {
+ parent destroy
+} -result {1 {this is ::cls1}}
+test oo-42.1 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object
+} {}
+test oo-42.2 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -class
+} {}
+test oo-42.3 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -instance
+} ::oo::objdefine
+test oo-42.4 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -gorp
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-42.5 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -class x
+} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"}
+test oo-42.6 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class
+} ::oo::define
+test oo-42.7 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -class
+} ::oo::define
+test oo-42.8 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -instance
+} {}
+
+test oo-43.1 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ oo::class create foo {
+ superclass parent
+ self class foocls
+ }
+ oo::define foo {
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.2 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.3 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -class foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.4 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -instance foodef
+ }
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {invalid command name "sparkle"}
+test oo-43.5 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ namespace delete foodef
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {invalid command name "sparkle"}
+test oo-43.6 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace delete foodef
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+} -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {0 ok 1 {invalid command name "sparkle"} 0 ok}
+test oo-43.7 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {x} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ }
+ oo::define foo spar gorp
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.8 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foo {
+ superclass parent
+ definitionnamespace -instance foodef
+ }
+ oo::objdefine [foo new] {
+ method x y z
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.9 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -gorp foodef
+ }
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-43.10 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -class foodef x
+ }
+} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"}
+test oo-43.11 {TIP 524: definition namespace control: syntax} -setup {
+ catch {namespace delete ::no_such_ns}
+} -body {
+ oo::class create foo {
+ definitionnamespace -class ::no_such_ns
+ }
+} -returnCodes error -result {namespace "::no_such_ns" not found}
+test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass oo::class parent
+ }
+ list [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace foodef] \
+ [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace {}] \
+ [info class definitionnamespace foo]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
+test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass parent
+ }
+ list [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance foodef] \
+ [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance {}] \
+ [info class definitionnamespace foo -instance]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
cleanupTests
return
# Local Variables:
-# MODE: Tcl
+# mode: tcl
# End:
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index 726757b..8d8cf45 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -2,12 +2,12 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 2006-2011 Donal K. Fellows
+# 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 TclOO 1.1.0
+package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
diff --git a/tests/ooProp.test b/tests/ooProp.test
new file mode 100644
index 0000000..8120f88
--- /dev/null
+++ b/tests/ooProp.test
@@ -0,0 +1,885 @@
+# This file contains a collection of tests for Tcl's built-in object system,
+# specifically the parts that support configurable properties on objects.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright © 2019-2020 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.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+ namespace import -force ::tcltest::*
+}
+
+test ooProp-1.1 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set a a a
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties c] [info class properties c -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
+test ooProp-1.2 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a a a
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
+test ooProp-1.3 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set a a a
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties c] [info class properties c -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
+test ooProp-1.4 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a a a
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
+test ooProp-1.5 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ oo::define d ::oo::configuresupport::readableproperties -set x y z
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ oo::define d ::oo::configuresupport::readableproperties -set r p q
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a a h
+ oo::define d ::oo::configuresupport::readableproperties -set g h g
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define d ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}}
+test ooProp-1.6 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ oo::define d ::oo::configuresupport::writableproperties -set x y z
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ oo::define d ::oo::configuresupport::writableproperties -set r p q
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a a h
+ oo::define d ::oo::configuresupport::writableproperties -set g h g
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define d ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}}
+test ooProp-1.7 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ c create o
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set
+ lappend result [info object properties o] [info object properties o -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}}
+test ooProp-1.8 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ c create o
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set
+ lappend result [info object properties o] [info object properties o -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}}
+test ooProp-1.9 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ d create o
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b
+ oo::define d ::oo::configuresupport::readableproperties -set c d
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c d e f} {} {a b c d e f} {}}
+test ooProp-1.10 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ d create o
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b
+ oo::define d ::oo::configuresupport::writableproperties -set c d
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c d e f} {} {a b c d e f}}
+test ooProp-1.11 {TIP 558: properties: core support cache} -setup {
+ oo::class create parent
+ unset -nocomplain result
+} -body {
+ oo::class create m {
+ superclass parent
+ ::oo::configuresupport::readableproperties -set a
+ ::oo::configuresupport::writableproperties -set c
+ }
+ oo::class create c {
+ superclass parent
+ ::oo::configuresupport::readableproperties -set b
+ ::oo::configuresupport::writableproperties -set d
+ }
+ c create o
+ lappend result [info object properties o -all -readable] \
+ [info object properties o -all -writable]
+ oo::objdefine o mixin m
+ lappend result [info object properties o -all -readable] \
+ [info object properties o -all -writable]
+} -cleanup {
+ parent destroy
+} -result {b d {a b} {c d}}
+
+test ooProp-2.1 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ variable x y
+ method report {} {
+ lappend ::result "x=$x, y=$y"
+ }
+ }
+ set pt [Point new -x 3]
+ $pt report
+ $pt configure -y 4
+ $pt report
+ lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
+test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ oo::configurable create 3DPoint {
+ superclass Point
+ property z
+ constructor args {
+ next -z 0 {*}$args
+ }
+ }
+ set pt [3DPoint new -x 3 -y 4 -z 5]
+ list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
+ [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {3,4,5 {-x 3 -y 4 -z 5}}
+test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ set pt [Point new -x 3 -y 4]
+ oo::objdefine $pt property z
+ $pt configure -z 5
+ list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
+ [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {3,4,5 {-x 3 -y 4 -z 5}}
+test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ [Point new] configure gorp
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property "gorp": must be -x or -y}
+test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ oo::configurable create 3DPoint {
+ superclass Point
+ property z
+ constructor args {
+ next -z 0 {*}$args
+ }
+ }
+ [3DPoint new] configure gorp
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property "gorp": must be -x, -y, or -z}
+test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ [Point create p] configure -x 1 -y
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {wrong # args: should be "::p configure ?-option value ...?"}
+test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y -kind writable
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ Point create p
+ list [p configure -y ok] [catch {p configure -y} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{} 1 {property "-y" is write only}}
+test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y -kind readable
+ constructor args {
+ my configure -x 0 {*}$args
+ variable y 123
+ }
+ }
+ Point create p
+ list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}
+
+test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property x -get {
+ global result
+ lappend result "get"
+ return [lrepeat 3 $xyz]
+ } -set {
+ global result
+ lappend result [list set $value]
+ set xyz [expr {$value * 3}]
+ }
+ }
+ Point create pt
+ pt configure -x 5
+ lappend result >[pt configure -x]<
+} -cleanup {
+ parent destroy
+} -result {{set 5} get {>15 15 15<}}
+test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property x -get {
+ global result
+ lappend result "get"
+ return [lrepeat 3 $xyz]
+ } -set {
+ global result
+ lappend result [list set $value]
+ set xyz [expr {$value * 3}]
+ } y -kind readable -get {return $xyz}
+ }
+ Point create pt
+ pt configure -x 5
+ lappend result >[pt configure -x]< [pt configure -y]
+} -cleanup {
+ parent destroy
+} -result {{set 5} get {>15 15 15<} 15}
+test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property -x -get {return $xyz}
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "-x": must not begin with -}
+test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property "x y"
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x y": must be a simple word}
+test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property ::x
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "::x": must not contain namespace separators}
+test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x(
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x(": must not contain parentheses}
+test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x)
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x)": must not contain parentheses}
+test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -get
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -get option}
+test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -set
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -set option}
+test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -kind
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing kind value to go with -kind option}
+test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -get {} -set
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -set option}
+test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {} -get {return ok}
+ }
+ [Point new] configure -x
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -kind gorp
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad kind "gorp": must be readable, readwrite, or writable}
+test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -k reada -g {return ok}
+ }
+ [Point new] configure -x
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property {*}{
+ x -kind writable
+ y -get {return ok}
+ }
+ }
+ [Point new] configure -y
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ variable xy
+ property x -kind readable -get {return $xy}
+ property x -kind writable -set {set xy $value}
+ }
+ Point create pt
+ list [catch {
+ pt configure -x ok
+ } msg] $msg [catch {
+ pt configure -x
+ } msg] $msg [catch {
+ pt configure -y 1
+ } msg] $msg
+} -cleanup {
+ parent destroy
+} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}}
+test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code break}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a break}
+test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code break}
+ }
+ while 1 {
+ [Point new] configure
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a break}
+test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {error "boo"}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {error "boo"}
+ }
+ while 1 {
+ [Point new] configure
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code continue}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a continue}
+test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure -x
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -code break}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property setter for -x did a break}
+test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -code continue}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property setter for -x did a continue}
+test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {error "boo"}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure -x gorp
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ private property var
+ }
+ Point create pt
+ pt configure -var ok
+ pt configure -var
+} -cleanup {
+ parent destroy
+} -result ok
+
+test ooProp-4.1 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property -x}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property name "-x": must not begin with -
+ while executing
+"property -x"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}}
+test ooProp-4.2 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -get}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing body to go with -get option
+ while executing
+"property x -get"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -get}"} {TCL WRONGARGS}}
+test ooProp-4.3 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -set}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing body to go with -set option
+ while executing
+"property x -set"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -set}"} {TCL WRONGARGS}}
+test ooProp-4.4 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -kind}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing kind value to go with -kind option
+ while executing
+"property x -kind"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -kind}"} {TCL WRONGARGS}}
+test ooProp-4.5 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -kind gorp}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad kind "gorp": must be readable, readwrite, or writable
+ while executing
+"property x -kind gorp"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}}
+test ooProp-4.6 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -gorp}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad option "-gorp": must be -get, -kind, or -set
+ while executing
+"property x -gorp"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}}
+test ooProp-4.7 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x
+ }
+ Point create pt
+ list [catch {pt configure -gorp} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property "-gorp": must be -x
+ while executing
+"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}}
+test ooProp-4.8 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x
+ }
+ Point create pt
+ list [catch {pt configure -gorp blarg} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property "-gorp": must be -x
+ while executing
+"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
new file mode 100644
index 0000000..9e1de8f
--- /dev/null
+++ b/tests/ooUtil.test
@@ -0,0 +1,586 @@
+# 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
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ Table find foo bar
+} -cleanup {
+ parent destroy
+} -result {::Table called with arguments: foo bar}
+test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
+ namespace eval ::testns {}
+} -body {
+ namespace eval ::testns {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ }
+ testns::Table find foo bar
+} -cleanup {
+ namespace delete ::testns
+} -result {::testns::Table called with arguments: foo bar}
+test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
+ oo::class create parent
+} -body {
+ oo::class create TestClass {
+ superclass oo::class parent
+ self method create {name ignore body} {
+ next $name $body
+ }
+ }
+ TestClass create okay {} {}
+} -cleanup {
+ parent destroy
+} -result {::okay}
+test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ oo::class create SubTable {
+ superclass Table
+ }
+ SubTable find foo bar
+} -cleanup {
+ parent destroy
+} -result {::SubTable called with arguments: foo bar}
+test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ set t [Table new]
+ $t find 1 2 3
+} -cleanup {
+ parent destroy
+} -result {::Table called with arguments: 1 2 3}
+test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ unexport find
+ }
+ set t [Table new]
+ $t find 1 2 3
+} -returnCodes error -cleanup {
+ parent destroy
+} -match glob -result {unknown method "find": must be *}
+test ooUtil-1.7 {} -setup {
+ oo::class create parent
+} -body {
+ oo::class create Foo {
+ superclass parent
+ classmethod bar {} {
+ puts "This is in the class; self is [self]"
+ my meee
+ }
+ classmethod meee {} {
+ puts "This is meee"
+ }
+ }
+ oo::class create Grill {
+ superclass Foo
+ classmethod meee {} {
+ puts "This is meee 2"
+ }
+ }
+ list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
+# Two tests to confirm that we correctly initialise the scripted part of TclOO
+# in child interpreters. This is slightly tricky at the implementation level
+# because we cannot count on either [source] or [open] being available.
+test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
+ set childinterp [interp create]
+} -body {
+ $childinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is not the parent interpreter
+ list [Table find foo bar] [info globals childinterp]
+ }
+} -cleanup {
+ interp delete $childinterp
+} -result {{::Table called with arguments: foo bar} {}}
+test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
+ set safeinterp [interp create -safe]
+} -body {
+ $safeinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is a (basic) safe interpreter
+ list [Table find foo bar] [info commands source]
+ }
+} -cleanup {
+ interp delete $safeinterp
+} -result {{::Table called with arguments: foo bar} {}}
+
+test ooUtil-2.1 {TIP 478: callback generation} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {} { return ok,[self] }
+ method makeCall {} {
+ return [callback CallMe]
+ }
+ }
+ c create ::context
+ set cb [context makeCall]
+ {*}$cb
+} -cleanup {
+ parent destroy
+} -result {ok,::context}
+test ooUtil-2.2 {TIP 478: callback generation} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ method makeCall {b} {
+ return [callback CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ {*}$cb PQR
+} -cleanup {
+ parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {} { return ok,[self] }
+ method makeCall {} {
+ return [mymethod CallMe]
+ }
+ }
+ c create ::context
+ set cb [context makeCall]
+ {*}$cb
+} -cleanup {
+ parent destroy
+} -result {ok,::context}
+test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ method makeCall {b} {
+ return [mymethod CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ {*}$cb PQR
+} -cleanup {
+ parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method makeCall {b} {
+ return [callback CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ set result [list [catch {{*}$cb PQR} msg] $msg]
+ oo::objdefine context {
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ }
+ lappend result [{*}$cb PQR]
+} -cleanup {
+ parent destroy
+} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
+test ooUtil-2.6 {TIP 478: callback use case} -setup {
+ oo::class create parent
+ unset -nocomplain x
+} -body {
+ oo::class create c {
+ superclass parent
+ variable count
+ constructor {var} {
+ set count 0
+ upvar 1 $var v
+ trace add variable v write [callback TraceCallback]
+ }
+ method count {} {return $count}
+ method TraceCallback {name1 name2 op} {
+ incr count
+ }
+ }
+ set o [c new x]
+ for {set x 0} {$x < 5} {incr x} {}
+ $o count
+} -cleanup {
+ unset -nocomplain x
+ parent destroy
+} -result 6
+
+test ooUtil-3.1 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.1 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialise {
+ proc foobar-3.1 {} {return ok}
+ }
+ method calls {} {
+ list [catch foobar-3.1 msg] $msg \
+ [namespace eval [info object namespace [self class]] foobar-3.1]
+ }
+ }
+ [cls new] calls
+} -cleanup {
+ parent destroy
+} -result {1 {invalid command name "foobar-3.1"} ok}
+test ooUtil-3.2 {TIP 478: class variables} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.1 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialise {
+ variable x 123
+ }
+ method call {} {
+ classvariable x
+ incr x
+ }
+ }
+ cls create a
+ cls create b
+ cls create c
+ list [a call] [b call] [c call] [a call] [b call] [c call]
+} -cleanup {
+ parent destroy
+} -result {124 125 126 127 128 129}
+test ooUtil-3.3 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.3 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialize {
+ proc foobar-3.3 {} {return ok}
+ }
+ method calls {} {
+ list [catch foobar-3.3 msg] $msg \
+ [namespace eval [info object namespace [self class]] foobar-3.3]
+ }
+ }
+ [cls new] calls
+} -cleanup {
+ parent destroy
+} -result {1 {invalid command name "foobar-3.3"} ok}
+test ooUtil-3.4 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::appendToResultVar {}}
+ proc ::appendToResultVar args {
+ lappend ::result {*}$args
+ }
+ set result {}
+} -body {
+ trace add execution oo::define::initialise enter appendToResultVar
+ oo::class create ::cls {
+ superclass parent
+ initialize {proc xyzzy {} {}}
+ }
+ return $result
+} -cleanup {
+ catch {
+ trace remove execution oo::define::initialise enter appendToResultVar
+ }
+ rename ::appendToResultVar {}
+ parent destroy
+} -result {{initialize {proc xyzzy {} {}}} enter}
+test ooUtil-3.5 {TIP 478: class initialisation} -body {
+ oo::define oo::object {
+ ::list [::namespace which initialise] [::namespace which initialize] \
+ [::namespace origin initialise] [::namespace origin initialize]
+ }
+} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
+
+test ooUtil-4.1 {TIP 478: singleton} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ set x [xyz new]
+ set y [xyz new]
+ set z [xyz new]
+ set code [catch {$x destroy} msg]
+ set p [xyz new]
+ lappend code [catch {rename $x ""}]
+ set q [xyz new]
+ string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
+} -cleanup {
+ parent destroy
+} -result {1 0 ONE ONE ONE ONE TWO TWO}
+test ooUtil-4.2 {TIP 478: singleton errors} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ [xyz new] destroy
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {may not destroy a singleton object}
+test ooUtil-4.3 {TIP 478: singleton errors} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ oo::copy [xyz new]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {may not clone a singleton object}
+
+
+test ooUtil-5.1 {TIP 478: abstract} -setup {
+ oo::class create parent
+} -body {
+ oo::abstract create xyz {
+ superclass parent
+ method foo {} {return 123}
+ }
+ oo::class create pqr {
+ superclass xyz
+ method bar {} {return 456}
+ }
+ set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
+ set x [pqr new]
+ set y [pqr create ::y]
+ lappend codes [$x foo] [$x bar] $y
+} -cleanup {
+ parent destroy
+} -result {1 1 1 123 456 ::y}
+
+test ooUtil-6.1 {TIP 478: classvariable} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ initialise {
+ variable x 1 y 2
+ }
+ method a {} {
+ classvariable x
+ incr x
+ }
+ method b {} {
+ classvariable y
+ incr y
+ }
+ method c {} {
+ classvariable x y
+ list $x $y
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ set result [list [$p c] [$q c]]
+ $p a
+ $q b
+ lappend result [[xyz new] c]
+} -cleanup {
+ parent destroy
+} -result {{1 2} {1 2} {2 3}}
+test ooUtil-6.2 {TIP 478: classvariable error case} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ method a {} {
+ classvariable x(1)
+ incr x(1)
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ list [$p a] [$q a]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
+test ooUtil-6.3 {TIP 478: classvariable error case} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ method a {} {
+ classvariable ::x
+ incr x
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ list [$p a] [$q a]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
+
+test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method foo {} {return "in foo of [self]"}
+ method Bar {} {return "in bar of [self]"}
+ method Grill {} {return "in grill of [self]"}
+ export eval
+ constructor {} {
+ link foo
+ link {bar Bar} {grill Grill}
+ }
+ }
+ cls create o
+ o eval {list [foo] [bar] [grill]}
+} -cleanup {
+ parent destroy
+} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
+test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method foo {} {return "in foo of [self]"}
+ constructor {cmd} {
+ link [list ::$cmd foo]
+ }
+ }
+ cls create o pqr
+ list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
+
+# Tests a very weird combination of things (with a key problem locus in
+# MixinClassDelegates) that TIP 567 fixes
+test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup {
+ oo::class create parent
+} -body {
+ ::oo::class create A {
+ superclass parent
+ }
+ ::oo::class create B {
+ superclass ::oo::class parent
+ constructor {{definitionScript ""}} {
+ next $definitionScript
+ next {superclass ::A}
+ }
+ }
+ B create C {
+ superclass A
+ }
+ C create instance
+} -cleanup {
+ parent destroy
+} -result ::instance
+
+# Tests that verify issues detected with the tcllib version of the code
+test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
+ oo::class create animal {}
+ namespace eval ::ooutiltest {
+ oo::class create pet { superclass animal }
+ }
+} -body {
+ namespace eval ::ooutiltest {
+ oo::class create dog { superclass pet }
+ }
+} -cleanup {
+ namespace delete ooutiltest
+ rename animal {}
+} -result {::ooutiltest::dog}
+test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
+ oo::class create TestClass {
+ superclass oo::class
+ self method create {name ignore body} {
+ next $name $body
+ }
+ }
+} -body {
+ TestClass create okay {} {}
+} -cleanup {
+ rename TestClass {}
+} -result {::okay}
+
+cleanupTests
+return
+
+# Local Variables:
+# fill-column: 78
+# mode: tcl
+# End:
diff --git a/tests/opt.test b/tests/opt.test
index 419e6bf..2d304c6 100644
--- a/tests/opt.test
+++ b/tests/opt.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/package.test b/tests/package.test
index 641ce49..134b4f7 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -5,28 +5,34 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2011 Donal K. Fellows
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 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.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.3.3
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact tcl::test [info patchlevel]]
+
# Do all this in a child interp to avoid garbaging the package list
set i [interp create]
tcltest::loadIntoChildInterpreter $i {*}$argv
+catch [list load {} Tcltest $i]
interp eval $i {
namespace import -force ::tcltest::*
-package forget {*}[package names]
+#package forget {*}[package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
+
+testConstraint testpreferstable [llength [info commands testpreferstable]]
test package-1.1 {pkg::create gives error on insufficient args} -body {
::pkg::create
@@ -134,7 +140,7 @@ test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.4}
test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
@@ -144,7 +150,7 @@ test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {3.5}
test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
@@ -154,7 +160,7 @@ test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.2
- return $x
+ set x
} -result {2.3}
test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
@@ -164,7 +170,7 @@ test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup {
package ifneeded t $i "set x $i; package provide t $i"
}
package require -exact t 2.3
- return $x
+ set x
} -result {2.3}
test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup {
package forget t
@@ -174,7 +180,7 @@ test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t 2.1
- return $x
+ set x
} -result {2.4}
test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup {
package forget t
@@ -233,7 +239,7 @@ test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup {
} -body {
package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2"
package require t 1.2
- return $x
+ set x
} -result {1.2}
test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package forget t
@@ -251,7 +257,7 @@ test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
}
package unknown pkgUnknown
package require -exact t 1.5
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {t 1.5-1.5}
@@ -278,7 +284,7 @@ test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup {
package provide [lindex $args 0] 2.0
}
package require {a b}
- return $x
+ set x
} -cleanup {
package unknown {}
} -result {{a b} 0-}
@@ -569,15 +575,24 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup {
} -returnCodes error -cleanup {
package forget demo
} -result {version conflict for package "demo": have 1.2.3, need exactly 1.2}
-test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup {
+test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ interp create child
+ load {} Tcltest child
+ child eval {
+ testpreferstable
package forget t
set x xxx
+ }
} -body {
+ child eval {
foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
+ }
+} -cleanup {
+ interp delete child
} -result {3.4}
test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
@@ -587,7 +602,7 @@ test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup {
package forget t
@@ -597,17 +612,19 @@ test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup
package ifneeded t $i "set x $i; package provide t $i"
}
package require t
- return $x
+ set x
} -result {1.3}
-test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} {
+test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup {
+ testpreferstable
package forget t
+ set x xxx
+} -body {
foreach i {1.2b1 1.1} {
package ifneeded t $i "set x $i; package provide t $i"
}
- set x xxx
package require t
set x
-} {1.1}
+} -result {1.1}
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
package forget t
} -body {
@@ -625,28 +642,51 @@ test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
package
} -result {wrong # args: should be "package option ?arg ...?"}
-test package-4.2 {Tcl_PackageCmd procedure, "forget" option} {
+test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
-test package-4.3 {Tcl_PackageCmd procedure, "forget" option} {
+ }
+} -cleanup {
+ interp delete child
+} -result {}
+test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package forget foo
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
set result {}
+ }
} -body {
+ child eval {
package ifneeded t 1.1 {first script}
package ifneeded t 2.3 {second script}
package ifneeded x 1.4 {x's script}
lappend result [lsort [package names]] [package versions t]
package forget t
lappend result [lsort [package names]] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{t x} {1.1 2.3} x {}}
test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded a 1.1 {first script}
package ifneeded b 2.3 {second script}
package ifneeded c 1.4 {third script}
@@ -654,6 +694,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup {
set result [list [lsort [package names]]]
package forget a c
lappend result [lsort [package names]]
+ }
+} -cleanup {
+ interp delete child
} -result {{a b c} b}
test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body {
# Test for Bug 415273
@@ -672,28 +715,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body {
test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body {
package ifneeded t xyz
} -returnCodes error -result {expected version number but got "xyz"}
-test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} {
+test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
list [package ifneeded foo 1.1] [package names]
-} {{} {}}
+ }
+} -cleanup {
+ interp delete child
+} -result {{} {}}
test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package names] [package ifneeded t 1.4] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {t {script for t 1.4} 1.4}
test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
list [package ifneeded t 1.5] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{} t 1.4}
test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
- package forget t
+ interp create child
+ child eval {
+ package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded t 1.4 "script for t 1.4"
package ifneeded t 1.4 "second script for t 1.4"
list [package ifneeded t 1.4] [package names] [package versions t]
+ }
+} -cleanup {
+ interp delete child
} -result {{second script for t 1.4} t 1.4}
test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
package forget t
@@ -706,18 +776,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup {
test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body {
package names a
} -returnCodes error -result {wrong # args: should be "package names"}
-test package-4.15 {Tcl_PackageCmd procedure, "names" option} {
+test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+} -body {
+ child eval {
package forget {*}[package names]
package names
-} {}
+ }
+} -cleanup {
+ interp delete child
+} -result {}
test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup {
+ interp create child
+ child eval {
package forget {*}[package names]
+ }
} -body {
+ child eval {
package ifneeded x 1.2 {dummy}
package provide x 1.3
package provide y 2.4
catch {package require z 47.16}
lsort [package names]
+ }
+} -cleanup {
+ interp delete child
} -result {x y}
test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body {
package provide
@@ -848,7 +931,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
} {0}
test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body {
package foo
-} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
+} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}
test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body {
package vsatisfies 2.1 2.1-3.2-4.5
} -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"}
@@ -1255,9 +1338,9 @@ proc prefer {args} {
}
}
-test package-13.0 {package prefer defaults} {
+test package-13.0 {package prefer defaults} -body {
prefer
-} stable
+} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}]
test package-13.1 {package prefer defaults} -body {
set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant!
prefer
@@ -1272,15 +1355,27 @@ test package-14.1 {bogus argument} -returnCodes error -body {
package prefer foo
} -result {bad preference "foo": must be latest or stable}
-test package-15.0 {set, keep} {package prefer stable} stable
-test package-15.1 {set stable, keep} {prefer stable} {stable stable}
-test package-15.2 {set latest, change} {prefer latest} {stable latest}
-test package-15.3 {set latest, keep} {
- prefer latest latest
-} {stable latest latest}
-test package-15.4 {set stable, rejected} {
- prefer latest stable
-} {stable latest latest}
+test package-15.0 {set, keep} -constraints testpreferstable -setup {
+ testpreferstable
+} -body {package prefer} -result stable
+test package-15.1 {set stable, keep} -constraints testpreferstable -setup {
+ testpreferstable
+} -body {package prefer stable} -result stable
+test package-15.2 {set latest, change} -constraints testpreferstable -setup {
+ testpreferstable
+} -body {package prefer latest} -result latest
+test package-15.3 {set latest, keep} -constraints testpreferstable -setup {
+ testpreferstable
+} -body {
+ package prefer latest
+ package prefer latest
+} -result latest
+test package-15.4 {set stable, rejected} -constraints testpreferstable -setup {
+ testpreferstable
+} -body {
+ package prefer latest
+ package prefer stable
+} -result latest
rename prefer {}
diff --git a/tests/parse.test b/tests/parse.test
index 39f3d1e..b0c051b 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -2,22 +2,22 @@
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
-if {[catch {package require tcltest 2.0.2}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
- return
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::parse {
namespace import ::tcltest::*
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
testConstraint testbytestring [llength [info commands testbytestring]]
@@ -31,7 +31,7 @@ testConstraint testevent [llength [info commands testevent]]
testConstraint memory [llength [info commands memory]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} {
- testparser [testbytestring "foo\0 bar"] -1
+ testparser [testbytestring "foo\x00 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -300,8 +300,8 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser {
testparser "\"b\\\nc\"" 0
} {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}}
test parse-6.16 {ParseTokens procedure, backslash substitution} testparser {
- testparser {\n\a\x7f} 0
-} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}}
+ testparser {\n\a\x7F} 0
+} {- {\n\a\x7F} 1 word {\n\a\x7F} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7F} 0 {}}
test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} {
expr {[testparser [testbytestring "foo\0zz"] 0] eq
"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}"
@@ -685,7 +685,7 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
-test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
+test parse-13.6 {Tcl_ParseVar memory leak} -constraints {testparsevar memory} -setup {
proc getbytes {} {
return [lindex [split [memory info] \n] 3 3]
}
@@ -707,7 +707,7 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
} -result 0
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} {
- testparser [testbytestring "foo\0 bar"] -1
+ testparser [testbytestring "foo\x00 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -744,7 +744,7 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser {
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"}
test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} {
- testparser [testbytestring "foo\0 bar"] -1
+ testparser [testbytestring "foo\x00 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -910,10 +910,10 @@ test parse-15.54 {CommandComplete procedure} "
info complete \"foo bar;# \{\"
" 1
test parse-15.55 {CommandComplete procedure} testbytestring {
- info complete "set x [testbytestring \0]; puts hi"
+ info complete "set x [testbytestring \x00]; puts hi"
} 1
test parse-15.56 {CommandComplete procedure} testbytestring {
- info complete "set x [testbytestring \0]; \{"
+ info complete "set x [testbytestring \x00]; \{"
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index aded88a..fd32df9 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -2,8 +2,8 @@
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
@@ -32,9 +32,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -44,19 +44,19 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -66,11 +66,11 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -85,7 +85,7 @@ testConstraint ieeeFloatingPoint [testIEEE]
######################################################################
test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} {
- testexprparser [testbytestring "1+2\0 +3"] -1
+ testexprparser [testbytestring "1+2\x00 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser {
testexprparser "1 + 2" -1
@@ -882,17 +882,17 @@ test parseExpr-21.36 {error messages} -body {
} -returnCodes error -result {invalid character "@"
in expression "...fghijklmnopqrstuvwxyz"@"abcdefghijklmnopqrstu..."}
test parseExpr-21.37 {error messages} -body {
- expr [format {"%s" @ 0} [string repeat \u00a7 25]]
+ expr [format {"%s" @ 0} [string repeat \xA7 25]]
} -returnCodes error -result [format {invalid character "@"
-in expression "...%s" @ 0"} [string repeat \u00a7 10]]
+in expression "...%s" @ 0"} [string repeat \xA7 10]]
test parseExpr-21.38 {error messages} -body {
- expr [format {0 @ "%s"} [string repeat \u00a7 25]]
+ expr [format {0 @ "%s"} [string repeat \xA7 25]]
} -returnCodes error -result [format {invalid character "@"
-in expression "0 @ "%s..."} [string repeat \u00a7 10]]
+in expression "0 @ "%s..."} [string repeat \xA7 10]]
test parseExpr-21.39 {error messages} -body {
- expr [format {"%s" @ "%s"} [string repeat \u00a7 25] [string repeat \u00a7 25]]
+ expr [format {"%s" @ "%s"} [string repeat \xA7 25] [string repeat \xA7 25]]
} -returnCodes error -result [format {invalid character "@"
-in expression "...%s" @ "%s..."} [string repeat \u00a7 10] [string repeat \u00a7 10]]
+in expression "...%s" @ "%s..."} [string repeat \xA7 10] [string repeat \xA7 10]]
test parseExpr-21.40 {error messages} -body {
catch {expr {"abcdefghijklmnopqrstuvwxyz"@0}} m o
dict get $o -errorinfo
@@ -902,13 +902,13 @@ in expression "...fghijklmnopqrstuvwxyz"@0"
invoked from within
"expr {"abcdefghijklmnopqrstuvwxyz"@0}"}
test parseExpr-21.41 {error messages} -body {
- catch {expr [format {"%s" @ 0} [string repeat \u00a7 25]]} m o
+ catch {expr [format {"%s" @ 0} [string repeat \xA7 25]]} m o
dict get $o -errorinfo
} -result [format {invalid character "@"
in expression "...%s" @ 0"
(parsing expression ""%s...")
invoked from within
-"expr [format {"%%s" @ 0} [string repeat \u00a7 25]]"} [string repeat \u00a7 10] [string repeat \u00a7 10]]
+"expr [format {"%%s" @ 0} [string repeat \xA7 25]]"} [string repeat \xA7 10] [string repeat \xA7 10]]
test parseExpr-21.42 {error message} -body {
expr {123456789012345678901234567890*"abcdefghijklmnopqrstuvwxyz}
} -returnCodes error -result {missing "
@@ -1034,7 +1034,7 @@ test parseExpr-22.10 {Bug 3401704} -constraints testexprparser -body {
dict get $o -errorcode
} -result {TCL PARSE EXPR BADCHAR}
test parseExpr-22.11 {Bug 3401704} -constraints testexprparser -body {
- catch {testexprparser 1e-3_() -1} m o
+ catch {testexprparser 1e-3`() -1} m o
dict get $o -errorcode
} -result {TCL PARSE EXPR BADCHAR}
test parseExpr-22.12 {Bug 3401704} -constraints testexprparser -body {
@@ -1046,9 +1046,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body {
} -result {- {} 0 subexpr naner() 1 operator naner 0 {}}
test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body {
- catch {testexprparser 08 -1} m o
- dict get $o -errorcode
-} -result {TCL PARSE EXPR BADNUMBER OCTAL}
+ testexprparser 07 -1
+} -result {- {} 0 subexpr 07 1 text 07 0 {}}
test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body {
catch {testexprparser 0o8 -1} m o
dict get $o -errorcode
@@ -1067,15 +1066,23 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
} -result {TCL PARSE EXPR BADNUMBER BINARY}
test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body {
- testexprparser \u0433 -1
+ testexprparser г -1
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body {
- testexprparser \u043f -1
+ testexprparser п -1
} -returnCodes error -match glob -result {*invalid character*}
test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body {
- testexprparser in\u0433(0) -1
+ testexprparser inг(0) -1
} -returnCodes error -match glob -result {missing operand*}
+test parseExpr-23.1 {TIP 582: comments} -constraints testexprparser -body {
+ testexprparser "7 # * 8 " -1
+} -result {- {} 0 subexpr 7 1 text 7 0 {}}
+test parseExpr-23.2 {TIP 582: comments} -constraints testexprparser -body {
+ testexprparser "7 #\n* 8 " -1
+} -result {- {} 0 subexpr {7 #
+*} 5 operator # 0 subexpr 7 1 text 7 0 subexpr * 1 text * 0 {}}
+
# cleanup
cleanupTests
return
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 0ac036b..44aa5d1 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -6,9 +6,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -19,10 +19,9 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testwordend [llength [info commands testwordend]]
-testConstraint testbytestring [llength [info commands testbytestring]]
# Save the argv value for restoration later
set savedArgv $argv
@@ -264,14 +263,14 @@ test parseOld-7.10 {backslash substitution} {
test parseOld-7.11 {backslash substitution} {
eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
-test parseOld-7.12 {backslash substitution} testbytestring {
- expr {[list \ua2] eq [testbytestring "\xc2\xa2"]}
+test parseOld-7.12 {backslash substitution} {
+ expr {[list \uA2] eq "¢"}
} 1
-test parseOld-7.13 {backslash substitution} testbytestring {
- expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]}
+test parseOld-7.13 {backslash substitution} {
+ expr {[list \u4E21] eq "両"}
} 1
-test parseOld-7.14 {backslash substitution} testbytestring {
- expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]}
+test parseOld-7.14 {backslash substitution} {
+ expr {[list \u4E2k] eq "Ӣk"}
} 1
# Semi-colon.
diff --git a/tests/pid.test b/tests/pid.test
index 47f753b..3f62457 100644
--- a/tests/pid.test
+++ b/tests/pid.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1995 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1995 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl
index 9d89277..96542f9 100644
--- a/tests/pkgIndex.tcl
+++ b/tests/pkgIndex.tcl
@@ -1,3 +1,3 @@
#! /usr/bin/env tclsh
-package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl]
+package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl] \ No newline at end of file
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index e047840..33add42 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -5,7 +5,7 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
@@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
exec [interpreter] << $cmd
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
+
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so we can
# delete the file and not get stuck because we're holding a reference to
# it.
#
# This test depends on context from prior test, so repeat it.
+
set script \
"[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]"
append script \n \
"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
exec [interpreter] << $script
pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
-} {0 {}}
+} "0 {}"
if {[testConstraint $dll]} {
file delete -force [file join $fullPkgPath [file tail $x]]
diff --git a/tests/platform.test b/tests/platform.test
index faab6d9..33aea3a 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1999 by Scriptics Corporation
+# Copyright © 1999 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -22,9 +22,10 @@ namespace eval ::tcl::test::platform {
namespace upvar :: tcl_platform tcl_platform
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testCPUID [llength [info commands testcpuid]]
+testConstraint testlongsize [llength [info commands testlongsize]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
@@ -39,16 +40,9 @@ test platform-1.1 {TclpSetVariables: tcl_platform} {
set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
-# Test assumes twos-complement arithmetic, which is true of virtually
-# everything these days. Note that this does *not* use wide(), and
-# this is intentional since that could make Tcl's numbers wider than
-# the machine-integer on some platforms...
-test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
- set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}]
- # Result must be the largest bit in a machine word, which this checks
- # without assuming how wide the word really is
- list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
-} {1 -1}
+test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize {
+ expr {$tcl_platform(wordSize) == [testlongsize]}
+} {1}
# On Windows/UNIX, test that the CPU ID works
diff --git a/tests/proc-old.test b/tests/proc-old.test
index 4d1f0d7..8c510ce 100644
--- a/tests/proc-old.test
+++ b/tests/proc-old.test
@@ -7,9 +7,9 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/proc.test b/tests/proc.test
index 72cb412..118dca1 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -7,8 +7,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,8 +17,9 @@ if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
-testConstraint procbodytest [expr {![catch {package require procbodytest}]}]
+testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
testConstraint memory [llength [info commands memory]]
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -210,14 +211,14 @@ catch {rename p ""}
catch {rename t ""}
# Note that the test require that procedures whose body is used to create
-# procbody objects must be executed before the procbodytest::proc command is
+# procbody objects must be executed before the tcl::procbodytest::proc command is
# executed, so that the Proc struct is populated correctly (CompiledLocals are
# added at compile time).
-test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body {
+test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body {
proc p x {return "$x:$x"}
set rv [p P]
- procbodytest::proc t x p
+ tcl::procbodytest::proc t x p
lappend rv [t T]
} -cleanup {
catch {rename p ""}
@@ -229,9 +230,9 @@ test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body {
return "$x:$y"
}
set rv [p P]
- procbodytest::proc t x p
+ tcl::procbodytest::proc t x p
lappend rv [t T]
-} -constraints procbodytest -cleanup {
+} -constraints tcl::test -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {P:p T:t}
@@ -241,9 +242,9 @@ test proc-4.3 {TclCreateProc, procbody obj, too many args} -body {
return "$x:$y"
}
set rv [p P]
- procbodytest::proc t {x x1 x2} p
+ tcl::procbodytest::proc t {x x1 x2} p
lappend rv [t T]
-} -constraints procbodytest -returnCodes error -cleanup {
+} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1}
@@ -254,9 +255,9 @@ test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body {
return "$v:$w"
}
set rv [p P Q R]
- procbodytest::proc t {x x1 z} p
+ tcl::procbodytest::proc t {x x1 z} p
lappend rv [t S T U]
-} -constraints procbodytest -returnCodes error -cleanup {
+} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body}
@@ -267,9 +268,9 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body
return "$v:$w"
}
set rv [p P Q R]
- procbodytest::proc t {x y z} p
+ tcl::procbodytest::proc t {x y z} p
lappend rv [t S T U]
-} -constraints procbodytest -returnCodes error -cleanup {
+} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
@@ -280,9 +281,9 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body
return "$v:$w"
}
set rv [p P Q R]
- procbodytest::proc t {x y {z Z}} p
+ tcl::procbodytest::proc t {x y {z Z}} p
lappend rv [t S T U]
-} -returnCodes error -constraints procbodytest -cleanup {
+} -returnCodes error -constraints tcl::test -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
@@ -293,9 +294,9 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -bod
return "$v:$w"
}
set rv [p P Q R]
- procbodytest::proc t {x y {z ZZ}} p
+ tcl::procbodytest::proc t {x y {z ZZ}} p
lappend rv [t S T U]
-} -constraints procbodytest -returnCodes error -cleanup {
+} -constraints tcl::test -returnCodes error -cleanup {
catch {rename p ""}
catch {rename t ""}
} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
@@ -309,10 +310,10 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
return "$x:$y"
}
px x
-} -constraints {procbodytest memory} -body {
+} -constraints {tcl::test memory} -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
- procbodytest::proc tx x px
+ tcl::procbodytest::proc tx x px
set tmp $end
set end [getbytes]
}
@@ -321,8 +322,8 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
rename getbytes {}
unset -nocomplain end i tmp leakedBytes
} -result 0
-test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
- procbodytest::check
+test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test {
+ tcl::procbodytest::check
} 1
test proc-4.10 {
TclCreateProc, issue a8579d906a28, argument with no name
diff --git a/tests/process.test b/tests/process.test
new file mode 100644
index 0000000..4533108
--- /dev/null
+++ b/tests/process.test
@@ -0,0 +1,341 @@
+# process.test --
+#
+# This file contains a collection of tests for the tcl::process ensemble.
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+#
+# Copyright © 2017 Frederic Bonnet
+# 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::*
+}
+
+# Utilities
+file delete [set path(test-signalfile) [makeFile {} test-signalfile]]
+set path(test-signalfile2) [makeFile {} test-signalfile2]
+# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted)
+set path(sleep) [makeFile {
+ after [expr {[lindex $argv 0]*1000}] {set stop 1}
+ if {[set fn [lindex $::argv 1]] ne ""} {
+ close [open $fn w]
+ proc check {} {
+ if {![file exists $::fn]} { # exit signaled
+ after 10 {set ::stop 2}
+ }
+ after 10 check
+ }
+ after 10 check
+ }
+ vwait stop
+ exit
+} sleep]
+
+proc wait_for_file {fn {timeout 10000}} {
+ if {![file exists $fn]} {
+ set toev [after $timeout {set found 0}]
+ proc check {fn} {
+ if {[file exists $fn]} {
+ set ::found 1
+ return
+ }
+ after 10 [list check $fn]
+ }
+ after 10 [list check $fn]
+ vwait ::found
+ after cancel $toev
+ unset ::found
+ }
+ file exists $fn
+}
+proc signal_exit {fn {wait 1}} {
+ # wait for until file created if expected:
+ if {!$wait || [wait_for_file $fn]} {
+ # delete file to signal exit for child-process:
+ while {1} {
+ if {![catch { file delete $fn } msg opt]
+ || [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES}
+ } break
+ }
+ }
+}
+
+set path(exit) [makeFile {
+ exit [lindex $argv 0]
+} exit]
+
+# Basic syntax checking
+test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
+ tcl::process
+} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
+test process-1.2 {tcl::process subcommands} -returnCodes error -body {
+ tcl::process ?
+} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
+
+# Autopurge flag
+# - Default state
+test process-2.1 {autopurge default} -body {
+ tcl::process autopurge
+} -result {1}
+# - Enabling autopurge
+test process-2.2 {enable autopurge} -body {
+ tcl::process autopurge true
+ tcl::process autopurge
+} -result {1}
+# - Disabling autopurge
+test process-2.3 {disable autopurge} -body {
+ tcl::process autopurge false
+ tcl::process autopurge
+} -result {0} -cleanup {tcl::process autopurge true}
+
+# Subprocess list & status
+test process-3.1 {empty subprocess list} -body {
+ llength [tcl::process list]
+} -result {0}
+test process-3.2 {empty subprocess status} -body {
+ dict size [tcl::process status]
+} -result {0}
+
+# Spawn subprocesses using [exec]
+# - One child
+test process-4.1 {exec one child} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 0 &]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status [lindex [tcl::process status $pid] 1]
+ expr {
+ [llength $list] eq 1
+ && [lindex $list 0] eq $pid
+ && [dict size $statuses] eq 1
+ && [dict get $statuses $pid] eq $status
+ && $status eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - Two children
+test process-4.2 {exec two children in parallel} -body {
+ tcl::process autopurge 0
+ set pid1 [exec [interpreter] $path(exit) 0 &]
+ set pid2 [exec [interpreter] $path(exit) 0 &]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ expr {
+ [llength $list] eq 2
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [dict size $statuses] eq 2
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && $status1 eq 0
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-4.3 {exec 3-stage pipe} -body {
+ tcl::process autopurge 0
+ set pids [exec \
+ [interpreter] $path(exit) 0 \
+ | [interpreter] $path(exit) 0 \
+ | [interpreter] $path(exit) 0 \
+ &]
+ lassign $pids pid1 pid2 pid3
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ set status3 [lindex [tcl::process status $pid3] 1]
+ expr {
+ [llength $pids] eq 3
+ && [llength $list] eq 3
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [lsearch $list $pid3] >= 0
+ && [dict size $statuses] eq 3
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && [dict get $statuses $pid3] eq $status3
+ && $status1 eq 0
+ && $status2 eq 0
+ && $status3 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Spawn subprocesses using [open "|"]
+# - One child
+test process-5.1 {exec one child} -body {
+ tcl::process autopurge 0
+ set f [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set pid [pid $f]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status [lindex [tcl::process status $pid] 1]
+ expr {
+ [llength $list] eq 1
+ && [lindex $list 0] eq $pid
+ && [dict size $statuses] eq 1
+ && [dict get $statuses $pid] eq $status
+ && $status eq 0
+ }
+} -result {1} -cleanup {
+ close $f
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - Two children
+test process-5.2 {exec two children in parallel} -body {
+ tcl::process autopurge 0
+ set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+ set pid1 [pid $f1]
+ set pid2 [pid $f2]
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ expr {
+ [llength $list] eq 2
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [dict size $statuses] eq 2
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && $status1 eq 0
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ close $f1
+ close $f2
+ tcl::process purge
+ tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-5.3 {exec 3-stage pipe} -body {
+ tcl::process autopurge 0
+ set f [open "|
+ \"[interpreter]\" \"$path(exit)\" 0
+ | \"[interpreter]\" \"$path(exit)\" 0
+ | \"[interpreter]\" \"$path(exit)\" 0
+ "]
+ set pids [pid $f]
+ lassign $pids pid1 pid2 pid3
+ set list [tcl::process list]
+ set statuses [tcl::process status -wait]
+ set status1 [lindex [tcl::process status $pid1] 1]
+ set status2 [lindex [tcl::process status $pid2] 1]
+ set status3 [lindex [tcl::process status $pid3] 1]
+ expr {
+ [llength $pids] eq 3
+ && [llength $list] eq 3
+ && [lsearch $list $pid1] >= 0
+ && [lsearch $list $pid2] >= 0
+ && [lsearch $list $pid3] >= 0
+ && [dict size $statuses] eq 3
+ && [dict get $statuses $pid1] eq $status1
+ && [dict get $statuses $pid2] eq $status2
+ && [dict get $statuses $pid3] eq $status3
+ && $status1 eq 0
+ && $status2 eq 0
+ && $status3 eq 0
+ }
+} -result {1} -cleanup {
+ close $f
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Async child status
+test process-6.1 {async status} -setup {
+ signal_exit $path(test-signalfile) 0; # clean signal-file
+} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
+ set status1 [lindex [tcl::process status $pid] 1]
+ signal_exit $path(test-signalfile); # signal exit (stop sleep)
+ set status2 [lindex [tcl::process status -wait $pid] 1]
+ expr {
+ $status1 eq {}
+ && $status2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-6.2 {selective wait} -setup {
+ signal_exit $path(test-signalfile) 0; # clean signal-files
+ signal_exit $path(test-signalfile2) 0;
+} -body {
+ tcl::process autopurge 0
+ # Child 1 sleeps 1s
+ set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
+ # Child 2 sleeps 1s
+ set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &]
+ # Initial status
+ set status1_1 [lindex [tcl::process status $pid1] 1]
+ set status1_2 [lindex [tcl::process status $pid2] 1]
+ # Wait until child 1 termination
+ signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep)
+ set status2_1 [lindex [tcl::process status -wait $pid1] 1]
+ set status2_2 [lindex [tcl::process status $pid2] 1]
+ # Wait until child 2 termination
+ signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep)
+ set status3_2 [lindex [tcl::process status -wait $pid2] 1]
+ set status3_1 [lindex [tcl::process status $pid1] 1]
+ expr {
+ $status1_1 eq {}
+ && $status1_2 eq {}
+ && $status2_1 eq 0
+ && $status2_2 eq {}
+ && $status3_1 eq 0
+ && $status3_2 eq 0
+ }
+} -result {1} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+# Error codes
+test process-7.1 {normal exit} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 0 &]
+ lindex [tcl::process status -wait $pid] 1
+} -result {0} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-7.2 {abnormal exit} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) 1 &]
+ lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+test process-7.3 {child killed} -constraints {win} -body {
+ tcl::process autopurge 0
+ set pid [exec [interpreter] $path(exit) -1 &]
+ lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
+ tcl::process purge
+ tcl::process autopurge 1
+}
+
+removeFile $path(exit)
+removeFile $path(sleep)
+
+rename wait_for_file {}
+rename signal_exit {}
+::tcltest::cleanupTests
+return
diff --git a/tests/pwd.test b/tests/pwd.test
index 3d4cffd..c069eef 100644
--- a/tests/pwd.test
+++ b/tests/pwd.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/range.test b/tests/range.test
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tests/range.test
diff --git a/tests/reg.test b/tests/reg.test
index 34edc97..b6198d8 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -7,14 +7,15 @@
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
-# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
+# Copyright © 1998, 1999 Henry Spencer. All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# All tests require the testregexp command, return if this
# command doesn't exist
@@ -513,8 +514,8 @@ expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b"
expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b"
expectError 9.42 - {a[\Z]b} EESCAPE
expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c"
-expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \
- "a\u0102\u02ffb" "a\u0102\u02ffb"
+expectMatch 9.44 EMP* {a[\xFE-\u0507][\xFF-\u0300]b} \
+ "a\u0102\u02FFb" "a\u0102\u02FFb"
doing 10 "anchors and newlines"
@@ -642,8 +643,8 @@ expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x"
expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x"
expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x"
expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x"
-expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x"
-expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x"
+expectMatch 13.33 P "a\\U1000000x" "a\uFFFD0x" "a\uFFFD0x"
+expectMatch 13.34 P {a\U1000000x} "a\uFFFD0x" "a\uFFFD0x"
doing 14 "back references"
diff --git a/tests/regexp.test b/tests/regexp.test
index e29cecf..16c775e 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1998 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1998 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,8 +17,22 @@ if {"::tcltest" ni [namespace children]} {
}
unset -nocomplain foo
-
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint exec [llength [info commands exec]]
+
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc memtest script {
+ set end [lindex [split [memory info] \n] 3 3]
+ for {set i 0} {$i < 5} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [lindex [split [memory info] \n] 3 3]
+ }
+ expr {$end - $tmp}
+ }
+}
test regexp-1.1 {basic regexp operation} {
regexp ab*c abbbc
@@ -40,8 +54,8 @@ test regexp-1.6 {basic regexp operation} {
} {0 1}
test regexp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
- set foo "\u4e4eb q"
- regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
+ set foo "乎b q"
+ regexp "乎b q" "a乎b qw幎N wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}
test regexp-1.8 {regexp ***= metasyntax} {
@@ -180,14 +194,14 @@ test regexp-3.7 {getting substrings back from regexp} {
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexp-3.8a {-indices by multi-byte utf-8} {
regexp -inline -indices {(\w+)-(\w+)} \
- "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"
+ "grüß-привет"
} {{0 10} {0 3} {5 10}}
test regexp-3.8b {-indices by multi-byte utf-8, from -start position} {
list\
[regexp -inline -indices -start 3 {(\w+)-(\w+)} \
- "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \
+ "grüß-привет"] \
[regexp -inline -indices -start 4 {(\w+)-(\w+)} \
- "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"]
+ "grüß-привет"]
} {{{3 10} {3 3} {5 10}} {}}
test regexp-4.1 {-nocase option to regexp} {
@@ -338,8 +352,8 @@ test regexp-7.16 {basic regsub operation} {
} {0 {}}
test regexp-7.17 {regsub utf compliance} {
# if not UTF-8 aware, result is "0 1"
- set foo "xyz555ijka\u4e4ebpqr"
- regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
+ set foo "xyz555ijka乎bpqr"
+ regsub a乎b xyza乎bijka乎bpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
} {0 0}
test regexp-7.18 {basic regsub replacement} {
@@ -464,7 +478,7 @@ test regexp-11.4 {regsub errors} {
} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
@@ -539,133 +553,133 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co
removeFile junk.tcl
} -result 1
-test regexp-15.1 {regexp -start} {
+test regexp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
-} {1 1}
-test regexp-15.2 {regexp -start} {
+} -result {1 1}
+test regexp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
-} {1 2}
-test regexp-15.3 {regexp -start} {
+} -result {1 2}
+test regexp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
-} {1 2}
-test regexp-15.4 {regexp -start} {
+} -result {1 2}
+test regexp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
-} {1 3}
-test regexp-15.5 {regexp -start, over end of string} {
+} -result {1 3}
+test regexp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
-} {0 0}
-test regexp-15.6 {regexp -start, loss of ^$ behavior} {
+} -result {0 0}
+test regexp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
-} {0}
-test regexp-15.7 {regexp -start, double option} {
+} -result {0}
+test regexp-15.7 {regexp -start, double option} -body {
regexp -start 2 -start 0 a abc
-} 1
-test regexp-15.8 {regexp -start, double option} {
+} -result 1
+test regexp-15.8 {regexp -start, double option} -body {
regexp -start 0 -start 2 a abc
-} 0
-test regexp-15.9 {regexp -start, end relative index} {
+} -result 0
+test regexp-15.9 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end {\d} 1abc2de3 x] [info exists x]
-} {0 0}
-test regexp-15.10 {regexp -start, end relative index} {
+} -result {0 0}
+test regexp-15.10 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
-} {1 1 3}
-test regexp-15.11 {regexp -start, over end of string} {
+} -result {1 1 3}
+test regexp-15.11 {regexp -start, over end of string} -body {
set x NA
list [regexp -start 2 {.*} ab x] $x
-} {1 {}}
+} -result {1 {}}
-test regexp-16.1 {regsub -start} {
+test regexp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
-} {4 a1b/2c/3d/4e/5}
-test regexp-16.2 {regsub -start} {
+} -result {4 a1b/2c/3d/4e/5}
+test regexp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
-} {0 hello}
-test regexp-16.3 {regsub -start} {
+} -result {0 hello}
+test regexp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
-} {0 hello}
-test regexp-16.4 {regsub -start, \A behavior} {
+} -result {0 hello}
+test regexp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
-} {5 /a/b/c/d/e 3 ab/c/d/e}
-test regexp-16.5 {regsub -start, double option} {
+} -result {5 /a/b/c/d/e 3 ab/c/d/e}
+test regexp-16.5 {regsub -start, double option} -body {
list [regsub -start 2 -start 0 a abc c x] $x
-} {1 cbc}
-test regexp-16.6 {regsub -start, double option} {
+} -result {1 cbc}
+test regexp-16.6 {regsub -start, double option} -body {
list [regsub -start 0 -start 2 a abc c x] $x
-} {0 abc}
-test regexp-16.7 {regexp -start, end relative index} {
+} -result {0 abc}
+test regexp-16.7 {regexp -start, end relative index} -body {
list [regsub -start end a aaa b x] $x
-} {0 aaa}
-test regexp-16.8 {regexp -start, end relative index} {
+} -result {0 aaa}
+test regexp-16.8 {regexp -start, end relative index} -body {
list [regsub -start end-1 a aaa b x] $x
-} {1 aab}
-test regexp-16.9 {regsub -start and -all} {
+} -result {1 aab}
+test regexp-16.9 {regsub -start and -all} -body {
set foo {}
list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo
-} {2 a|xxx|b|xx|}
-test regexp-16.10 {regsub -start and -all} {
+} -result {2 a|xxx|b|xx|}
+test regexp-16.10 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo
-} {2 a|xxx|b|xx|}
-test regexp-16.11 {regsub -start and -all} {
+} -result {2 a|xxx|b|xx|}
+test regexp-16.11 {regsub -start and -all} -body {
set foo {}
list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo
-} {1 axxxb|xx|}
-test regexp-16.12 {regsub -start} {
+} -result {1 axxxb|xx|}
+test regexp-16.12 {regsub -start} -body {
set foo {}
list [regsub -start 4 x+ axxxbxx |&| foo] $foo
-} {1 axxxb|xx|}
-test regexp-16.13 {regsub -start and -all} {
+} -result {1 axxxb|xx|}
+test regexp-16.13 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all a+ "" & foo] $foo
-} {0 {}}
-test regexp-16.14 {regsub -start} {
+} -result {0 {}}
+test regexp-16.14 {regsub -start} -body {
set foo {}
list [regsub -start 1 a+ "" & foo] $foo
-} {0 {}}
-test regexp-16.15 {regsub -start and -all} {
+} -result {0 {}}
+test regexp-16.15 {regsub -start and -all} -body {
set foo {}
list [regsub -start 2 -all a+ "xy" & foo] $foo
-} {0 xy}
-test regexp-16.16 {regsub -start} {
+} -result {0 xy}
+test regexp-16.16 {regsub -start} -body {
set foo {}
list [regsub -start 2 a+ "xy" & foo] $foo
-} {0 xy}
-test regexp-16.17 {regsub -start and -all} {
+} -result {0 xy}
+test regexp-16.17 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all y+ "xy" & foo] $foo
-} {1 xy}
-test regexp-16.18 {regsub -start} {
+} -result {1 xy}
+test regexp-16.18 {regsub -start} -body {
set foo {}
list [regsub -start 1 y+ "xy" & foo] $foo
-} {1 xy}
-test regexp-16.19 {regsub -start} {
+} -result {1 xy}
+test regexp-16.19 {regsub -start} -body {
set foo {}
list [regsub -start -1 a+ "" & foo] $foo
-} {0 {}}
-test regexp-16.20 {regsub -start, loss of ^$ behavior} {
+} -result {0 {}}
+test regexp-16.20 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^$} {} & foo] $foo
-} {0 {}}
-test regexp-16.21 {regsub -start, loss of ^$ behavior} {
+} -result {0 {}}
+test regexp-16.21 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^.*$} abc & foo] $foo
-} {0 abc}
-test regexp-16.22 {regsub -start, loss of ^$ behavior} {
+} -result {0 abc}
+test regexp-16.22 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -all -start 1 {^.*$} abc & foo] $foo
-} {0 abc}
+} -result {0 abc}
test regexp-17.1 {regexp -inline} {
regexp -inline b ababa
@@ -751,45 +765,45 @@ test regexp-19.2 {regsub null replacement} {
string equal $result $expected
} 1
-test regexp-20.1 {regsub shared object shimmering} {
+test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
-} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
-test regexp-20.2 {regsub shared object shimmering with -about} {
+} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
+test regexp-20.2 {regsub shared object shimmering with -about} -body {
eval regexp -about abc
-} {0 {}}
+} -result {0 {}}
-test regexp-21.1 {regsub works with empty string} {
+test regexp-21.1 {regsub works with empty string} -body {
regsub -- ^ {} foo
-} {foo}
-test regexp-21.2 {regsub works with empty string} {
+} -result {foo}
+test regexp-21.2 {regsub works with empty string} -body {
regsub -- \$ {} foo
-} {foo}
-test regexp-21.3 {regsub works with empty string offset} {
+} -result {foo}
+test regexp-21.3 {regsub works with empty string offset} -body {
regsub -start 0 -- ^ {} foo
-} {foo}
-test regexp-21.4 {regsub works with empty string offset} {
+} -result {foo}
+test regexp-21.4 {regsub works with empty string offset} -body {
regsub -start 0 -- \$ {} foo
-} {foo}
-test regexp-21.5 {regsub works with empty string offset} {
+} -result {foo}
+test regexp-21.5 {regsub works with empty string offset} -body {
regsub -start 3 -- \$ {123} foo
-} {123foo}
-test regexp-21.6 {regexp works with empty string} {
+} -result {123foo}
+test regexp-21.6 {regexp works with empty string} -body {
regexp -- ^ {}
-} {1}
-test regexp-21.7 {regexp works with empty string} {
+} -result {1}
+test regexp-21.7 {regexp works with empty string} -body {
regexp -start 0 -- ^ {}
-} {1}
-test regexp-21.8 {regexp works with empty string offset} {
+} -result {1}
+test regexp-21.8 {regexp works with empty string offset} -body {
regexp -start 3 -- ^ {123}
-} {0}
-test regexp-21.9 {regexp works with empty string offset} {
+} -result {0}
+test regexp-21.9 {regexp works with empty string offset} -body {
regexp -start 3 -- \$ {123}
-} {1}
+} -result {1}
test regexp-21.10 {multiple matches handle newlines} {
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"
@@ -1093,13 +1107,13 @@ test regexp-26.1 {matches start of line 1 time} {
test regexp-26.2 {matches start of line(s) 2 times} {
regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
-test regexp-26.3 {effect of -line -all and -start} {
+test regexp-26.3 {effect of -line -all and -start} -body {
list \
[regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \
-} {{aa aaa} aaa aaa aaa}
+} -result {{aa aaa} aaa aaa aaa}
# No regexp-26.4
test regexp-26.5 {match length 0, match length 1} {
regexp -all -inline -line -- {^b*} "a\nb"
@@ -1134,6 +1148,57 @@ test regexp-26.12 {regexp with -line option} {
test regexp-26.13 {regexp without -line option} {
regexp -all -inline -- {a*} "b\n"
} {{} {}}
+
+test regexp-27.1 {regsub -command} {
+ regsub -command {.x.} {abcxdef} {string length}
+} ab3ef
+test regexp-27.2 {regsub -command} {
+ regsub -command {.x.} {abcxdefxghi} {string length}
+} ab3efxghi
+test regexp-27.3 {regsub -command} {
+ set x 0
+ regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}}
+} 1a2b3c4d5e
+test regexp-27.4 {regsub -command} -body {
+ regsub -command {.x.} {abcxdef} error
+} -returnCodes error -result cxd
+test regexp-27.5 {regsub -command} {
+ regsub -command {(.)(.)} {abcdef} {list ,}
+} {, ab a bcdef}
+test regexp-27.6 {regsub -command} {
+ regsub -command -all {(.)(.)} {abcdef} {list ,}
+} {, ab a b, cd c d, ef e f}
+test regexp-27.7 {regsub -command representation smash} {
+ set ::s {123=456 789}
+ regsub -command -all {\d+} $::s {apply {n {
+ expr {[llength $::s] + $n}
+ }}}
+} {125=458 791}
+test regexp-27.8 {regsub -command representation smash} {
+ set ::t {apply {n {
+ expr {[llength [lindex $::t 1 1 1]] + $n}
+ }}}
+ regsub -command -all {\d+} "123=456 789" $::t
+} {131=464 797}
+test regexp-27.9 {regsub -command memory leak testing} memory {
+ set ::s "123=456 789"
+ set ::t {apply {n {
+ expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n}
+ }}}
+ memtest {
+ regsub -command -all {\d+} $::s $::t
+ }
+} 0
+test regexp-27.10 {regsub -command error cases} -returnCodes error -body {
+ regsub -command . abc "def \{ghi"
+} -result {unmatched open brace in list}
+test regexp-27.11 {regsub -command error cases} -returnCodes error -body {
+ regsub -command . abc {}
+} -result {command prefix must be a list of at least one element}
+test regexp-27.12 {regsub -command representation smash} {
+ set s {list (.+)}
+ regsub -command $s {list list} $s
+} {(.+) {list list} list}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index 926d9ef..42f1b3b 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1998 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1998 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+source [file join [file dirname [info script]] tcltests.tcl]
+
# Procedure to evaluate a script within a proc, to test compilation
# functionality
@@ -62,8 +64,8 @@ test regexpComp-1.6 {basic regexp operation} {
test regexpComp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
evalInProc {
- set foo "\u4e4eb q"
- regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
+ set foo "乎b q"
+ regexp "乎b q" "a乎b qw幎N wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
@@ -447,8 +449,8 @@ test regexpComp-7.16 {basic regsub operation} {
test regexpComp-7.17 {regsub utf compliance} {
evalInProc {
# if not UTF-8 aware, result is "0 1"
- set foo "xyz555ijka\u4e4ebpqr"
- regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
+ set foo "xyz555ijka乎bpqr"
+ regsub a乎b xyza乎bijka乎bpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
@@ -587,7 +589,7 @@ test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
-} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
@@ -665,54 +667,54 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache}
removeFile junk.tcl
} -result 1
-test regexpComp-15.1 {regexp -start} {
+test regexpComp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
-} {1 1}
-test regexpComp-15.2 {regexp -start} {
+} -result {1 1}
+test regexpComp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
-} {1 2}
-test regexpComp-15.3 {regexp -start} {
+} -result {1 2}
+test regexpComp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
-} {1 2}
-test regexpComp-15.4 {regexp -start} {
+} -result {1 2}
+test regexpComp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
-} {1 3}
-test regexpComp-15.5 {regexp -start, over end of string} {
+} -result {1 3}
+test regexpComp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
-} {0 0}
-test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
+} -result {0 0}
+test regexpComp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
-} {0}
+} -result {0}
-test regexpComp-16.1 {regsub -start} {
+test regexpComp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
-} {4 a1b/2c/3d/4e/5}
-test regexpComp-16.2 {regsub -start} {
+} -result {4 a1b/2c/3d/4e/5}
+test regexpComp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
-} {0 hello}
-test regexpComp-16.3 {regsub -start} {
+} -result {0 hello}
+test regexpComp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
-} {0 hello}
-test regexpComp-16.4 {regsub -start, \A behavior} {
+} -result {0 hello}
+test regexpComp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
-} {5 /a/b/c/d/e 3 ab/c/d/e}
+} -result {5 /a/b/c/d/e 3 ab/c/d/e}
-test regexpComp-17.1 {regexp -inline} {
+test regexpComp-17.1 {regexp -inline} -body {
regexp -inline b ababa
-} {b}
-test regexpComp-17.2 {regexp -inline} {
+} -result {b}
+test regexpComp-17.2 {regexp -inline} -body {
regexp -inline (b) ababa
-} {b b}
+} -result {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
@@ -791,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} {
}
} "\0a\0hel\0a\0lo\0a\0 14"
-test regexpComp-20.1 {regsub shared object shimmering} {
+test regexpComp-20.1 {regsub shared object shimmering} deprecated {
evalInProc {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
diff --git a/tests/registry.test b/tests/registry.test
index 53e48fe..2f1fd8c 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -7,8 +7,8 @@
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc. All rights reserved.
+# Copyright © 1998-1999 Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
@@ -19,11 +19,12 @@ testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::regver [package require registry 1.3.5]
+ set ::regver [package require registry 1.3.7]
}]} {
testConstraint reg 1
}
}
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# determine the current locale
testConstraint english [expr {
@@ -33,7 +34,7 @@ testConstraint english [expr {
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
-} {1.3.5}
+} {1.3.7}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
@@ -673,10 +674,10 @@ test registry-12.2 {BroadcastValue} -constraints {win reg} -body {
test registry-12.3 {BroadcastValue} -constraints {win reg} -body {
registry broadcast "" - 500
} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\""
-test registry-12.4 {BroadcastValue} -constraints {win reg} -body {
+test registry-12.4 {BroadcastValue} -constraints {win reg notWine} -body {
registry broadcast {Environment}
} -result {1 0}
-test registry-12.5 {BroadcastValue} -constraints {win reg} -body {
+test registry-12.5 {BroadcastValue} -constraints {win reg notWine} -body {
registry b {}
} -result {1 0}
diff --git a/tests/remote.tcl b/tests/remote.tcl
index 2b975c6..eee551a 100644
--- a/tests/remote.tcl
+++ b/tests/remote.tcl
@@ -4,7 +4,7 @@
#
# Source this file in the remote server you are using to test Tcl against.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/rename.test b/tests/rename.test
index ddda909..9b8f9a0 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
diff --git a/tests/resolver.test b/tests/resolver.test
index 88eae99..ea84956 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -4,8 +4,8 @@
# in the reusing context. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
-# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
+# Copyright © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
+# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testinterpresolver [llength [info commands testinterpresolver]]
diff --git a/tests/result.test b/tests/result.test
index 6e51e4e..5ae29b2 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Some tests require the testsaveresult command
@@ -33,7 +33,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 0
-} {dynamic result notCalled present}
+} {dynamic result presentOrFreed}
test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 0
} {object result same}
@@ -45,7 +45,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} {
} {42}
test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 1
-} {42 called missing}
+} {42 presentOrFreed}
test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 1
} {42 different}
@@ -109,14 +109,14 @@ test result-6.0 {Bug 1209759} -constraints testreturn -body {
# Might panic if bug is not fixed.
proc foo {} {testreturn}
foo
-} -returnCodes ok -result {}
+} -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 {}
-} -returnCodes ok -result {}
+} -result {}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
if {[catch {
diff --git a/tests/safe-stock.test b/tests/safe-stock.test
index 0bab25d..24e90a0 100644
--- a/tests/safe-stock.test
+++ b/tests/safe-stock.test
@@ -1,9 +1,9 @@
# safe-stock.test --
#
# This file contains tests for safe Tcl that were previously in the file
-# safe.test, and use files and packages of stock Tcl 8.6 to perform the tests.
-# These files may be changed or disappear in future revisions of Tcl,
-# for example package http 1.0 will be removed from Tcl 8.7.
+# safe.test, and use files and packages of stock Tcl 8.7 to perform the tests.
+# These files may be changed or disappear in future revisions of Tcl, for
+# example package opt will eventually be removed.
#
# The tests are replaced in safe.tcl with tests that use files provided in the
# tests directory. Test numbering is for comparison with similar tests in
@@ -12,8 +12,18 @@
# Sourcing this file into tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# The defunct package http 1.0 was convenient for testing package loading.
+# - This file, safe-stock.test, uses packages opt and (from cookiejar)
+# tcl::idna to provide alternative tests based on stock Tcl packages.
+# - These are tests 7.1 7.2 7.4 9.11 9.13
+# - Tests 7.[124], 9.1[13] use "package require opt".
+# - Tests 9.1[13] also use "package require tcl::idna".
+# - The corresponding tests in safe.test use example packages provided in
+# subdirectory auto0 of the tests directory, which are independent of any
+# changes made to the packages provided with Tcl.
+#
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -27,10 +37,50 @@ foreach i [interp children] {
interp delete $i
}
+# When using package opt for testing positive/negative package search:
+# - The directory location and the error message depend on whether
+# and how the package is installed.
+
+# Error message for test 7.2 for "package require opt".
+if {[string match *zipfs:/* [info library]]} {
+ # pkgIndex.tcl is in [info library]
+ # file to be sourced is in [info library]/opt*
+ set pkgOptErrMsg {permission denied}
+} else {
+ # pkgIndex.tcl and file to be sourced are
+ # both in [info library]/opt*
+ set pkgOptErrMsg {can't find package opt}
+}
+
+# Directory of opt for tests 7.4, 9.10, 9.12 for "package require opt".
+if {[file exists [file join [info library] opt0.4]]} {
+ # Installed files in lib8.7/opt0.4
+ set pkgOptDir opt0.4
+} elseif {[file exists [file join [info library] opt]]} {
+ # Installed files in zipfs, or source files used by "make test"
+ set pkgOptDir opt
+} else {
+ error {cannot find opt library}
+}
+
+# Directory of cookiejar for tests 9.10, 9.12 for "package require tcl::idna".
+if {[file exists [file join [info library] cookiejar0.2]]} {
+ # Installed files in lib8.7/cookiejar0.2
+ set pkgJarDir cookiejar0.2
+} elseif {[file exists [file join [info library] cookiejar]]} {
+ # Installed files in zipfs, or source files used by "make test"
+ set pkgJarDir cookiejar
+} else {
+ error {cannot find cookiejar library}
+}
+
set SaveAutoPath $::auto_path
set ::auto_path [info library]
set TestsDir [file normalize [file dirname [info script]]]
-set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR]
+set PathMapp {}
+lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR
+lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR
+lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR
proc mapList {map listIn} {
set listOut {}
@@ -39,55 +89,125 @@ proc mapList {map listIn} {
}
return $listOut
}
+proc mapAndSortList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ lsort $listOut
+}
# Force actual loading of the safe package because we use unexported (and
# thus unautoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
+testConstraint AutoSyncDefined 1
+
# high level general test
-test safe-stock-7.1 {tests that everything works at high level, uses http 2} -body {
+test safe-stock-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set i [safe::interpCreate]
+} -body {
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a child works like in the parent)
- set v [interp eval $i {package require http 2}]
+ set v [interp eval $i {package require opt}]
# no error shall occur:
- interp eval $i {http::config}
- safe::interpDelete $i
+ interp eval $i {::tcl::Lempty {a list}}
set v
-} -match glob -result 2.*
-test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body {
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result 0.4.*
+test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
+} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
- # should add as p1
+ # should add as p* (not p1 if parent has a module path)
set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ # an error shall occur (opt is not anymore in the secure 0-level
+ # provided deep path)
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
- # an error shall occur (http is not anymore in the secure 0-level
- # provided deep path)
list $token1 $token2 -- \
- [catch {interp eval $i {package require http 1}} msg] $msg -- \
+ [catch {interp eval $i {package require opt}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
-} -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\
- {TCLLIB */dummy/unixlike/test/path} -- {}}
-test safe-stock-7.4 {tests specific path and positive search, uses http1.0} -body {
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\
+ {TCLLIB */dummy/unixlike/test/path} -- {}"
+test safe-stock-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
+} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
set token1 [safe::interpAddToAccessPath $i [info library]]
- # should add as p1
- set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
- # this time, unlike test safe-stock-7.2, http should be found
+ # this time, unlike test safe-stock-7.2, opt should be found
list $token1 $token2 -- \
- [catch {interp eval $i {package require http 1}} msg] $msg -- \
- $mappA -- [safe::interpDelete $i]
-} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}}
+ [catch {interp eval $i {package require opt}} msg] $msg -- \
+ $mappA -- [safe::interpDelete $i]
+ # Note that the glob match elides directories (those from the module path)
+ # other than the first and last in the access path.
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\
+ {TCLLIB * TCLLIB/OPTDIR} -- {}}
+test safe-stock-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set i [safe::interpCreate]
+ interp eval $i {
+ package forget platform::shell
+ package forget platform
+ catch {namespace delete ::platform}
+ }
+} -body {
+ # Should raise an error (module ancestor directory issue)
+ set code1 [catch {interp eval $i {package require shell}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require platform::shell}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {1 {can't find package shell} 0}
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading. It was previously test "safe-5.1".
-test safe-stock-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup {
+test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup {
catch {safe::interpDelete a}
safe::interpCreate a
} -body {
@@ -95,11 +215,226 @@ test safe-stock-9.8 {test auto-loading in safe interpreters, was test 5.1} -setu
} -cleanup {
safe::interpDelete a
} -result -1
+test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $tcl_library $pkgOptDir] \
+ [file join $tcl_library $pkgJarDir]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $tcl_library $pkgJarDir] \
+ [file join $tcl_library $pkgOptDir]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require tcl::idna}} msg3]
+ set code4 [catch {interp eval $i {package require opt}} msg4]
+ set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5]
+ set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\
+ {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\
+ {TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\
+ 0 0 0 example.com}
+test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $tcl_library $pkgOptDir] \
+ [file join $tcl_library $pkgJarDir]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library]
+
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4]
+ set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5]
+
+ # Try to load the packages.
+ set code3 [catch {interp eval $i {package require opt}} msg3]
+ set code6 [catch {interp eval $i {package require tcl::idna}} msg6]
+
+ list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
+ $mappA -- $mappB
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
+ 1 {* not found in access path} -- 1 1 --\
+ {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}}
+
+test safe-stock-18.1 {cf. safe-stock-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ # Without AutoPathSync, we need a more complete auto_path,
+ # because the child will use the same value.
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+ set ::auto_path $::auto_TMP
+} -body {
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs so
+ # package require in a child works like in the parent)
+ set v [interp eval $i {package require opt}]
+ # no error shall occur:
+ interp eval $i {::tcl::Lempty {a list}}
+ set v
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result 0.4.*
+test safe-stock-18.2 {cf. safe-stock-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ set auto1 [interp eval $i {set ::auto_path}]
+ # This will differ from the value -autoPath {}
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ # an error shall occur (opt is not anymore in the secure 0-level
+ # provided deep path)
+ list $auto1 $token1 $token2 \
+ [catch {interp eval $i {package require opt}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\
+ {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\
+ -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
+test safe-stock-18.4 {cf. safe-stock-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+
+ # should not have been set by Safe Base:
+ set auto1 [interp eval $i {set ::auto_path}]
+
+ # This will differ from the value -autoPath {}
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]]
+
+ # should not have been changed by Safe Base:
+ set auto2 [interp eval $i {set ::auto_path}]
+
+ # This time, unlike test safe-stock-18.2opt and the try above, opt should be found:
+ list $auto1 $auto2 $token1 $token2 \
+ [catch {interp eval $i {package require opt}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\
+ {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\
+ -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
+test safe-stock-18.5 {cf. safe-stock-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate]
+ interp eval $i {
+ package forget platform::shell
+ package forget platform
+ catch {namespace delete ::platform}
+ }
+} -body {
+ # Should raise an error (tests module ancestor directory rule)
+ set code1 [catch {interp eval $i {package require shell}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require platform::shell}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {1 {can't find package shell} 0}
set ::auto_path $SaveAutoPath
-unset SaveAutoPath TestsDir PathMapp
+unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp
rename mapList {}
-
+rename mapAndSortList {}
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test
new file mode 100644
index 0000000..52ec6c4
--- /dev/null
+++ b/tests/safe-zipfs.test
@@ -0,0 +1,837 @@
+# safe-zipfs.test --
+#
+# This file contains tests for safe Tcl that test its compatibility with the
+# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison
+# with similar tests in safe.test that do not use the zipfs file system.
+#
+# Sourcing this file into tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
+
+
+apply [list {} {
+ global auto_path
+ global tcl_library
+ if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+ }
+
+ foreach i [interp children] {
+ interp delete $i
+ }
+
+ set SaveAutoPath $::auto_path
+ set ::auto_path [info library]
+ set TestsDir [file normalize [file dirname [info script]]]
+
+ set ZipMountPoint [zipfs root]auto-files
+ zipfs mount [file join $TestsDir auto-files.zip] $ZipMountPoint
+
+ set PathMapp {}
+ lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR
+
+ proc mapList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ return $listOut
+ }
+ proc mapAndSortList {map listIn} {
+ set listOut {}
+ foreach element $listIn {
+ lappend listOut [string map $map $element]
+ }
+ lsort $listOut
+ }
+
+ # Force actual loading of the safe package because we use un-exported (and
+ # thus un-autoindexed) APIs in this test result arguments:
+ catch {safe::interpConfigure}
+
+ testConstraint AutoSyncDefined 1
+
+ # Tests 5.* test the example files before using them to test safe interpreters.
+
+ test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]
+ } -body {
+ # Try to load the commands.
+ set code3 [catch report1 msg3]
+ set code4 [catch report2 msg4]
+ list $code3 $msg3 $code4 $msg4
+ } -cleanup {
+ catch {rename report1 {}}
+ catch {rename report2 {}}
+ set ::auto_path $tmpAutoPath
+ auto_reset
+ } -match glob -result {0 ok1 0 ok2}
+ test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $ZipMountPoint auto0]
+ } -body {
+ # Try to load the commands.
+ set code3 [catch report1 msg3]
+ set code4 [catch report2 msg4]
+ list $code3 $msg3 $code4 $msg4
+ } -cleanup {
+ catch {rename report1 {}}
+ catch {rename report2 {}}
+ set ::auto_path $tmpAutoPath
+ auto_reset
+ } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}}
+ test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $ZipMountPoint auto0]
+ } -body {
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {package require SafeTestPackage1} msg3]
+ set code4 [catch {package require SafeTestPackage2} msg4]
+ set code5 [catch HeresPackage1 msg5]
+ set code6 [catch HeresPackage2 msg6]
+ list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
+ } -cleanup {
+ set ::auto_path $tmpAutoPath
+ catch {package forget SafeTestPackage1}
+ catch {package forget SafeTestPackage2}
+ catch {rename HeresPackage1 {}}
+ catch {rename HeresPackage2 {}}
+ } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
+ test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup {
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]
+ } -body {
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {package require SafeTestPackage1} msg3]
+ set code4 [catch {package require SafeTestPackage2} msg4]
+ set code5 [catch HeresPackage1 msg5]
+ set code6 [catch HeresPackage2 msg6]
+ list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6
+ } -cleanup {
+ set ::auto_path $tmpAutoPath
+ catch {package forget SafeTestPackage1}
+ catch {package forget SafeTestPackage2}
+ catch {rename HeresPackage1 {}}
+ catch {rename HeresPackage2 {}}
+ } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2}
+ test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup {
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ # Try to load the modules and run a command from each one.
+ set code0 [catch {package require test0} msg0]
+ set code1 [catch {package require mod1::test1} msg1]
+ set code2 [catch {package require mod2::test2} msg2]
+ set out0 [test0::try0]
+ set out1 [mod1::test1::try1]
+ set out2 [mod2::test2::try2]
+ list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ catch {package forget test0}
+ catch {package forget mod1::test1}
+ catch {package forget mod2::test2}
+ catch {namespace delete ::test0}
+ catch {namespace delete ::mod1}
+ } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
+ test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup {
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ # Try to load the modules and run a command from each one.
+ set code0 [catch {package require test0} msg0]
+ set code1 [catch {package require mod1::test1} msg1]
+ set code2 [catch {package require mod2::test2} msg2]
+ set out0 [test0::try0]
+ set out1 [mod1::test1::try1]
+ set out2 [mod2::test2::try2]
+ list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ catch {package forget test0}
+ catch {package forget mod1::test1}
+ catch {package forget mod2::test2}
+ catch {namespace delete ::test0}
+ catch {namespace delete ::mod1}
+ } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
+
+ # high level general test
+ # Use zipped example packages not http1.0 etc
+ test safe-zipfs-7.1 {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set tmpAutoPath $::auto_path
+ lappend ::auto_path [file join $ZipMountPoint auto0]
+ set i [safe::interpCreate]
+ set ::auto_path $tmpAutoPath
+ } -body {
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs so
+ # package require in a child works like in the parent)
+ set v [interp eval $i {package require SafeTestPackage1}]
+ # no error shall occur:
+ interp eval $i {HeresPackage1}
+ set v
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result 1.2.3
+ test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
+ } -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ # should add as p* (not p2 if parent has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
+ # provided deep path)
+ list $token1 $token2 $token3 -- [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- $mappA -- [safe::interpDelete $i]
+ } -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} -- 1 {can't find package SafeTestPackage1} -- {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}}
+ test safe-zipfs-7.4 {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
+ } -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found
+ list $token1 $token2 -- [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- $mappA -- [safe::interpDelete $i]
+ # Note that the glob match elides directories (those from the module path)
+ # other than the first and last in the access path.
+ } -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 -- {TCLLIB * ZIPDIR/auto0/auto1} -- {}}
+
+ test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset) with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Load and run the commands.
+ # This guarantees the test will pass even if the tokens are swapped.
+ set code1 [catch {interp eval $i {report1}} msg1]
+ set code2 [catch {interp eval $i {report2}} msg2]
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}}
+ test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset) with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Do not load the commands. With the tokens swapped, the test
+ # will pass only if the Safe Base has called auto_reset.
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load and run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}}
+ test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ } -body {
+ # For complete correspondence to safe-stock-9.11, include auto0 in access path.
+ set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0] [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
+ # This would have no effect because the records in Pkg of these directories
+ # were from access as children of {$p(:1:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0] [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 -- {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} -- 0 OK1 0 OK2}
+ test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0 with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto2] [file join $ZipMountPoint auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB -- $code5 $msg5 $code6 $msg6
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.2.3 0 2.3.4 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} -- 0 OK1 0 OK2}
+ test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library]
+
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4]
+ set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5]
+
+ # Try to load the packages.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
+ set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
+
+ list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- $mappA -- $mappB
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} -- 1 {* not found in access path} -- 1 1 -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}}
+ test safe-zipfs-9.20 {check module loading, with conventional AutoPathSync; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
+ # - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in
+ # tokenized form to the child's access path, and then adds all the
+ # descendants, discovered recursively by using glob.
+ # - The order of the directories in the list returned by glob is system-dependent,
+ # and therefore this is true also for (a) the order of token assignment to
+ # descendants of the [tcl::tm::list] roots; and (b) the order of those same
+ # directories in the access path. Both those things must be sorted before
+ # comparing with expected results. The test is therefore not totally strict,
+ # but will notice missing or surplus directories.
+ test safe-zipfs-9.21 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 1; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Load pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
+ # See comments on lsort after test safe-zipfs-9.20.
+ test safe-zipfs-9.22 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 0; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
+ # See comments on lsort after test safe-zipfs-9.20.
+ test safe-zipfs-9.23 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 3; zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Refresh stale pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
+ # See comments on lsort after test safe-zipfs-9.20.
+ test safe-zipfs-9.24 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 2 (worst case); zipfs} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $ZipMountPoint auto0 modules]
+ } -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- [lsort [list $path3 $path4 $path5]] -- $modsB -- $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- $out0 $out1 $out2
+ } -cleanup {
+ tcl::tm::path remove [file join $ZipMountPoint auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} -- {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} -- 0 0.5 0 1.0 0 2.0 -- {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} -- res0 res1 res2}
+ # See comments on lsort after test safe-zipfs-9.20.
+
+ test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ # Without AutoPathSync, we need a more complete auto_path,
+ # because the child will use the same value.
+ set lib1 [info library]
+ set lib2 [file join $ZipMountPoint auto0]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+ set ::auto_path $::auto_TMP
+ } -body {
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs so
+ # package require in a child works like in the parent)
+ set v [interp eval $i {package require SafeTestPackage1}]
+ # no error shall occur:
+ interp eval $i HeresPackage1
+ set v
+ } -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result 1.2.3
+ test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ } -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ set auto1 [interp eval $i {set ::auto_path}]
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ # should add as p* (not p2 if parent has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
+ # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
+ # provided deep path)
+ list $auto1 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i]
+ } -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1 {can't find package SafeTestPackage1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path $ZipMountPoint/auto0]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
+ test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ } -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+
+ # should not have been set by Safe Base:
+ set auto1 [interp eval $i {set ::auto_path}]
+
+ # This will differ from the value -autoPath {}
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]]
+
+ # should add as p* (not p2 if parent has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]]
+
+ # should not have been changed by Safe Base:
+ set auto2 [interp eval $i {set ::auto_path}]
+
+ # This will differ from the value -autoPath {}
+ set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]]
+
+ # This time, unlike test safe-zipfs-18.2 and the try above, SafeTestPackage1 should be found:
+ list $auto1 $auto2 $token1 $token2 $token3 [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg [safe::interpConfigure $i] [safe::interpDelete $i]
+ } -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+ } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3 {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
+
+ # cleanup
+ set ::auto_path $SaveAutoPath
+ zipfs unmount ${ZipMountPoint}
+ unset SaveAutoPath TestsDir ZipMountPoint PathMapp
+ rename mapList {}
+ rename mapAndSortList {}
+ ::tcltest::cleanupTests
+ return
+} [namespace current]]
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/safe.test b/tests/safe.test
index 632a959..0a888f4 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -4,19 +4,18 @@
# using safe interpreters. Sourcing this file into tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# The package http 1.0 is convenient for testing package loading, but will soon
-# be removed.
-# - Tests that use http are replaced here with tests that use example packages
+# The defunct package http 1.0 was convenient for testing package loading.
+# - Tests that used http are replaced here with tests that use example packages
# provided in subdirectory auto0 of the tests directory, which are independent
# of any changes made to the packages provided with Tcl itself.
-# - These are tests 7.1 7.2 7.4 9.11 9.13
+# - These are tests 7.1 7.2 7.4 9.11 9.13 17.1 17.2 17.4
# - Tests 5.* test the example packages themselves before they
# are used to test Safe Base interpreters.
-# - Alternative tests using stock packages of Tcl 8.6 are in file
+# - Alternative tests using stock packages of Tcl 8.7 are in file
# safe-stock.test.
#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -25,6 +24,8 @@ 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]]
foreach i [interp children] {
interp delete $i
@@ -35,6 +36,11 @@ set ::auto_path [info library]
set TestsDir [file normalize [file dirname [info script]]]
set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR]
+proc getAutoPath {child} {
+ set ap1 [lrange [lindex [safe::interpConfigure $child -autoPath] 1] 0 end]
+ set ap2 [::safe::DetokPath $child [interp eval $child set ::auto_path]]
+ list $ap1 -- $ap2
+}
proc mapList {map listIn} {
set listOut {}
foreach element $listIn {
@@ -55,31 +61,74 @@ proc mapAndSortList {map listIn} {
catch {safe::interpConfigure}
# testing that nested and statics do what is advertised (we use a static
-# package - Tcltest - but it might be absent if we're in standard tclsh)
+# package - tcl::test - but it might be absent if we're in standard tclsh)
-testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}]
+testConstraint tcl::test [expr {![catch {package require tcl::test}]}]
+testConstraint AutoSyncDefined 1
+### 1. Basic help/error messages.
+
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
-} -result {no value given for parameter "slave" (use -help for full usage) :
- slave name () name of the slave}
-test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
+} -result {no value given for parameter "child" (use -help for full usage) :
+ child name () name of the child}
+test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
+} -body {
safe::interpCreate -help
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
(-help gives this help)
- ?slave? name () name of the slave (optional)
- -accessPath list () access path for the slave
+ ?child? name () name of the child (optional)
+ -accessPath list () access path for the child
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook}
+test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ safe::interpCreate -help
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {Usage information:
+ Var/FlagName Type Value Help
+ ------------ ---- ----- ----
+ (-help gives this help)
+ ?child? name () name of the child (optional)
+ -accessPath list () access path for the child
+ -noStatics boolflag (false) prevent loading of statically linked pkgs
+ -statics boolean (true) loading of statically linked pkgs
+ -nestedLoadOk boolflag (false) allow nested loading
+ -nested boolean (false) nested loading
+ -deleteHook script () delete hook
+ -autoPath list () ::auto_path for the child}
test safe-1.3 {safe::interpInit syntax} -returnCodes error -body {
safe::interpInit -noStatics
} -result {bad value "-noStatics" for parameter
- slave name () name of the slave}
+ child name () name of the child}
+
+### 2. Aliases in a new "interp create" interpreter.
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
# Disabled this test. It tests nothing sensible. [Bug 999612]
@@ -102,7 +151,10 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s
lsort [a aliases]
} -cleanup {
interp delete a
-} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock}
+} -result {clock}
+
+### 3. Simple use of interpCreate, interpInit.
+### Aliases in a new "interpCreate/interpInit" interpreter.
test safe-3.1 {calling safe::interpInit is safe} -setup {
catch {safe::interpDelete a}
@@ -120,7 +172,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
lsort [a aliases]
} -cleanup {
safe::interpDelete a
-} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source}
+} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
@@ -138,6 +190,8 @@ test safe-3.4 {calling safe::interpCreate on trusted interp} -setup {
safe::interpDelete a
} -result {}
+### 4. Testing safe::interpDelete, double interpCreate.
+
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
@@ -170,9 +224,9 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup {
a eval exit
} -result ""
-# The old test "safe-5.1" has been moved to "safe-stock-9.8".
-# A replacement test using example files is "safe-9.8".
-# Tests 5.* test the example files before using them to test safe interpreters.
+### 5. Test the example files before using them to test safe interpreters.
+### The old test "safe-5.1" has been moved to "safe-stock-9.8".
+### A replacement test using example files is "safe-9.8".
unset -nocomplain path
@@ -285,7 +339,8 @@ test safe-5.6 {example modules packages, test in parent interpreter, append to p
catch {namespace delete ::mod1}
} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2}
-# test safe interps 'information leak'
+### 6. Test safe interps 'information leak'.
+
proc SafeEval {script} {
# Helper procedure that ensures the safe interp is cleaned up even if
# there is a failure in the script.
@@ -315,9 +370,16 @@ rename SafeEval {}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
-# high level general test
-# Use example packages not http1.0 etc
-test safe-7.1 {tests that everything works at high level} -setup {
+### 7. Test the use of ::auto_path for loading commands (via tclIndex files)
+### and non-module packages (via pkgIndex.tcl files).
+### Corresponding tests with Sync Mode off are 17.*
+
+test safe-7.1 {positive non-module package require, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set tmpAutoPath $::auto_path
lappend ::auto_path [file join $TestsDir auto0]
set i [safe::interpCreate]
@@ -332,8 +394,18 @@ test safe-7.1 {tests that everything works at high level} -setup {
set v
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result 1.2.3
-test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup {
+test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
@@ -344,12 +416,14 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup {
set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
set confA [safe::interpConfigure $i]
set mappA [mapList $PathMapp [dict get $confA -accessPath]]
- # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level
- # provided deep path)
+ # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
list $token1 $token2 $token3 -- \
[catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \
$mappA -- [safe::interpDelete $i]
} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\
1 {can't find package SafeTestPackage1} --\
{TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}}
@@ -384,7 +458,14 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set
[safe::interpDelete $i] \
[interp exists $j] [info vars ::safe::S*]
} -match glob -result {{} {} ok ok {} 0 {}}
-test safe-7.4 {tests specific path and positive search} -setup {
+test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ } else {
+ set SyncVal_TMP 1
+ }
} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
@@ -400,10 +481,39 @@ test safe-7.4 {tests specific path and positive search} -setup {
# Note that the glob match elides directories (those from the module path)
# other than the first and last in the access path.
} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\
{TCLLIB * TESTSDIR/auto0/auto1} -- {}}
+test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+ set i [safe::interpCreate]
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ interp eval $i {
+ package forget mod1::test1
+ catch {namespace delete ::mod1}
+ }
+} -body {
+ # Should raise an error (module ancestor directory issue)
+ set code1 [catch {interp eval $i {package require test1}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require mod1::test1}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {1 {can't find package test1} 0}
+
+### 8. Test source control on file name.
-# test source control on file name
test safe-8.1 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -439,7 +549,7 @@ test safe-8.3 {safe source control on file} -setup {
safe::interpDelete $i
rename safe-test-log {}
unset i log
-} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
+} -result {1 {permission denied} {{ERROR for child a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -455,7 +565,7 @@ test safe-8.4 {safe source control on file} -setup {
safe::interpDelete $i
rename safe-test-log {}
unset i log
-} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
+} -result {1 {permission denied} {{ERROR for child a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -475,7 +585,7 @@ test safe-8.5 {safe source control on file} -setup {
safe::interpDelete $i
rename safe-test-log {}
unset i log
-} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
+} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -493,7 +603,7 @@ test safe-8.6 {safe source control on file} -setup {
safe::interpDelete $i
rename safe-test-log {}
unset i log
-} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
+} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -513,7 +623,7 @@ test safe-8.7 {safe source control on file} -setup {
safe::interpDelete $i
rename safe-test-log {}
unset i log
-} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
+} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} emptyTest {
# Disabled this test. It was only useful for long unsupported
# Mac OS 9 systems. [Bug 860a9f1945]
@@ -548,6 +658,9 @@ test safe-8.10 {safe source and return} -setup {
unset i
} -result ok
+### 9. Assorted options, including changes to option values.
+### If Sync Mode is on, a corresponding test with Sync Mode off is 19.*
+
test safe-9.1 {safe interps' deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
@@ -591,7 +704,7 @@ test safe-9.2 {safe interps' error in deleteHook} -setup {
catch {rename testDelHook {}}
rename safe-test-log {}
unset i log res
-} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}}
+} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}}
test safe-9.3 {dual specification of statics} -returnCodes error -body {
safe::interpCreate -stat true -nostat
} -result {conflicting values given for -statics and -noStatics}
@@ -650,7 +763,12 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body {
{-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\
{-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\
{-accessPath * -statics 0 -nested 0 -deleteHook toto}}
-test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup {
+test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
@@ -668,9 +786,17 @@ test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup {
list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}}
-test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup {
+test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
@@ -706,10 +832,18 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
-test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup {
+test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
@@ -743,11 +877,19 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe
list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 ok1 0 ok2 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}}
-test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup {
+test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
# For complete correspondence to safe-9.10opt, include auto0 in access path.
set i [safe::interpCreate -accessPath [list $tcl_library \
@@ -787,11 +929,19 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un
$mappA -- $mappB -- $code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
0 OK1 0 OK2}
-test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup {
+test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
@@ -826,12 +976,20 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un
$code5 $msg5 $code6 $msg6
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
0 1.2.3 0 2.3.4 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
{TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
0 OK1 0 OK2}
-test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup {
+test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
} -body {
set i [safe::interpCreate -accessPath [list $tcl_library \
[file join $TestsDir auto0 auto1] \
@@ -862,10 +1020,18 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa
$mappA -- $mappB
} -cleanup {
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\
1 {* not found in access path} -- 1 1 --\
{TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}}
-test safe-9.20 {check module loading} -setup {
+test safe-9.20 {check module loading, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
@@ -898,6 +1064,9 @@ test safe-9.20 {check module loading} -setup {
tcl::tm::path add $path
}
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
0 0.5 0 1.0 0 2.0 --\
{TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
@@ -911,7 +1080,12 @@ test safe-9.20 {check module loading} -setup {
# directories in the access path. Both those things must be sorted before
# comparing with expected results. The test is therefore not totally strict,
# but will notice missing or surplus directories.
-test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup {
+test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
@@ -964,6 +1138,9 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st
tcl::tm::path add $path
}
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
@@ -973,7 +1150,12 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
-test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup {
+test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
@@ -1021,6 +1203,9 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st
tcl::tm::path add $path
}
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
@@ -1030,7 +1215,12 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
-test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup {
+test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
@@ -1088,6 +1278,9 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st
tcl::tm::path add $path
}
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
@@ -1097,7 +1290,12 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st
TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
res0 res1 res2}
# See comments on lsort after test safe-9.20.
-test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup {
+test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
set oldTm [tcl::tm::path list]
foreach path $oldTm {
tcl::tm::path remove $path
@@ -1150,6 +1348,9 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st
tcl::tm::path add $path
}
safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
{{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
0 0.5 0 1.0 0 2.0 --\
@@ -1160,58 +1361,62 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st
res0 res1 res2}
# See comments on lsort after test safe-9.20.
-catch {teststaticpkg Safepkg1 0 0}
-test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
+### 10. Test options -statics -nostatics -nested -nestedloadok
+
+catch {teststaticlibrary Safepfx1 0 0}
+test safe-10.1 {testing statics loading} -constraints tcl::test -setup {
set i [safe::interpCreate]
} -body {
- interp eval $i {load {} Safepkg1}
+ interp eval $i {load {} Safepfx1}
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
-test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
+} -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 {} Safepkg1}} m o
+ catch {interp eval $i {load {} Safepfx1}} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
-"load {} Safepkg1"
+"load {} Safepfx1"
invoked from within
-"interp eval $i {load {} Safepkg1}"}
-test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
+"interp eval $i {load {} Safepfx1}"}
+test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body {
set i [safe::interpCreate -nostatics]
- interp eval $i {load {} Safepkg1}
+ interp eval $i {load {} Safepfx1}
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {permission denied (static package)}
+} -result {permission denied (static library)}
test safe-10.3 {testing nested statics loading / no nested by default} -setup {
set i [safe::interpCreate]
-} -constraints TcltestPackage -body {
- interp eval $i {interp create x; load {} Safepkg1 x}
+} -constraints tcl::test -body {
+ interp eval $i {interp create x; load {} Safepfx1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {permission denied (nested load)}
-test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
+test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body {
set i [safe::interpCreate -nestedloadok]
- interp eval $i {interp create x; load {} Safepkg1 x}
+ interp eval $i {interp create x; load {} Safepfx1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
-test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
+} -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 {} Safepkg1 x}} m o
+ catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
invoked from within
-"load {} Safepkg1 x"
+"load {} Safepfx1 x"
invoked from within
-"interp eval $i {interp create x; load {} Safepkg1 x}"}
+"interp eval $i {interp create x; load {} Safepfx1 x}"}
+
+### 11. Safe encoding.
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
@@ -1219,14 +1424,14 @@ test safe-11.1 {testing safe encoding} -setup {
interp eval $i encoding
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {wrong # args: should be "encoding option ?arg ...?"}
+} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test safe-11.1a {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding foobar
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -match glob -result {bad option "foobar": must be *}
+} -match glob -result {unknown or ambiguous subcommand "foobar": must be *}
test safe-11.2 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
@@ -1268,21 +1473,19 @@ test safe-11.7 {testing safe encoding} -setup {
interp eval $i encoding convertfrom
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
+} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data"}
test safe-11.7.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i encoding convertfrom} m o
dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
+} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data"
while executing
"encoding convertfrom"
invoked from within
-"::interp invokehidden interp* encoding convertfrom"
- invoked from within
"encoding convertfrom"
invoked from within
"interp eval $i encoding convertfrom"}
@@ -1292,25 +1495,26 @@ test safe-11.8 {testing safe encoding} -setup {
interp eval $i encoding convertto
} -returnCodes error -cleanup {
safe::interpDelete $i
-} -result {wrong # args: should be "encoding convertto ?encoding? data"}
+} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data"}
test safe-11.8.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
catch {interp eval $i encoding convertto} m o
dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
unset -nocomplain m o
safe::interpDelete $i
-} -result {wrong # args: should be "encoding convertto ?encoding? data"
+} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data"
while executing
"encoding convertto"
invoked from within
-"::interp invokehidden interp* encoding convertto"
- invoked from within
"encoding convertto"
invoked from within
"interp eval $i encoding convertto"}
+### 12. Safe glob.
+### More tests of glob in sections 13, 16.
+
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
} -body {
@@ -1361,6 +1565,9 @@ test safe-12.7 {glob is restricted} -setup {
safe::interpDelete $i
} -result {permission denied}
+### 13. More tests for Safe base glob, with patches @ Bug 2964715
+### More tests of glob in sections 12, 16.
+
proc buildEnvironment {filename} {
upvar 1 testdir testdir testdir2 testdir2 testfile testfile
set testdir [makeDirectory deletethisdir]
@@ -1376,7 +1583,7 @@ proc buildEnvironment2 {filename} {
set testdir3 [makeDirectory deleteme $testdir]
set testfile2 [makeFile {} $filename $testdir3]
}
-#### New tests for Safe base glob, with patches @ Bug 2964715
+
test safe-13.1 {glob is restricted [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
@@ -1513,7 +1720,8 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p
rename buildEnvironment {}
rename buildEnvironment2 {}
-#### Test for the module path
+### 14. Sanity checks on paths - module path, access path, auto_path.
+
test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup {
set i [safe::interpCreate]
} -body {
@@ -1525,6 +1733,122 @@ test safe-14.1 {Check that module path is the same as in the parent interpreter
} -cleanup {
safe::interpDelete $i
} -result [::tcl::tm::path list]
+test safe-14.2 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+ return [list [lindex $accessList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [info library] [info library]]
+test safe-14.2.1 {Check that first element of child auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+ set autoList [lindex [safe::interpConfigure $i -autoPath] 1]
+ return [list [lindex $accessList 0] [lindex $autoList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [info library] [info library] [info library]]
+test safe-14.3 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib2 $lib1]
+ # Unexpected order, should be reversed in the child
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+
+ return [list [lindex $accessList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [info library] [info library]]
+test safe-14.3.1 {Check that first element of child auto_path (and access path) is Tcl Library, even if not true for parent, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+
+ set lib1 [info library]
+ set lib2 [file dirname $lib1]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib2 $lib1]
+ # Unexpected order, should be reversed in the child
+
+ set i [safe::interpCreate]
+} -body {
+ set autoList {}
+ set token [lindex [$i eval set ::auto_path] 0]
+ set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token]
+ set accessList [lindex [safe::interpConfigure $i -accessPath] 1]
+ set autoList [lindex [safe::interpConfigure $i -autoPath] 1]
+
+ return [list [lindex $accessList 0] [lindex $autoList 0] $auto0]
+} -cleanup {
+ set ::auto_path $::auto_TMP
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [info library] [info library] [info library]]
+
+### 15. Safe file ensemble.
test safe-15.1 {safe file ensemble does not surprise code} -setup {
set i [interp create -safe]
@@ -1563,7 +1887,10 @@ test safe-15.2 {safe file ensemble does not surprise code} -setup {
invoked from within
"interp eval $i {file isdirectory .}"}}
-### ~ should have no special meaning in paths in safe interpreters
+### 16. ~ should have no special meaning in paths in safe interpreters.
+### Defang it in glob.
+### More tests of glob in sections 12, 13.
+
test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
set savedHOME $env(HOME)
set env(HOME) /foo/bar
@@ -1657,10 +1984,1576 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup
safe::interpDelete $i
unset user
} -result {~USER}
+
+### 17. Test the use of ::auto_path for loading commands (via tclIndex files)
+### and non-module packages (via pkgIndex.tcl files).
+### Corresponding tests with Sync Mode on are 7.*
+
+test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ # Without AutoPathSync, we need a more complete auto_path,
+ # because the child will use the same value.
+ set lib1 [info library]
+ set lib2 [file join $TestsDir auto0]
+ set ::auto_TMP $::auto_path
+ set ::auto_path [list $lib1 $lib2]
+
+ set i [safe::interpCreate]
+ set ::auto_path $::auto_TMP
+} -body {
+ # no error shall occur:
+ # (because the default access_path shall include 1st level sub dirs so
+ # package require in a child works like in the parent)
+ set v [interp eval $i {package require SafeTestPackage1}]
+ # no error shall occur:
+ interp eval $i HeresPackage1
+ set v
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result 1.2.3
+test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+ # should not have been set by Safe Base:
+ set auto1 [interp eval $i {set ::auto_path}]
+ # This does not change the value of option -autoPath:
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"]
+ # should add as p* (not p2 if parent has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
+ # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory)
+ list $auto1 $token1 $token2 $token3 \
+ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\
+ 1 {can't find package SafeTestPackage1}\
+ {-accessPath {[list $tcl_library \
+ */dummy/unixlike/test/path \
+ $TestsDir/auto0]}\
+ -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}"
+# (not a counterpart of safe-7.3)
+test safe-17.3 {Check that default auto_path is the same as in the parent interpreter, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate]
+} -body {
+ # This file's header sets auto_path to a single directory [info library],
+ # which is the one required by Safe Base to be present & first in the list.
+ set ap {}
+ foreach token [$i eval set ::auto_path] {
+ lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token]
+ }
+ return [list $ap [lindex [::safe::interpConfigure $i -autoPath] 1]]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list $::auto_path $::auto_path]
+test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
+
+ # should not have been set by Safe Base:
+ set auto1 [interp eval $i {set ::auto_path}]
+
+ # This does not change the value of option -autoPath.
+ interp eval $i {set ::auto_path [list {$p(:0:)}]}
+
+ # should not add anything (p0)
+ set token1 [safe::interpAddToAccessPath $i [info library]]
+
+ # should add as p* (not p1 if parent has a module path)
+ set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]]
+
+ # should add as p* (not p2 if parent has a module path)
+ set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]]
+
+ # should not have been changed by Safe Base:
+ set auto2 [interp eval $i {set ::auto_path}]
+
+ set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]]
+
+ # This time, unlike test safe-17.2 and the try above, SafeTestPackage1 should be found:
+ list $auto1 $auto2 $token1 $token2 $token3 \
+ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \
+ [safe::interpConfigure $i]\
+ [safe::interpDelete $i]
+} -cleanup {
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\
+ {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\
+ -statics 0 -nested 1 -deleteHook {}\
+ -autoPath {}} {}"
+test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+ set i [safe::interpCreate]
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ interp eval $i {
+ package forget mod1::test1
+ catch {namespace delete ::mod1}
+ }
+} -body {
+ # Should raise an error (tests module ancestor directory rule)
+ set code1 [catch {interp eval $i {package require test1}} msg1]
+ # Should not raise an error
+ set code2 [catch {interp eval $i {package require mod1::test1}} msg2]
+ return [list $code1 $msg1 $code2]
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {1 {can't find package test1} 0}
+
+### 18. Test tokenization of directories available to a child.
+
+test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {set ::auto_path}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {}
+test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {set ::auto_path}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {}
+test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 1
+ }
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {::tcl::tm::path list}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {}
+test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate]
+} -body {
+ set badTokens {}
+ foreach dir [$i eval {::tcl::tm::path list}] {
+ if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} {
+ # Match - OK - token has expected form
+ } else {
+ # No match - possibly an ordinary path has not been tokenized
+ lappend badTokens $dir
+ }
+ }
+ set badTokens
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {}
+
+### 19. Assorted options, including changes to option values.
+### Mostly these are changes to access path, auto_path, module path.
+### If Sync Mode is on, a corresponding test with Sync Mode off is 9.*
+
+test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load and run the commands.
+ set code1 [catch {interp eval $i {report1}} msg1]
+ set code2 [catch {interp eval $i {report2}} msg2]
+
+ list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA -- $mappC -- $toksC
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {{$p(:0:)} {$p(:1:)} {$p(:2:)}}}
+test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Load and run the commands.
+ # This guarantees the test will pass even if the tokens are swapped.
+ set code1 [catch {interp eval $i {report1}} msg1]
+ set code2 [catch {interp eval $i {report2}} msg2]
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confB -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}}
+test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load auto_load data.
+ interp eval $i {catch nonExistentCommand}
+
+ # Do not load the commands. With the tokens swapped, the test
+ # will pass only if the Safe Base has called auto_reset.
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confB -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Load and run the commands.
+ set code3 [catch {interp eval $i {report1}} msg3]
+ set code4 [catch {interp eval $i {report2}} msg4]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
+ 0 ok1 0 ok2 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
+ {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}}
+test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement (1), Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
+ # This would have no effect because the records in Pkg of these directories
+ # were from access as children of {$p(:1:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confB -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \
+ $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
+ {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:1:)}} --\
+ 0 OK1 0 OK2}
+test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ # To manage without path auto0, use an auto_path that is unusual for
+ # package discovery.
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confB -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \
+ $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\
+ 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1} --\
+ {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:1:)} {$p(:2:)}} --\
+ 0 OK1 0 OK2}
+test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ # Path auto0 added (cf. safe-9.3) because it is needed for auto_path.
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Limit access path. Remove tokens {$p(:2:)} and {$p(:3:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library]
+
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4]
+ set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5]
+ set mappD [mapList $PathMapp [dict get $confB -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
+ set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6]
+
+ list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\
+ 1 {* not found in access path} -- 1 1 --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB*} -- {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
+ {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)}}}
+# (no counterpart safe-9.14)
+test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ # Test that although -autoPath is unchanged, the child's ::auto_path changes to
+ # reflect the changes in token mappings.
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:3:)}.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto2] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path0 $path1 $path2 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \
+ $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} {$p(:1:)} -- {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1 TESTSDIR/auto0*} --\
+ {TCLLIB TESTSDIR/auto0} --\
+ {TCLLIB TESTSDIR/auto0} --\
+ 0 OK1 0 OK2}
+# (no counterpart safe-9.15)
+test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ # Test that although -autoPath is unchanged, the child's ::auto_path changes to
+ # reflect the changes in token mappings; and that it is based on the -autoPath
+ # value, not the previously restricted child ::auto_path.
+ set i [safe::interpCreate -accessPath [list $tcl_library \
+ [file join $TestsDir auto0]] \
+ -autoPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]]
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappA [mapList $PathMapp [dict get $confA -accessPath]]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Add more directories.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]]
+ set mappD [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path0 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \
+ $code3 $msg3 $code4 $msg4 -- \
+ $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} -- {$p(:1:)} {$p(:2:)} {$p(:3:)} -- {{$p(:0:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\
+ {TCLLIB TESTSDIR/auto0*} --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\
+ 0 OK1 0 OK2}
+# (no counterpart safe-9.16)
+test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoPath preserved when -accessPath changes, ::auto_path using changed tokens, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set tmpAutoPath $::auto_path
+ set ::auto_path [list $tcl_library [file join $TestsDir auto0]]
+ set i [safe::interpCreate]
+ set ::auto_path $tmpAutoPath
+} -body {
+ # Test that the -autoPath acquires and keeps the parent's value unless otherwise specified.
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set mappC [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksC [interp eval $i set ::auto_path]
+
+ # Load pkgIndex.tcl data.
+ catch {interp eval $i {package require NOEXIST}}
+
+ # Rearrange access path. Remove a directory.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0] \
+ [file join $TestsDir auto0 auto1]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set mappB [mapList $PathMapp [dict get $confB -accessPath]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]]
+ set mappD [mapList $PathMapp [dict get $confA -autoPath]]
+ set toksD [interp eval $i set ::auto_path]
+
+ # Try to load the packages and run a command from each one.
+ set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3]
+ set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4]
+ set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5]
+ set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6]
+
+ list $path5 $path3 -- [lindex $toksC 0] [llength $toksC] -- \
+ $toksD -- $code3 $msg3 $code4 $msg4 -- \
+ $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:0:)} 2 --\
+ {{$p(:0:)} {$p(:1:)}} -- 0 1.2.3 1 {can't find package SafeTestPackage2} --\
+ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1*} --\
+ {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\
+ 0 OK1 1 {invalid command name "HeresPackage2"}}
+test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} -- res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Load pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Refresh stale pkg data.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+test safe-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set oldTm [tcl::tm::path list]
+ foreach path $oldTm {
+ tcl::tm::path remove $path
+ }
+ tcl::tm::path add [file join $TestsDir auto0 modules]
+} -body {
+ set i [safe::interpCreate -accessPath [list $tcl_library]]
+
+ # Inspect.
+ set confA [safe::interpConfigure $i]
+ set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]]
+ set modsA [interp eval $i {tcl::tm::path list}]
+ set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Force the interpreter to acquire pkg data which will soon become stale.
+ catch {interp eval $i {package require NOEXIST}}
+ catch {interp eval $i {package require mod1::NOEXIST}}
+ catch {interp eval $i {package require mod2::NOEXIST}}
+
+ # Add to access path.
+ # This injects more tokens, pushing modules to higher token numbers.
+ safe::interpConfigure $i -accessPath [list $tcl_library \
+ [file join $TestsDir auto0 auto1] \
+ [file join $TestsDir auto0 auto2]]
+ # Inspect.
+ set confB [safe::interpConfigure $i]
+ set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]]
+ set modsB [interp eval $i {tcl::tm::path list}]
+ set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]]
+ set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]]
+ set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]]
+
+ # Try to load the packages and run a command from each one.
+ set code0 [catch {interp eval $i {package require test0}} msg0]
+ set code1 [catch {interp eval $i {package require mod1::test1}} msg1]
+ set code2 [catch {interp eval $i {package require mod2::test2}} msg2]
+ set out0 [interp eval $i {test0::try0}]
+ set out1 [interp eval $i {mod1::test1::try1}]
+ set out2 [interp eval $i {mod2::test2::try2}]
+
+ list [lsort [list $path0 $path1 $path2]] -- $modsA -- \
+ [lsort [list $path3 $path4 $path5]] -- $modsB -- \
+ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \
+ $out0 $out1 $out2
+} -cleanup {
+ tcl::tm::path remove [file join $TestsDir auto0 modules]
+ foreach path [lreverse $oldTm] {
+ tcl::tm::path add $path
+ }
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\
+ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\
+ 0 0.5 0 1.0 0 2.0 --\
+ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\
+ TESTSDIR/auto0/modules/mod2} --\
+ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\
+ TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\
+ res0 res1 res2}
+# See comments on lsort after test safe-9.20.
+
+
+### 20. safe::interpCreate with different cases of -accessPath, -autoPath.
+
+set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]]
+
+test safe-20.1 "create -accessPath NULL -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list $::auto_path -- $::auto_path]
+test safe-20.2 "create -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath {}]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list $::auto_path -- $::auto_path]
+test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1]]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -autoPath {}]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath {} -autoPath {}]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath {}]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -autoPath [lrange $::auto_path 0 0]]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
+test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath {} -autoPath [lrange $::auto_path 0 0]]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
+test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
+test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -autoPath /not/in/access/path]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
+test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath {} -autoPath /not/in/access/path]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
+test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+} -body {
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath /not/in/access/path]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
+
+### 21. safe::interpConfigure with different cases of -accessPath, -autoPath.
+
+test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -deleteHook {}
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
+test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> parent's ::auto_path" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath {}
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list $::auto_path -- $::auto_path]
+test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath [lrange $::auto_path 0 1]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]]
+test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -autoPath {}
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath {} -autoPath {}
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath [lrange $::auto_path 1 1] -autoPath {}
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {{} -- {}}
+test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -autoPath [lrange $::auto_path 1 1]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
+test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath {} -autoPath [lrange $::auto_path 1 1]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
+test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath [lrange $::auto_path 1 1]
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]]
+test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -autoPath /not/in/access/path
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
+test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath {} -autoPath /not/in/access/path
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
+test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup {
+ set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}]
+ if {$SyncExists} {
+ set SyncVal_TMP [safe::setSyncMode]
+ safe::setSyncMode 0
+ } else {
+ error {This test is meaningful only if the command ::safe::setSyncMode is defined}
+ }
+ set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]]
+} -body {
+ safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath /not/in/access/path
+ getAutoPath $i
+} -cleanup {
+ safe::interpDelete $i
+ if {$SyncExists} {
+ safe::setSyncMode $SyncVal_TMP
+ }
+} -result {/not/in/access/path -- {}}
# cleanup
set ::auto_path $SaveAutoPath
unset SaveAutoPath TestsDir PathMapp
+rename getAutoPath {}
unset -nocomplain path
rename mapList {}
rename mapAndSortList {}
diff --git a/tests/scan.test b/tests/scan.test
index cd2ba63..98ec314 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1994 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1994 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -19,11 +19,8 @@ if {"::tcltest" ni [namespace children]} {
# procedure that returns the range of integers
proc int_range {} {
- for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} {
- set MIN_INT [expr { $MIN_INT << 1 }]
- }
- set MIN_INT [expr {int($MIN_INT)}]
- set MAX_INT [expr { ~ $MIN_INT }]
+ set MAX_INT [expr {[format %u -2]/2}]
+ set MIN_INT [expr { ~ $MAX_INT }]
return [list $MIN_INT $MAX_INT]
}
@@ -35,9 +32,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -47,19 +44,19 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -69,11 +66,11 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
set ieeeValues(littleEndian) 0
return 1
@@ -85,8 +82,7 @@ proc testIEEE {} {
}
testConstraint ieeeFloatingPoint [testIEEE]
-testConstraint wideIs64bit \
- [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
@@ -557,8 +553,13 @@ test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
- %llu a] $a
-} -returnCodes 1 -result {unsigned bignum scans are invalid}
+ %llu a] $a
+} -result {1 207698809136909011942886895}
+test scan-5.20 {ignore digit separators} -setup {
+ set a {}; set b {}; set c {};
+} -body {
+ list [scan "10_23_45" %d_%d_%d a b c] $a $b $c
+} -result {3 10 23 45}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
@@ -604,6 +605,11 @@ test scan-6.8 {floating-point scanning} -setup {
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
+test scan-6.9 {disallow diget separator in floating-point} -setup {
+ set a {}; set b {}; set c {};
+} -body {
+ list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c
+} -result {3 3.14 2.35 98.6}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
@@ -633,18 +639,18 @@ test scan-7.5 {string and character scanning} -setup {
test scan-7.6 {string and character scanning, unicode} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
- list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
-} -result "4 abc d\u00c7f ghijk dum"
+ list [scan "abc dÇfghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
+} -result "4 abc dÇf ghijk dum"
test scan-7.7 {string and character scanning, unicode} -setup {
set a {}; set b {}
} -body {
- list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b
+ list [scan "abÇcdef" "ab%c%c" a b] $a $b
} -result "2 199 99"
test scan-7.8 {string and character scanning, unicode} -setup {
set a {}; set b {}
} -body {
- list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a
-} -result "1 ab\ufeff"
+ list [scan "ab\uFEFFdef" "%\[ab\uFEFF\]" a] $a
+} -result "1 ab\uFEFF"
test scan-8.1 {error conditions} -body {
scan a
diff --git a/tests/security.test b/tests/security.test
index 3235a1f..6aa7ccb 100644
--- a/tests/security.test
+++ b/tests/security.test
@@ -6,8 +6,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
if {"::tcltest" ni [namespace children]} {
diff --git a/tests/set-old.test b/tests/set-old.test
index 68e0497..3289ae8 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -6,9 +6,9 @@
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -169,7 +169,7 @@ test set-old-5.4 {errors in reading variables} {
test set-old-6.1 {creating array during write} {
catch {unset a}
- trace var a rwu ignore
+ trace add var a {read write unset} ignore
list [catch {set a(14) 186} msg] $msg [array names a]
} {0 186 14}
test set-old-6.2 {errors in writing variables} {
@@ -340,7 +340,7 @@ test set-old-8.6 {array command} {
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
+} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
@@ -407,7 +407,7 @@ test set-old-8.18 {array command, get option} {
test set-old-8.19 {array command, get option (unset variable)} {
catch {unset a}
set a(x) 3
- trace var a(y) w ignore
+ trace add var a(y) write ignore
array get a
} {x 3}
test set-old-8.20 {array command, get option, with pattern} {
@@ -445,13 +445,13 @@ test set-old-8.24 {array command, names option} {
test set-old-8.25 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
- trace var a(xxx) w ignore
+ trace add var a(xxx) write ignore
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33}}
test set-old-8.26 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
- trace var a(xxx) w ignore
+ trace add var a(xxx) write ignore
set a(xxx) value
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33 xxx}}
@@ -579,7 +579,7 @@ test set-old-8.43 {array command, size option} {
test set-old-8.44 {array command, size option} {
catch {unset a}
set a(22) 3;
- trace var a(33) rwu ignore
+ trace add var a(33) {read write unset} ignore
list [catch {array size a} msg] $msg
} {0 1}
test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
@@ -700,7 +700,7 @@ test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
list [array star a] [array star a] [array done a s-1-a; array star a] \
- [array done a s-2-a; array d a s-3-a; array start a]
+ [array done a s-2-a; array do a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}
test set-old-9.2 {array enumeration} {
catch {unset a}
@@ -786,7 +786,7 @@ test set-old-9.10 {array enumeration: searches automatically stopped} {
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
- trace var a(b) r {}
+ trace add var a(b) read {}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
@@ -795,14 +795,14 @@ test set-old-9.11 {array enumeration: searches automatically stopped} {
set a(a) 1
set x [array startsearch a]
set y [array startsearch a]
- trace var a(a) r {}
+ trace add var a(a) read {}
list [catch {array next a $x} msg] $msg \
[catch {array next a $y} msg2] $msg2
} {0 a 0 a}
test set-old-9.12 {array enumeration with traced undefined elements} {
catch {unset a}
set a(a) 1
- trace var a(b) r {}
+ trace add var a(b) read {}
set x [array startsearch a]
lsort [list [array next a $x] [array next a $x]]
} {{} a}
diff --git a/tests/set.test b/tests/set.test
index 303c2d7..3f099a3 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testset2 [llength [info commands testset2]]
@@ -263,7 +263,7 @@ test set-2.4 {set command: runtime error, readonly variable} -setup {
} -body {
proc readonly args {error "variable is read-only"}
set x 123
- trace var x w readonly
+ trace add var x write readonly
list [catch {set x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
@@ -521,7 +521,7 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
set z set
proc readonly args {error "variable is read-only"}
$z x 123
- trace var x w readonly
+ trace add var x write readonly
list [catch {$z x 1} msg] $msg $::errorInfo
} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only
while executing
diff --git a/tests/socket.test b/tests/socket.test
index 7251bfa..b628404 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -66,16 +66,21 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
+catch [list package require -exact tcl::test [info patchlevel]]
+::tcltest::loadTestedCommands
# A bad interaction between socket creation, macOS, and unattended CI
# environments make this whole file impractical to run; too many weird hangs.
if {[info exists ::env(MAC_CI)]} {
return
}
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint exec [llength [info commands exec]]
+testConstraint notWinCI [expr {
+ $tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
@@ -96,6 +101,14 @@ proc randport {} {
return $port
}
+# Check if testsocket testflags is available
+testConstraint testsocket_testflags [expr {![catch {
+ set h [socket -async localhost [randport]]
+ testsocket testflags $h 0
+ close $h
+ }]}]
+
+
# Test the latency of tcp connections over the loopback interface. Some OSes
# (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
# up to 200ms for a packet sent to localhost to arrive. We're measuring this
@@ -295,13 +308,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s
} -returnCodes error -result {no argument given for -server option}
test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"}
test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myaddr
} -returnCodes error -result {no argument given for -myaddr option}
test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myaddr $localhost
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"}
test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport
} -returnCodes error -result {no argument given for -myport option}
@@ -310,19 +323,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s
} -returnCodes error -result {expected integer but got "xxxx"}
test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -myport 2522
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"}
test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -froboz
-} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server}
+} -returnCodes error -result {bad option "-froboz": must be -async, -backlog, -myaddr, -myport, -reuseaddr, -reuseport, or -server}
test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -myport 2521 3333
} -returnCodes error -result {option -myport is not valid for servers}
test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket host 2528 -junk
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"}
test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server callback 2520 --
-} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"}
+} -returnCodes error -result {wrong # args: should be "socket ?-async? ?-myaddr addr? ?-myport myport? host port" or "socket -server command ?-backlog count? ?-myaddr addr? ?-reuseaddr boolean? ?-reuseport boolean? port"}
test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket foo badport
} -returnCodes error -result {expected integer but got "badport"}
@@ -332,6 +345,24 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket
test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
socket -server foo -async
} -returnCodes error -result {cannot set -async option for server sockets}
+test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr yes 4242
+} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers}
+test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr no 4242
+} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers}
+test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseaddr
+} -returnCodes error -result {no argument given for -reuseaddr option}
+test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport yes 4242
+} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers}
+test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport no 4242
+} -returnCodes error -result {options -backlog, -reuseaddr, and -reuseport are only valid for servers}
+test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body {
+ socket -reuseport
+} -returnCodes error -result {no argument given for -reuseport option}
set path(script) [makeFile {} script]
@@ -709,7 +740,7 @@ test socket_$af-2.12 {} [list socket stdio supported_$af] {
close $f
set ::done
} 0
-test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} {
+test socket_$af-2.13 {Bug 1758a0b603} {socket stdio notWine} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -1040,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket
close $s
update
llength $l
-} -result 14
+} -result 20
test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup {
set timer [after 10000 "set x timed_out"]
set l ""
@@ -1518,7 +1549,7 @@ test socket_$af-11.11 {testing spurious events} -setup {
after cancel $timer
sendCommand {close $server}
} -result {0 2690 1}
-test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup {
+test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer notWine] -setup {
set counter 0
set done 0
set port [sendCommand {
@@ -1937,522 +1968,575 @@ catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
-test socket-14.0.0 {[socket -async] when server only listens on IPv4} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x ok
- }
- set server [socket -server accept -myaddr 127.0.0.1 0]
- set port [lindex [fconfigure $server -sockname] 2]
-} -constraints {socket supported_inet localhost_v4} -body {
- set client [socket -async localhost $port]
- set after [after $latency {set x [fconfigure $client -error]}]
- vwait x
- set x
-} -cleanup {
- catch {after cancel $after}
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result ok
-test socket-14.0.1 {[socket -async] when server only listens on IPv6} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x ok
- }
- set server [socket -server accept -myaddr ::1 0]
- set port [lindex [fconfigure $server -sockname] 2]
-} -constraints {socket supported_inet6 localhost_v6} -body {
- set client [socket -async localhost $port]
- set after [after $latency {set x [fconfigure $client -error]}]
- vwait x
- set x
-} -cleanup {
- catch {after cancel $after}
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result ok
-test socket-14.1 {[socket -async] fileevent while still connecting} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- lappend x ok
- }
- set server [socket -server accept -myaddr localhost 0]
- set port [lindex [fconfigure $server -sockname] 2]
- set x ""
-} -constraints socket -body {
- set client [socket -async localhost $port]
- fileevent $client writable {
- lappend x [fconfigure $client -error]
- fileevent $client writable {}
- }
- set after [after $latency {lappend x timeout}]
- while {[llength $x] < 2 && "timeout" ni $x} {
- vwait x
- }
- lsort $x; # we only want to see both events, the order doesn't matter
-} -cleanup {
- catch {after cancel $after}
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result {{} ok}
-test socket-14.2 {[socket -async] fileevent connection refused} -setup {
- set after [after $latency set x timeout]
-} -body {
- set client [socket -async localhost [randport]]
- fileevent $client writable {set x ok}
- vwait x
- lappend x [fconfigure $client -error]
-} -constraints socket -cleanup {
- catch {after cancel $after}
- catch {close $client}
- unset -nocomplain x after client
-} -result {ok {connection refused}}
-test socket-14.3 {[socket -async] when server only listens on IPv6} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x ok
- }
- set server [socket -server accept -myaddr ::1 0]
- set port [lindex [fconfigure $server -sockname] 2]
-} -constraints {socket supported_inet6 localhost_v6} -body {
- set client [socket -async localhost $port]
- set after [after $latency {set x [fconfigure $client -error]}]
- vwait x
- set x
-} -cleanup {
- catch {after cancel $after}
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result ok
-test socket-14.4 {[socket -async] and both, readdable and writable fileevents} -setup {
- proc accept {s a p} {
- puts $s bye
- close $s
- }
- set server [socket -server accept -myaddr localhost 0]
- set port [lindex [fconfigure $server -sockname] 2]
- set x ""
-} -constraints socket -body {
- set client [socket -async localhost $port]
- fileevent $client writable {
- lappend x [fconfigure $client -error]
- fileevent $client writable {}
- }
- fileevent $client readable {lappend x [gets $client]}
- set after [after $latency {lappend x timeout}]
- while {[llength $x] < 2 && "timeout" ni $x} {
- vwait x
- }
- lsort $x
-} -cleanup {
- catch {after cancel $after}
- catch {close $client}
- catch {close $server}
- unset -nocomplain x
-} -result {{} bye}
+test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set client [socket -async localhost $port]
+ set after [after $latency {set x [fconfigure $client -error]}]
+ vwait x
+ set x
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result ok
+test socket-14.0.1 {[socket -async] when server only listens on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set client [socket -async localhost $port]
+ set after [after $latency {set x [fconfigure $client -error]}]
+ vwait x
+ set x
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result ok
+test socket-14.1 {[socket -async] fileevent while still connecting} \
+ -constraints {socket} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ lappend x ok
+ }
+ set server [socket -server accept -myaddr localhost 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } -body {
+ set client [socket -async localhost $port]
+ fileevent $client writable {
+ lappend x [fconfigure $client -error]
+ fileevent $client writable {}
+ }
+ set after [after $latency {lappend x timeout}]
+ while {[llength $x] < 2 && "timeout" ni $x} {
+ vwait x
+ }
+ lsort $x; # we only want to see both events, the order doesn't matter
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result {{} ok}
+test socket-14.2 {[socket -async] fileevent connection refused} \
+ -constraints {socket} \
+ -body {
+ set client [socket -async localhost [randport]]
+ fileevent $client writable {set x ok}
+ set after [after $latency {set x timeout}]
+ vwait x
+ after cancel $after
+ lappend x [fconfigure $client -error]
+ } -cleanup {
+ after cancel $after
+ close $client
+ unset x after client
+ } -result {ok {connection refused}}
+test socket-14.3 {[socket -async] when server only listens on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set client [socket -async localhost $port]
+ set after [after $latency {set x [fconfigure $client -error]}]
+ vwait x
+ set x
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result ok
+test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
+ -constraints {socket} \
+ -setup {
+ proc accept {s a p} {
+ puts $s bye
+ close $s
+ }
+ set server [socket -server accept -myaddr localhost 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } -body {
+ set client [socket -async localhost $port]
+ fileevent $client writable {
+ lappend x [fconfigure $client -error]
+ fileevent $client writable {}
+ }
+ fileevent $client readable {lappend x [gets $client]}
+ set after [after $latency {lappend x timeout}]
+ while {[llength $x] < 2 && "timeout" ni $x} {
+ vwait x
+ }
+ lsort $x
+ } -cleanup {
+ after cancel $after
+ close $client
+ close $server
+ unset x
+ } -result {{} bye}
# FIXME: we should also have an IPv6 counterpart of this
-test socket-14.5 {[socket -async] which fails before any connect() can be made} -body {
- # address from rfc5737
- socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
-} -constraints {socket supported_inet notOSX} -returnCodes 1 \
+test socket-14.5 {[socket -async] which fails before any connect() can be made} \
+ -constraints {socket supported_inet notWine} \
+ -body {
+ # address from rfc5737
+ socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
+ } \
+ -returnCodes 1 \
-result {couldn't open socket: cannot assign requested address}
-test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x ok
- }
- set server [socket -server accept -myaddr 127.0.0.1 0]
- set port [lindex [fconfigure $server -sockname] 2]
- set x ""
-} -constraints {socket supported_inet localhost_v4} -body {
- set client [socket -async localhost $port]
- for {set i 0} {$i < 50} {incr i } {
- update
- if {$x ne ""} {
- lappend x [gets $client]
- break
- }
- after 100
- }
- set x
-} -cleanup {
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result {ok bye}
-test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} -setup {
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x ok
- }
- set server [socket -server accept -myaddr ::1 0]
- set port [lindex [fconfigure $server -sockname] 2]
- set x ""
-} -constraints {socket supported_inet6 localhost_v6} -body {
- set client [socket -async localhost $port]
- for {set i 0} {$i < 50} {incr i } {
- update
- if {$x ne ""} {
- lappend x [gets $client]
- break
- }
- after 100
- }
- set x
-} -cleanup {
- catch {close $server}
- catch {close $client}
- unset -nocomplain x
-} -result {ok bye}
-test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr 127.0.0.1 0]
- proc accept {s h p} {puts $s ok; close $s; set ::x 1}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet localhost_v4 notOSX} -body {
- set sock [socket -async localhost $port]
- list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok {}}
-test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr ::1 0]
- proc accept {s h p} {puts $s ok; close $s; set ::x 1}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet6 localhost_v6 notOSX} -body {
- set sock [socket -async localhost $port]
- list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok {}}
-test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} -setup {
- set sock [socket -server error 0]
- set unusedPort [lindex [fconfigure $sock -sockname] 2]
- close $sock
-} -body {
- set sock [socket -async localhost $unusedPort]
- catch {gets $sock} x
- list $x [fconfigure $sock -error] [fconfigure $sock -error]
-} -constraints {socket notOSX} -cleanup {
- catch {close $sock}
-} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
-test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr 127.0.0.1 0]
- proc accept {s h p} {puts $s ok; close $s; set ::x 1}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet localhost_v4} -body {
- set sock [socket -async localhost $port]
- fconfigure $sock -blocking 0
- for {set i 0} {$i < 50} {incr i } {
- if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
- after 200
- }
- set x
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {ok}
-test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr ::1 0]
- proc accept {s h p} {puts $s ok; close $s; set ::x 1}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet6 localhost_v6} -body {
- set sock [socket -async localhost $port]
- fconfigure $sock -blocking 0
- for {set i 0} {$i < 50} {incr i } {
- if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
- after 200
- }
- set x
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {ok}
-test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} -body {
- set sock [socket -async localhost [randport]]
- fconfigure $sock -blocking 0
- for {set i 0} {$i < 50} {incr i } {
- if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
- after 200
- }
- list $x [fconfigure $sock -error] [fconfigure $sock -error]
-} -constraints socket -cleanup {
- catch {close $sock}
-} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
-test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} -setup {
- makeFile {
- fileevent stdin readable exit
- after 10000 exit
- set server [socket -server accept -myaddr 127.0.0.1 0]
- proc accept {s h p} {set ::x $s}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- puts [gets $x]
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet localhost_v4 notOSX} -body {
- set sock [socket -async localhost $port]
- puts $sock ok
- flush $sock
- list [fconfigure $sock -error] [gets $fd]
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok}
-test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} -setup {
- makeFile {
- fileevent stdin readable exit
- after 10000 exit
- set server [socket -server accept -myaddr ::1 0]
- proc accept {s h p} {set ::x $s}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- puts [gets $x]
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
-} -constraints {socket supported_inet6 localhost_v6 notOSX} -body {
- set sock [socket -async localhost $port]
- puts $sock ok
- flush $sock
- list [fconfigure $sock -error] [gets $fd]
-} -cleanup {
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok}
-test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr 127.0.0.1 0]
- proc accept {s h p} {set ::x $s}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- puts [gets $x]
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
- set after [after $latency set x timeout]
-} -constraints {socket supported_inet localhost_v4} -body {
- set sock [socket -async localhost $port]
- fconfigure $sock -blocking 0
- puts $sock ok
- flush $sock
- fileevent $fd readable {set x 1}
- vwait x
- list [fconfigure $sock -error] [gets $fd]
-} -cleanup {
- after cancel $after
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok}
-test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} -setup {
- makeFile {
- fileevent stdin readable exit
- set server [socket -server accept -myaddr ::1 0]
- proc accept {s h p} {set ::x $s}
- puts [lindex [fconfigure $server -sockname] 2]
- flush stdout
- vwait x
- puts [gets $x]
- } script
- set fd [open |[list [interpreter] script] RDWR]
- set port [gets $fd]
- set after [after $latency set x timeout]
-} -constraints {socket supported_inet6 localhost_v6} -body {
- set sock [socket -async localhost $port]
- fconfigure $sock -blocking 0
- puts $sock ok
- flush $sock
- fileevent $fd readable {set x 1}
- vwait x
- list [fconfigure $sock -error] [gets $fd]
-} -cleanup {
- after cancel $after
- catch {close $fd}
- catch {close $sock}
- removeFile script
-} -result {{} ok}
-test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} -setup {
- set after [after $latency set x timeout]
-} -body {
- set sock [socket -async localhost [randport]]
- fconfigure $sock -blocking 0
- puts $sock ok
- fileevent $sock writable {set x 1}
- vwait x
- close $sock
-} -constraints socket -cleanup {
- after cancel $after
- catch {close $sock}
- unset -nocomplain x
-} -result {socket is not connected} -returnCodes 1
-test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} -setup {
- set after [after $latency set x timeout]
-} -body {
- set sock [socket -async localhost [randport]]
- fconfigure $sock -blocking 0
- puts $sock ok
- flush $sock
- fileevent $sock writable {set x 1}
- vwait x
- close $sock
-} -constraints {socket nonPortable} -cleanup {
- after cancel $timeout
- catch {close $sock}
- unset -nocomplain x
-} -result {socket is not connected} -returnCodes 1
-test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} -body {
- set s [socket -async localhost [randport]]
- for {set i 0} {$i < 50} {incr i} {
- set x [fconfigure $s -error]
- if {$x != ""} break
- after 200
- }
- set x
-} -constraints socket -cleanup {
- catch {close $s}
- unset -nocomplain x s
-} -result {connection refused}
-test socket-14.13 {testing writable event when quick failure} -body {
+test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } \
+ -body {
+ set client [socket -async localhost $port]
+ for {set i 0} {$i < 50} {incr i } {
+ update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
+ }
+ set x
+ } \
+ -cleanup {
+ close $server
+ close $client
+ unset x
+ } \
+ -result {ok bye}
+test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } \
+ -body {
+ set client [socket -async localhost $port]
+ for {set i 0} {$i < 50} {incr i } {
+ update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
+ }
+ set x
+ } \
+ -cleanup {
+ close $server
+ close $client
+ unset x
+ } \
+ -result {ok bye}
+test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok {}}
+test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok {}}
+test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ catch {gets $sock} x
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}}
+test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {ok}
+test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {ok}
+test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": transport endpoint is not connected} {connection refused} {}}
+test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
+ -constraints {socket notWinCI} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ unset x
+ } -result {transport endpoint is not connected} -returnCodes 1
+test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
+ -constraints {socket testsocket_testflags} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ # Set the socket in async test mode.
+ # The async connect will not be continued on the following fconfigure
+ # and puts/flush. Thus, the connect will fail after them.
+ testsocket testflags $sock 1
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ testsocket testflags $sock 0
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ catch {unset x}
+ } -result {transport endpoint is not connected} -returnCodes 1
+test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \
+ -constraints {socket} \
+ -body {
+ set s [socket -async localhost [randport]]
+ for {set i 0} {$i < 50} {incr i} {
+ set x [fconfigure $s -error]
+ if {$x != ""} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $s
+ unset x s
+ } -result {connection refused}
+
+test socket-14.13 {testing writable event when quick failure} \
+ -constraints {socket win supported_inet notWine} \
+ -body {
# Test for bug 336441ed59 where a quick background fail was ignored
- #
+
# Test only for windows as socket -async 255.255.255.255 fails
# directly on Unix
- #
+
# The following connect should fail very quickly
- set a1 [after $latency {set x timeout}]
+ set a1 [after 2000 {set x timeout}]
set s [socket -async 255.255.255.255 43434]
fileevent $s writable {set x writable}
vwait x
set x
-} -constraints {socket win supported_inet} -cleanup {
+} -cleanup {
catch {close $s}
after cancel $a1
} -result writable
-test socket-14.14 {testing fileevent readable on failed async socket connect} -body {
+
+test socket-14.14 {testing fileevent readable on failed async socket connect} \
+ -constraints {socket} -body {
# Test for bug 581937ab1e
- set a1 [after $latency {set x timeout}]
+
+ set a1 [after 5000 {set x timeout}]
# This connect should fail
set s [socket -async localhost [randport]]
fileevent $s readable {set x readable}
vwait x
set x
-} -constraints socket -cleanup {
+} -cleanup {
catch {close $s}
after cancel $a1
} -result readable
-test socket-14.15 {blocking read on async socket should not trigger event handlers} -setup {
- set subprocess [open "|[list [interpreter]]" r+]
- fconfigure $subprocess -blocking 0 -buffering none
-} -constraints socket -body {
- puts $subprocess {
- set s [socket -async localhost [randport]]
- set x ok
- fileevent $s writable {set x fail}
- catch {read $s}
+
+test socket-14.15 {blocking read on async socket should not trigger event handlers} \
+ -constraints socket -body {
+ set s [socket -async localhost [randport]]
+ set x ok
+ fileevent $s writable {set x fail}
+ catch {read $s}
close $s
- puts $x
- exit
- }
- set after [after $latency set x timeout]
- fileevent $subprocess readable [list gets $subprocess x]
- vwait x
- return $x
-} -cleanup {
- catch {after cancel $after}
- if {![testConstraint win]} {
- catch {exec kill [pid $subprocess]}
- }
- catch {close $subprocess}
- unset -nocomplain x
-} -result ok
+ set x
+ } -result ok
+
# v4 and v6 is required to prevent that the async connect does not terminate
# before the fconfigure command. There is always an additional ip to try.
-test socket-14.16 {empty -peername while [socket -async] connecting} -body {
- set client [socket -async localhost [randport]]
- fconfigure $client -peername
-} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup {
- catch {close $client}
-} -result {}
+test socket-14.16 {empty -peername while [socket -async] connecting} \
+ -constraints {socket localhost_v4 localhost_v6} \
+ -body {
+ set client [socket -async localhost [randport]]
+ fconfigure $client -peername
+ } -cleanup {
+ catch {close $client}
+ } -result {}
+
# v4 and v6 is required to prevent that the async connect does not terminate
# before the fconfigure command. There is always an additional ip to try.
-test socket-14.17 {empty -sockname while [socket -async] connecting} -body {
- set client [socket -async localhost [randport]]
- fconfigure $client -sockname
-} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup {
- catch {close $client}
-} -result {}
+test socket-14.17 {empty -sockname while [socket -async] connecting} \
+ -constraints {socket localhost_v4 localhost_v6} \
+ -body {
+ set client [socket -async localhost [randport]]
+ fconfigure $client -sockname
+ } -cleanup {
+ catch {close $client}
+ } -result {}
+
# test for bug c6ed4acfd8: running async socket connect with other connect
# established will block tcl as it goes in an infinite loop in vwait
-test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} -body {
- proc accept {channel address port} {}
- set port [randport]
- set ssock [socket -server accept $port]
- set csock1 [socket -async localhost [randport]]
- set csock2 [socket localhost $port]
- after 1000 {set done ok}
- vwait done
-} -constraints {socket notOSX} -cleanup {
- catch {close $ssock}
- catch {close $csock1}
- catch {close $csock2}
-} -result {}
+test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \
+ -constraints {socket} \
+ -body {
+ proc accept {channel address port} {}
+ set port [randport]
+ set ssock [socket -server accept $port]
+ set csock1 [socket -async localhost [randport]]
+ set csock2 [socket localhost $port]
+ after 1000 {set done ok}
+ vwait done
+} -cleanup {
+ catch {close $ssock}
+ catch {close $csock1}
+ catch {close $csock2}
+ } -result {}
+
+test socket-14.19 {tip 456 -- introduce the -reuseport option} \
+ -constraints {socket notWine} \
+ -body {
+ proc accept {channel address port} {}
+ set port [randport]
+ set ssock1 [socket -server accept -reuseport yes $port]
+ set ssock2 [socket -server accept -reuseport yes $port]
+ return ok
+} -cleanup {
+ catch {close $ssock1}
+ catch {close $ssock2}
+ } -result ok
set num 0
@@ -2464,7 +2548,8 @@ set resulterr {
}
foreach {servip sc} $x {
foreach {cliip cc} $x {
- set constraints [list socket $sc $cc]
+ set constraints socket
+ lappend constraints $sc $cc
set result $resulterr
switch -- [lsort -unique [list $servip $cliip]] {
localhost - 127.0.0.1 - ::1 {
@@ -2481,20 +2566,29 @@ foreach {servip sc} $x {
}
}
}
- test socket-15.1.$num "Connect to $servip from $cliip" -setup {
- set server [socket -server accept -myaddr $servip 0]
- proc accept {s h p} { close $s }
- set port [lindex [fconfigure $server -sockname] 2]
- } -constraints $constraints -body {
- set s [socket $cliip $port]
- } -cleanup {
- close $server
- catch {close $s}
- } {*}$result
+ test socket-15.1.$num "Connect to $servip from $cliip" \
+ -constraints $constraints -setup {
+ set server [socket -server accept -myaddr $servip 0]
+ proc accept {s h p} { close $s }
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set s [socket $cliip $port]
+ } -cleanup {
+ close $server
+ catch {close $s}
+ } {*}$result
incr num
}
}
+test socket-bug-31fc36fe47 "Crash listening in multiple threads" \
+ -constraints thread -body {
+ close [socket -server xxx 0]
+ set tid [thread::create]
+ thread::send $tid {close [socket -server accept 0]}
+ thread::release $tid
+ } -result 0
+
::tcltest::cleanupTests
flush stdout
return
diff --git a/tests/source.test b/tests/source.test
index f2a2858..f5f9f0f 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -4,16 +4,16 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2.1}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
+if {[catch {package require tcltest 2.5}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
return
}
@@ -103,16 +103,15 @@ test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
- list [catch {source $sourcefile} msg] $msg $::errorCode
-} -match listGlob -result [list 1 \
- {couldn't read file "*_non_existent_": no such file or directory} \
- {POSIX ENOENT {no such file or directory}}]
+ source $sourcefile
+} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \
+ -errorCode {POSIX ENOENT {no such file or directory}}
test source-2.7 {utf-8 with BOM} -setup {
set sourcefile [makeFile {} source.file]
} -body {
set out [open $sourcefile w]
fconfigure $out -encoding utf-8
- puts $out "\ufeffset y new-y"
+ puts $out "\uFEFFset y new-y"
close $out
set y old-y
source -encoding utf-8 $sourcefile
@@ -200,7 +199,7 @@ test source-4.1 {continuation line parsing} -setup {
test source-6.1 {source is binary ok} -setup {
# Note [makeFile] writes in the system encoding.
# [source] defaults to reading in the system encoding.
- set sourcefile [makeFile [list set x "a b\0c"] source.file]
+ set sourcefile [makeFile [list set x "a b\x00c"] source.file]
} -body {
set x {}
source $sourcefile
@@ -209,7 +208,7 @@ test source-6.1 {source is binary ok} -setup {
removeFile source.file
} -result 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup {
- set sourcefile [makeFile "set x ab\32c" source.file]
+ set sourcefile [makeFile "set x ab\x1Ac" source.file]
} -body {
set x {}
source $sourcefile
@@ -223,7 +222,7 @@ test source-7.1 {source -encoding test} -setup {
file delete $sourcefile
set f [open $sourcefile w]
fconfigure $f -encoding utf-8
- puts $f "set symbol(square-root) \u221A; set x correct"
+ puts $f "set symbol(square-root) √; set x correct"
close $f
} -body {
set x unset
@@ -234,19 +233,19 @@ test source-7.1 {source -encoding test} -setup {
} -result correct
test source-7.2 {source -encoding test} -setup {
# This tests for bad interactions between [source -encoding]
- # and use of the Control-Z character (\u001A) as a cross-platform
+ # and use of the Control-Z character (\x1A) as a cross-platform
# EOF character by [source]. Here we write out and the [source] a
- # file that contains the byte \x1A, although not the character \u001A in
+ # file that contains the byte \x1A, although not the character \x1A in
# the indicated encoding.
set sourcefile [makeFile {} source.file]
file delete $sourcefile
set f [open $sourcefile w]
- fconfigure $f -encoding unicode
- puts $f "set symbol(square-root) \u221A; set x correct"
+ fconfigure $f -encoding utf-16
+ puts $f "set symbol(square-root) √; set x correct"
close $f
} -body {
set x unset
- source -encoding unicode $sourcefile
+ source -encoding utf-16 $sourcefile
set x
} -cleanup {
removeFile source.file
@@ -267,28 +266,28 @@ test source-7.5 {source -encoding: correct operation} -setup {
file delete $sourcefile
set f [open $sourcefile w]
fconfigure $f -encoding utf-8
- puts $f "proc \u20ac {} {return foo}"
+ puts $f "proc € {} {return foo}"
close $f
} -body {
source -encoding utf-8 $sourcefile
- \u20ac
+ €
} -cleanup {
removeFile source.file
- rename \u20ac {}
+ rename € {}
} -result foo
test source-7.6 {source -encoding: mismatch encoding error} -setup {
set sourcefile [makeFile {} source.file]
file delete $sourcefile
set f [open $sourcefile w]
fconfigure $f -encoding utf-8
- puts $f "proc \u20ac {} {return foo}"
+ puts $f "proc € {} {return foo}"
close $f
} -body {
source -encoding iso8859-1 $sourcefile
- \u20ac
+ €
} -cleanup {
removeFile source.file
-} -returnCodes error -result "invalid command name \"\u20ac\""
+} -returnCodes error -result {invalid command name "€"}
test source-8.1 {source and coroutine/yield} -setup {
set sourcefile [makeFile {} source.file]
diff --git a/tests/split.test b/tests/split.test
index efd4323..a34c49d 100644
--- a/tests/split.test
+++ b/tests/split.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -49,20 +49,20 @@ test split-1.8 {basic split commands} {
} {]\n}
test split-1.9 {basic split commands} {
proc foo {} {
- set x ab\000c
+ set x ab\x00c
set y [split $x {}]
return $y
}
foo
-} "a b \000 c"
+} "a b \x00 c"
test split-1.10 {basic split commands} {
- split "a0ab1b2bbb3\000c4" ab\000c
+ split "a0ab1b2bbb3\x00c4" ab\x00c
} {{} 0 {} 1 2 {} {} 3 {} 4}
test split-1.11 {basic split commands} {
split "12,3,45" {,}
} {12 3 45}
test split-1.12 {basic split commands} {
- split "\u0001ab\u0001cd\u0001\u0001ef\u0001" \1
+ split "\x01ab\x01cd\x01\x01ef\x01" \x01
} {{} ab cd {} ef {}}
test split-1.13 {basic split commands} {
split "12,34,56," {,}
@@ -71,8 +71,11 @@ test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
- split "a\U01f4a9b" {}
-} -result "a \U01f4a9 b"
+ split "a💩b" {}
+} -result "a 💩 b"
+test split-1.16 {basic split commands} -body {
+ split "a💩b" 💩
+} -result "a b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
diff --git a/tests/stack.test b/tests/stack.test
index 77cb69f..461e8d3 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/tests/string.test b/tests/string.test
index f2b8bcc..b003898 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -4,10 +4,10 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -18,18 +18,46 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+source [file join [file dirname [info script]] tcltests.tcl]
+
+
+# Helper commands to test various optimizations, code paths, and special cases.
+proc makeByteArray {s} {binary format a* $s}
+proc makeUnicode {s} {lindex [regexp -inline .* $s] 0}
+proc makeList {args} {return $args}
+proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
-testConstraint testobj [expr {[info commands testobj] != {}}]
-testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
-testConstraint testevalex [expr {[info commands testevalex] != {}}]
-testConstraint utf16 [expr {[string length \U010000] == 2}]
+testConstraint testobj [expr {[info commands testobj] ne {}}]
+testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
+testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint testutf16string [llength [info commands testutf16string]]
# 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]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
+
+proc representationpoke s {
+ set r [::tcl::unsupported::representation $s]
+ list [lindex $r 3] [string match {*, string representation "*"} $r]
+}
foreach noComp {0 1} {
@@ -48,10 +76,19 @@ if {$noComp} {
test string-1.1.$noComp {error conditions} -body {
list [catch {run {string gorp a b}} msg] $msg
-} -result {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -result {1 {unknown or ambiguous subcommand "gorp": 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-1.2.$noComp {error conditions} {
list [catch {run {string}} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
+test stringComp-1.3.$noComp {error condition - undefined method during compile} {
+ # We don't want this to complain about 'never' because it may never
+ # be called, or string may get redefined. This must compile OK.
+ proc foo {str i} {
+ if {"yes" == "no"} { string never called but complains here }
+ string index $str $i
+ }
+ foo abc 0
+} a
test string-2.1.$noComp {string compare, not enough args} {
list [catch {run {string compare a}} msg] $msg
@@ -84,10 +121,19 @@ test string-2.10.$noComp {string compare with special index} {
list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11.$noComp {string compare, unicode} {
- run {string compare ab\u7266 ab\u7267}
+ run {string compare ab牦 ab牧}
} -1
+test string-2.11.1.$noComp {string compare, unicode} {
+ run {string compare Ü Ü}
+} 0
+test string-2.11.2.$noComp {string compare, unicode} {
+ run {string compare Ü ü}
+} -1
+test string-2.11.3.$noComp {string compare, unicode} {
+ run {string compare ÜÜÜüü ÜÜÜÜÜ}
+} 1
test string-2.12.$noComp {string compare, high bit} {
- # This test will fail if the underlying comparison
+ # This test fails if the underlying comparison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
run {string compare "\x80" "@"}
@@ -98,12 +144,21 @@ test string-2.12.$noComp {string compare, high bit} {
test string-2.13.$noComp {string compare -nocase} {
run {string compare -nocase abcde abdef}
} -1
+test string-2.13.1.$noComp {string compare -nocase} {
+ run {string compare -nocase abcde Abdef}
+} -1
test string-2.14.$noComp {string compare -nocase} {
run {string compare -nocase abcde ABCDE}
} 0
test string-2.15.$noComp {string compare -nocase} {
run {string compare -nocase abcde abcde}
} 0
+test string-2.15.1.$noComp {string compare -nocase} {
+ run {string compare -nocase Ü Ü}
+} 0
+test string-2.15.2.$noComp {string compare -nocase} {
+ run {string compare -nocase ÜÜÜüü ÜÜÜÜÜ}
+} 0
test string-2.16.$noComp {string compare -nocase with length} {
run {string compare -length 2 -nocase abcde Abxyz}
} 0
@@ -119,7 +174,7 @@ test string-2.19.$noComp {string compare -nocase with excessive length} {
test string-2.20.$noComp {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
- run {string compare -len 5 \334\334\334 \334\334\374}
+ run {string compare -len 5 ÜÜÜ ÜÜü}
} -1
test string-2.21.$noComp {string compare -nocase with special index} {
list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg
@@ -142,10 +197,10 @@ test string-2.26.$noComp {string compare -nocase, null strings} {
test string-2.27.$noComp {string compare -nocase, null strings} {
run {string compare -nocase foo ""}
} 1
-test string-2.28.$noComp {string compare with length, unequal strings} {
+test string-2.28.$noComp {string compare with length, unequal strings, partial first string} {
run {string compare -length 2 abc abde}
} 0
-test string-2.29.$noComp {string compare with length, unequal strings} {
+test string-2.29.$noComp {string compare with length, unequal strings 2, full first string} {
run {string compare -length 2 ab abde}
} 0
test string-2.30.$noComp {string compare with NUL character vs. other ASCII} {
@@ -171,6 +226,9 @@ test string-2.35.$noComp {string compare, binary neq} {
test string-2.36.$noComp {string compare, binary neq unequal length} {
run {string compare [binary format a20a 0 1] [binary format a100a 0 0]}
} 1
+test string-2.37.$noComp {string compare with -length >= 2^32} {
+ run {string compare -length 4294967296 ab abde}
+} -1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
@@ -178,13 +236,13 @@ test string-3.1.$noComp {string equal} {
run {string equal abcde abdef}
} 0
test string-3.2.$noComp {string equal} {
- run {string eq abcde ABCDE}
+ run {string e abcde ABCDE}
} 0
test string-3.3.$noComp {string equal} {
run {string equal abcde abcde}
} 1
test string-3.4.$noComp {string equal -nocase} {
- run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
+ run {string equal -nocase ÜÜÜÜüüüü ÜÜÜÜÜÜÜÜ}
} 1
test string-3.5.$noComp {string equal -nocase} {
run {string equal -nocase abcde abdef}
@@ -198,6 +256,125 @@ test string-3.7.$noComp {string equal -nocase} {
test string-3.8.$noComp {string equal with length, unequal strings} {
run {string equal -length 2 abc abde}
} 1
+test string-3.9.$noComp {string equal, not enough args} {
+ list [catch {run {string equal a}} msg] $msg
+} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
+test string-3.10.$noComp {string equal, bad args} {
+ list [catch {run {string equal a b c}} msg] $msg
+} {1 {bad option "a": must be -nocase or -length}}
+test string-3.11.$noComp {string equal, bad args} {
+ list [catch {run {string equal -length -nocase str1 str2}} msg] $msg
+} {1 {expected integer but got "-nocase"}}
+test string-3.12.$noComp {string equal, too many args} {
+ list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg
+} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
+test string-3.13.$noComp {string equal with length unspecified} {
+ list [catch {run {string equal -length 10 10}} msg] $msg
+} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}}
+test string-3.14.$noComp {string equal with length} {
+ run {string equal -length 2 abcde abxyz}
+} 1
+test string-3.15.$noComp {string equal with special index} {
+ list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg
+} {1 {expected integer but got "end-3"}}
+
+test string-3.16.$noComp {string equal, unicode} {
+ run {string equal ab牦 ab牧}
+} 0
+test string-3.17.$noComp {string equal, unicode} {
+ run {string equal Ü Ü}
+} 1
+test string-3.18.$noComp {string equal, unicode} {
+ run {string equal Ü ü}
+} 0
+test string-3.19.$noComp {string equal, unicode} {
+ run {string equal ÜÜÜüü ÜÜÜÜÜ}
+} 0
+test string-3.20.$noComp {string equal, high bit} {
+ # This test fails if the underlying comparison
+ # is using signed chars instead of unsigned chars.
+ # (like SunOS's default memcmp thus the compat/memcmp.c)
+ run {string equal "\x80" "@"}
+ # Nb this tests works also in utf8 space because \x80 is
+ # translated into a 2 or more bytelength but whose first byte has
+ # the high bit set.
+} 0
+test string-3.21.$noComp {string equal -nocase} {
+ run {string equal -nocase abcde Abdef}
+} 0
+test string-3.22.$noComp {string equal, -nocase unicode} {
+ run {string equal -nocase Ü Ü}
+} 1
+test string-3.23.$noComp {string equal, -nocase unicode} {
+ run {string equal -nocase ÜÜÜüü ÜÜÜÜÜ}
+} 1
+test string-3.24.$noComp {string equal -nocase with length} {
+ run {string equal -length 2 -nocase abcde Abxyz}
+} 1
+test string-3.25.$noComp {string equal -nocase with length} {
+ run {string equal -nocase -length 3 abcde Abxyz}
+} 0
+test string-3.26.$noComp {string equal -nocase with length <= 0} {
+ run {string equal -nocase -length -1 abcde AbCdEf}
+} 0
+test string-3.27.$noComp {string equal -nocase with excessive length} {
+ run {string equal -nocase -length 50 AbCdEf abcde}
+} 0
+test string-3.28.$noComp {string equal -len unicode} {
+ # These are strings that are 6 BYTELENGTH long, but the length
+ # shouldn't make a different because there are actually 3 CHARS long
+ run {string equal -len 5 ÜÜÜ ÜÜü}
+} 0
+test string-3.29.$noComp {string equal -nocase with special index} {
+ list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg
+} {1 {expected integer but got "end-3"}}
+test string-3.30.$noComp {string equal, null strings} {
+ run {string equal "" ""}
+} 1
+test string-3.31.$noComp {string equal, null strings} {
+ run {string equal "" foo}
+} 0
+test string-3.32.$noComp {string equal, null strings} {
+ run {string equal foo ""}
+} 0
+test string-3.33.$noComp {string equal -nocase, null strings} {
+ run {string equal -nocase "" ""}
+} 1
+test string-3.34.$noComp {string equal -nocase, null strings} {
+ run {string equal -nocase "" foo}
+} 0
+test string-3.35.$noComp {string equal -nocase, null strings} {
+ run {string equal -nocase foo ""}
+} 0
+test string-3.36.$noComp {string equal with NUL character vs. other ASCII} {
+ # Be careful here, since UTF-8 rep comparison with memcmp() of
+ # these puts chars in the wrong order
+ run {string equal \x00 \x01}
+} 0
+test string-3.37.$noComp {string equal, high bit} {
+ run {string equal "a\x80" "a@"}
+} 0
+test string-3.38.$noComp {string equal, high bit} {
+ run {string equal "a\x00" "a\x01"}
+} 0
+test string-3.39.$noComp {string equal, high bit} {
+ run {string equal "a\x00\x00" "a\x00\x01"}
+} 0
+test string-3.40.$noComp {string equal, binary equal} {
+ run {string equal [binary format a100 0] [binary format a100 0]}
+} 1
+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-3.43.$noComp {string equal, big -length} {
+ run {string equal -length 4294967296 abc def}
+} 0
+test string-3.44.$noComp {string equal, bigger -length} -body {
+ run {string equal -length 18446744073709551616 abc def}
+} -returnCodes 1 -result {integer value too large to represent}
test string-4.1.$noComp {string first, not enough args} {
list [catch {run {string first a}} msg] $msg
@@ -224,19 +401,19 @@ test string-4.8.$noComp {string first} {
run {string first "" x123xx345xxx789xxx012}
} -1
test string-4.9.$noComp {string first, unicode} {
- run {string first x abc\u7266x}
+ run {string first x abc牦x}
} 4
test string-4.10.$noComp {string first, unicode} {
- run {string first \u7266 abc\u7266x}
+ run {string first 牦 abc牦x}
} 3
test string-4.11.$noComp {string first, start index} {
- run {string first \u7266 abc\u7266x 3}
+ run {string first 牦 abc牦x 3}
} 3
test string-4.12.$noComp {string first, start index} -body {
- run {string first \u7266 abc\u7266x 4}
+ run {string first 牦 abc牦x 4}
} -result -1
test string-4.13.$noComp {string first, start index} -body {
- run {string first \u7266 abc\u7266x end-2}
+ run {string first 牦 abc牦x end-2}
} -result 3
test string-4.14.$noComp {string first, negative start index} -body {
run {string first b abc -1}
@@ -245,12 +422,19 @@ test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars}
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
- set uchar \u057E ;# character with two-byte encoding in utf-8
+ set uchar վ ;# character with two-byte encoding in utf-8
run {string first % %#$uchar$uchar#$uchar$uchar#% 3}
} -result 8
+test string-4.16.$noComp {string first, normal string vs pure unicode string} -body {
+ set s hello
+ regexp ll $s m
+ # Representation checks are canaries
+ run {list [representationpoke $s] [representationpoke $m] \
+ [string first $m $s]}
+} -match glob -result {{*string 1} {*string 0} 2}
test string-4.17.$noComp {string first, corner case} -body {
run {string first a aaa 4294967295}
-} -result 0
+} -result -1
test string-4.18.$noComp {string first, corner case} -body {
run {string first a aaa -1}
} -result 0
@@ -259,7 +443,7 @@ test string-4.19.$noComp {string first, corner case} -body {
} -result 0
test string-4.20.$noComp {string last, corner case} -body {
run {string last a aaa 4294967295}
-} -result -1
+} -result 2
test string-4.21.$noComp {string last, corner case} -body {
run {string last a aaa -1}
} -result -1
@@ -277,7 +461,7 @@ test string-5.3.$noComp {string index} {
run {string index abcde 0}
} a
test string-5.4.$noComp {string index} {
- run {string in abcde 4}
+ run {string ind abcde 4}
} e
test string-5.5.$noComp {string index} {
run {string index abcde 5}
@@ -295,13 +479,13 @@ test string-5.9.$noComp {string index} {
run {string index abc end-1}
} b
test string-5.10.$noComp {string index, unicode} {
- run {string index abc\u7266d 4}
+ run {string index abc牦d 4}
} d
test string-5.11.$noComp {string index, unicode} {
- run {string index abc\u7266d 3}
-} \u7266
+ run {string index abc牦d 3}
+} 牦
test string-5.12.$noComp {string index, unicode over char length, under byte length} -body {
- run {string index \334\374\334\374 6}
+ run {string index ÜüÜü 6}
} -result {}
test string-5.13.$noComp {string index, bytearray object} {
run {string index [binary format a5 fuz] 0}
@@ -332,18 +516,13 @@ test string-5.19.$noComp {string index, bytearray object out of bounds} {
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]} -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}
-proc largest_int {} {
- # This will give us what the largest valid int on this machine is,
- # so we can test for overflow properly below on >32 bit systems
- set int 1
- set exp 7; # assume we get at least 8 bits
- while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] }
- return [expr {$int-1}]
-}
test string-6.1.$noComp {string is, not enough args} {
list [catch {run {string is}} msg] $msg
@@ -359,10 +538,10 @@ test string-6.4.$noComp {string is, too many args} {
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5.$noComp {string is, class check} {
list [catch {run {string is bogus str}} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}}
test string-6.6.$noComp {string is, ambiguous class} {
list [catch {run {string is al str}} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, unicode, wideinteger, wordchar, or xdigit}}
test string-6.7.$noComp {string is alpha, all ok} {
run {string is alpha -strict -failindex var abc}
} 1
@@ -385,7 +564,7 @@ test string-6.12.$noComp {string is alnum, true} {
test string-6.13.$noComp {string is alnum, false} {
list [run {string is alnum -failindex var abc1.23}] $var
} {0 4}
-test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xfc}" 1
+test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abcü}" 1
test string-6.15.$noComp {string is alpha, true} {
run {string is alpha abc}
} 1
@@ -393,7 +572,7 @@ test string-6.16.$noComp {string is alpha, false} {
list [run {string is alpha -fail var a1bcde}] $var
} {0 1}
test string-6.17.$noComp {string is alpha, unicode} {
- run {string is alpha abc\374}
+ run {string is alpha abcü}
} 1
test string-6.18.$noComp {string is ascii, true} {
run {string is ascii abc\x7Fend\x00}
@@ -417,7 +596,7 @@ test string-6.24.$noComp {string is digit, true} {
run {string is digit 0123456789}
} 1
test string-6.25.$noComp {string is digit, false} {
- list [run {string is digit -fail var 0123\xDC567}] $var
+ list [run {string is digit -fail var 0123Ü567}] $var
} {0 4}
test string-6.26.$noComp {string is digit, false} {
list [run {string is digit -fail var +123567}] $var
@@ -459,7 +638,7 @@ test string-6.37.$noComp {string is double, false on int overflow} -setup {
# Since bignums arrived in Tcl 8.5, the sense of this test changed.
# Now integer values that exceed native limits become bignums, and
# bignums can convert to doubles without error.
- list [run {string is double -fail var [largest_int]0}] $var
+ list [run {string is double -fail var 9223372036854775808}] $var
} -result {1 priorValue}
# string-6.38 removed, underflow on input is no longer an error.
test string-6.39.$noComp {string is double, false} {
@@ -518,9 +697,9 @@ test string-6.53.$noComp {string is integer, true with whitespace} {
test string-6.54.$noComp {string is integer, false} {
list [run {string is integer -fail var 123abc}] $var
} {0 3}
-test string-6.55.$noComp {string is integer, false on overflow} {
- list [run {string is integer -fail var +[largest_int]0}] $var
-} {0 -1}
+test string-6.55.$noComp {string is integer, no overflow possible} {
+ run {string is integer +9223372036854775808}
+} 1
test string-6.56.$noComp {string is integer, false} {
list [run {string is integer -fail var [expr {double(1)}]}] $var
} {0 1}
@@ -540,7 +719,7 @@ test string-6.60.$noComp {string is lower, true} {
run {string is lower abc}
} 1
test string-6.61.$noComp {string is lower, unicode true} {
- run {string is lower abc\xFCue}
+ run {string is lower abcüue}
} 1
test string-6.62.$noComp {string is lower, false} {
list [run {string is lower -fail var aBc}] $var
@@ -549,7 +728,7 @@ test string-6.63.$noComp {string is lower, false} {
list [run {string is lower -fail var abc1}] $var
} {0 3}
test string-6.64.$noComp {string is lower, unicode false} {
- list [run {string is lower -fail var ab\xDCUE}] $var
+ list [run {string is lower -fail var abÜUE}] $var
} {0 2}
test string-6.65.$noComp {string is space, true} {
run {string is space " \t\n\v\f"}
@@ -587,7 +766,7 @@ test string-6.75.$noComp {string is upper, true} {
run {string is upper ABC}
} 1
test string-6.76.$noComp {string is upper, unicode true} {
- run {string is upper ABC\xDCUE}
+ run {string is upper ABCÜUE}
} 1
test string-6.77.$noComp {string is upper, false} {
list [run {string is upper -fail var AbC}] $var
@@ -596,13 +775,13 @@ test string-6.78.$noComp {string is upper, false} {
list [run {string is upper -fail var AB2C}] $var
} {0 2}
test string-6.79.$noComp {string is upper, unicode false} {
- list [run {string is upper -fail var ABC\xFCue}] $var
+ list [run {string is upper -fail var ABCüue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
- run {string is wordchar abc\xFCab\xDCAB\u5001}
+ run {string is wordchar abcüabÜAB倁\U1D7CA}
} 1
test string-6.82.$noComp {string is wordchar, false} {
list [run {string is wordchar -fail var abcd.ef}] $var
@@ -651,22 +830,22 @@ test string-6.91.$noComp {string is double, bad doubles} {
}
return $result
} {1 1 0 0 0 1 0 0}
-test string-6.92.$noComp {string is integer, 32-bit overflow} {
+test string-6.92.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
- set x 0x100000000
- list [run {string is integer -failindex var $x}] $var
-} {0 -1}
-test string-6.93.$noComp {string is integer, 32-bit overflow} {
+ set x 0x10000000000000000
+ run {string is integer $x}
+} 1
+test string-6.93.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
- set x 0x100000000
+ set x 0x10000000000000000
append x ""
- list [run {string is integer -failindex var $x}] $var
-} {0 -1}
-test string-6.94.$noComp {string is integer, 32-bit overflow} {
+ run {string is integer $x}
+} 1
+test string-6.94.$noComp {string is integer, no 64-bit overflow} {
# Bug 718878
- set x 0x100000000
- list [run {string is integer -failindex var [expr {$x}]}] $var
-} {0 -1}
+ set x 0x10000000000000000
+ run {string is integer [expr {$x}]}
+} 1
test string-6.95.$noComp {string is wideinteger, true} {
run {string is wideinteger +1234567890}
} 1
@@ -689,7 +868,7 @@ test string-6.101.$noComp {string is wideinteger, false} {
list [run {string is wideinteger -fail var 123abc}] $var
} {0 3}
test string-6.102.$noComp {string is wideinteger, false on overflow} {
- list [run {string is wideinteger -fail var +[largest_int]0}] $var
+ list [run {string is wideinteger -fail var +9223372036854775808}] $var
} {0 -1}
test string-6.103.$noComp {string is wideinteger, false} {
list [run {string is wideinteger -fail var [expr {double(1)}]}] $var
@@ -795,24 +974,44 @@ test string-6.130.1.$noComp {string is entier, false on bad octal} {
test string-6.131.$noComp {string is entier, false on bad hex} {
list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var
} {0 88}
+test string-6.132.$noComp {string is unicode} {
+ run {string is unicode \U10FFFD\uD7FF\uE000\uFDCF\uFDF0}
+} 1
+test string-6.133.$noComp {string is unicode, upper surrogate} {
+ run {string is unicode \uD800}
+} 0
+test string-6.134.$noComp {string is unicode, lower surrogate} {
+ run {string is unicode \uDFFF}
+} 0
+test string-6.135.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFFFE}
+} 0
+test string-6.136.$noComp {string is unicode, noncharacter} {
+ run {string is unicode \uFFFF}
+} 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}
-} 0
+} 1
test string-6.140.$noComp {string is integer, bug [76ad7aeba3]} {
run {string is integer -18446744073709551615}
-} 0
+} 1
-catch {rename largest_int {}}
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 ?startIndex?"}}
+} {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
} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
test string-7.3.$noComp {string last, too many args} {
list [catch {run {string last a b c d}} msg] $msg
-} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}}
+} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}}
test string-7.4.$noComp {string last} {
run {string la xxx xxxx123xx345x678}
} 1
@@ -823,22 +1022,22 @@ test string-7.6.$noComp {string last} {
run {string las x xxxx123xx345x678}
} 12
test string-7.7.$noComp {string last, unicode} {
- run {string las x xxxx12\u7266xx345x678}
+ run {string las x xxxx12牦xx345x678}
} 12
test string-7.8.$noComp {string last, unicode} {
- run {string las \u7266 xxxx12\u7266xx345x678}
+ run {string las 牦 xxxx12牦xx345x678}
} 6
test string-7.9.$noComp {string last, stop index} {
- run {string las \u7266 xxxx12\u7266xx345x678}
+ run {string las 牦 xxxx12牦xx345x678}
} 6
test string-7.10.$noComp {string last, unicode} {
- run {string las \u7266 xxxx12\u7266xx345x678}
+ run {string las 牦 xxxx12牦xx345x678}
} 6
test string-7.11.$noComp {string last, start index} {
- run {string last \u7266 abc\u7266x 3}
+ run {string last 牦 abc牦x 3}
} 3
test string-7.12.$noComp {string last, start index} {
- run {string last \u7266 abc\u7266x 2}
+ run {string last 牦 abc牦x 2}
} -1
test string-7.13.$noComp {string last, start index} {
## Constrain to last 'a' should work
@@ -849,22 +1048,22 @@ test string-7.14.$noComp {string last, start index} {
run {string last ba badbad end-2}
} 0
test string-7.15.$noComp {string last, start index} {
- run {string last \334a \334ad\334ad 0}
+ run {string last Üa ÜadÜad 0}
} -1
test string-7.16.$noComp {string last, start index} {
- run {string last \334a \334ad\334ad end-1}
+ run {string last Üa ÜadÜad end-1}
} 3
-test string-8.1.$noComp {string bytelength} {
+test string-8.1.$noComp {string bytelength} deprecated {
list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.2.$noComp {string bytelength} {
+test string-8.2.$noComp {string bytelength} deprecated {
list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
-test string-8.3.$noComp {string bytelength} {
+test string-8.3.$noComp {string bytelength} deprecated {
run {string bytelength "\xC7"}
} 2
-test string-8.4.$noComp {string bytelength} {
+test string-8.4.$noComp {string bytelength} deprecated {
run {string b ""}
} 0
@@ -881,7 +1080,7 @@ test string-9.4.$noComp {string length} {
run {string le ""}
} 0
test string-9.5.$noComp {string length, unicode} {
- run {string le "abcd\u7266"}
+ run {string le "abcd牦"}
} 5
test string-9.6.$noComp {string length, bytearray object} {
run {string length [binary format a5 foo]}
@@ -901,13 +1100,13 @@ test string-10.3.$noComp {string map, too many args} {
} {1 {wrong # args: should be "string map ?-nocase? charMap string"}}
test string-10.4.$noComp {string map} {
run {string map {a b} abba}
-} {bbbb}
+} bbbb
test string-10.5.$noComp {string map} {
run {string map {a b} a}
-} {b}
+} b
test string-10.6.$noComp {string map -nocase} {
run {string map -nocase {a b} Abba}
-} {bbbb}
+} bbbb
test string-10.7.$noComp {string map} {
run {string map {abc 321 ab * a A} aabcabaababcab}
} {A321*A*321*}
@@ -922,25 +1121,25 @@ test string-10.10.$noComp {string map} {
} {1 {char map list unbalanced}}
test string-10.11.$noComp {string map, nulls} {
run {string map {\x00 NULL blah \x00nix} {qwerty}}
-} {qwerty}
+} qwerty
test string-10.12.$noComp {string map, unicode} {
- run {string map [list \374 ue UE \334] "a\374ueUE\x00EU"}
-} aueue\334\x00EU
+ 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 \374 ue UE \334] "a\374ueUE\x00EU"}
-} aue\334\334\x00EU
+ 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}
+} a32aBaAb32Ab
test string-10.16.$noComp {string map, one pair case} {
run {string map -nocase {ab 4321} aAbCaBaAbAbcAb}
-} {a4321C4321a43214321c4321}
+} a4321C4321a43214321c4321
test string-10.17.$noComp {string map, one pair case} {
run {string map {Ab 4321} aAbCaBaAbAbcAb}
-} {a4321CaBa43214321c4321}
+} a4321CaBa43214321c4321
test string-10.18.$noComp {string map, empty argument} {
run {string map -nocase {{} abc} foo}
} foo
@@ -1132,7 +1331,7 @@ test string-11.32.$noComp {string match nocase} {
run {string match -n a A}
} 1
test string-11.33.$noComp {string match nocase} {
- run {string match -nocase a\334 A\374}
+ run {string match -nocase aÜ Aü}
} 1
test string-11.34.$noComp {string match nocase} {
run {string match -nocase a*f ABCDEf}
@@ -1245,6 +1444,11 @@ test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
+test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} {
+ apply {s {
+ string range $s 0 end-5
+ }} 12345
+} {}
test string-12.1.$noComp {string range} {
list [catch {run {string range}} msg] $msg
} {1 {wrong # args: should be "string range string first last"}}
@@ -1294,11 +1498,11 @@ test string-12.16.$noComp {string range} {
run {string range abcdefghijklmnop end end-1}
} {}
test string-12.17.$noComp {string range, unicode} {
- run {string range ab\u7266cdefghijklmnop 5 5}
+ run {string range ab牦cdefghijklmnop 5 5}
} e
test string-12.18.$noComp {string range, unicode} {
- run {string range ab\u7266cdefghijklmnop 2 3}
-} \u7266c
+ run {string range ab牦cdefghijklmnop 2 3}
+} 牦c
test string-12.19.$noComp {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set r1 [run {string range $b 1 end-1}]
@@ -1329,9 +1533,23 @@ test string-12.22.$noComp {string range, shimmering binary/index} {
binary scan $s a* x
run {string range $s $s end}
} 000000001
-test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 {
+test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
-} [list \U100000 {} b]
+} [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 {
+ demo 2 0+0x10000000000000000
+} -result bar
+test string-12.25.$noComp {bignum index arithmetic} -setup {
+ proc demo {i j} {string range fubar $i $j}
+} -cleanup {
+ rename demo {}
+} -body {
+ demo 0x10000000000000000-0xffffffffffffffff 3
+} -result uba
test string-13.1.$noComp {string repeat} {
list [catch {run {string repeat}} msg] $msg
@@ -1367,15 +1585,15 @@ test string-13.11.$noComp {string repeat} {
run {string repeat def 1}
} def
test string-13.12.$noComp {string repeat} {
- run {string repeat ab\u7266cd 3}
-} ab\u7266cdab\u7266cdab\u7266cd
+ run {string repeat ab牦cd 3}
+} ab牦cdab牦cdab牦cd
test string-13.13.$noComp {string repeat} {
run {string repeat \x00 3}
} \x00\x00\x00
test string-13.14.$noComp {string repeat} {
# The string range will ensure us that string repeat gets a unicode string
- run {string repeat [run {string range ab\u7266cd 2 3}] 3}
-} \u7266c\u7266c\u7266c
+ run {string repeat [run {string range ab牦cd 2 3}] 3}
+} 牦c牦c牦c
test string-14.1.$noComp {string replace} {
list [catch {run {string replace}} msg] $msg
@@ -1433,6 +1651,65 @@ test string-14.18.$noComp {string replace} {
test string-14.19.$noComp {string replace} {
run {string replace {} -1 0 A}
} A
+test string-14.20.$noComp {string replace} {
+ run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\
+ [makeByteArray NEW]}
+} {abcdeNEWop}
+test string-14.21.$noComp {string replace (surrogates)} {
+ run {string replace \uD83D? 1 end \uDE02}
+} \uD83D\uDE02
+test string-14.22.$noComp {string replace (surrogates)} {
+ run {string replace ?\uDE02 0 end-1 \uD83D}
+} \uD83D\uDE02
+test string-14.23.$noComp {string replace \xC0 \x80} testbytestring {
+ run {string length [string replace [testbytestring \xC0]? 1 end [testbytestring \x80]]}
+} 2
+test string-14.24.$noComp {string replace \xC0 \x80} testbytestring {
+ run {string length [string replace ?[testbytestring \x80] 0 end-1 [testbytestring \xC0]]}
+} 2
+
+
+test stringComp-14.21.$noComp {Bug 82e7f67325} {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {a b}
+} {3 3}
+test stringComp-14.22.$noComp {Bug 82e7f67325} memory {
+ # As in stringComp-14.1, but make sure we don't retain too many refs
+ leaktest {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {a b}
+ }
+} {0}
+test stringComp-14.23.$noComp {Bug 0dca3bfa8f} {
+ apply {arg {
+ set argCopy $arg
+ set arg [string replace $arg 1 2 aa]
+ # Crashes in comparison before fix
+ expr {$arg ne $argCopy}
+ }} abcde
+} 1
+test stringComp-14.24.$noComp {Bug 1af8de570511} {
+ apply {{x y} {
+ # Generate an unshared string value
+ set val ""
+ for { set i 0 } { $i < $x } { incr i } {
+ set val [format "0%s" $val]
+ }
+ string replace $val[unset val] 1 1 $y
+ }} 4 x
+} 0x00
+test stringComp-14.25.$noComp {} {
+ string length [string replace [string repeat a\xFE 2] 3 end {}]
+} 3
+test stringComp-14.26.$noComp {} {
+ run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e}
+} aed
test string-15.1.$noComp {string tolower not enough args} {
list [catch {run {string tolower}} msg] $msg
@@ -1526,6 +1803,10 @@ test string-17.7.$noComp {string totitle, unicode} {
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]} {
+ 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
@@ -1579,7 +1860,7 @@ test string-20.1.$noComp {string trimright errors} {
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} -body {
list [catch {run {string trimg a}} msg] $msg
-} -result {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -result {1 {unknown or ambiguous subcommand "trimg": 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-20.3.$noComp {string trimright} {
run {string trimright " XYZ "}
} { XYZ}
@@ -1613,11 +1894,11 @@ test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is
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}]]
- lappend result [string map $m [run {string trimright $b [bytestring \xE8]}]]
+ lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]]
lappend result [string map $m [run {string trimright $b \xA0}]]
- lappend result [string map $m [run {string trimright $b [bytestring \xA0]}]]
+ lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]]
lappend result [string map $m [run {string trimright $b \xE8\xA0}]]
- lappend result [string map $m [run {string trimright $b [bytestring \xE8\xA0]}]]
+ lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]]
lappend result [string map $m [run {string trimright $b \x00}]]
} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV]
@@ -1663,6 +1944,12 @@ test string-21.13.$noComp {string wordend, unicode} -body {
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} -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!"
@@ -1693,7 +1980,7 @@ test string-21.25.$noComp {string trimright, unicode} {
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 bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} -match glob -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
} -result {1 {wrong # args: should be "string wordstart string index"}}
@@ -1735,6 +2022,12 @@ test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbyt
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} -body {
+ run {string wordstart "\U1D7CA\U1D7CA abc" 10}
+} -result 3
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
@@ -2134,6 +2427,53 @@ test string-29.4.$noComp {string cat, many args} {
set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}]
list $r1 $r2
} {0 0}
+if {$noComp} {
+test string-29.5.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list x] [list]}]
+} -match glob -result {*no string representation}
+test string-29.6.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list] [list x]}]
+} -match glob -result {*no string representation}
+test string-29.7.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list x] [list] [list]}]
+} -match glob -result {*no string representation}
+test string-29.8.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list] [list x] [list]}]
+} -match glob -result {*no string representation}
+test string-29.9.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list] [list] [list x]}]
+} -match glob -result {*no string representation}
+test string-29.10.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat [list x] [list x]}]
+} -match glob -result {*, string representation "xx"}
+test string-29.11.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation \
+ [run {string cat [list x] [encoding convertto utf-8 {}]}]
+} -match glob -result {*no string representation}
+test string-29.12.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation \
+ [run {string cat [encoding convertto utf-8 {}] [list x]}]
+} -match glob -result {*, string representation "x"}
+test string-29.13.$noComp {string cat, efficiency} -body {
+ tcl::unsupported::representation [run {string cat \
+ [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}]
+} -match glob -result {*, string representation "x"}
+test string-29.14.$noComp {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e
+} -body {
+ tcl::unsupported::representation [run {string cat $e $e [list x]}]
+} -match glob -result {*no string representation}
+test string-29.15.$noComp {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+ set f [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e f
+} -body {
+ tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
+} -match glob -result {*no string representation}
+}
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
@@ -2142,11 +2482,187 @@ test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
+# Note: string-31.* tests use [tcl::string::insert] rather than [string insert]
+# to dodge ticket [3397978fff] which would cause all arguments to be shared,
+# thereby preventing the optimizations from being tested.
+test string-31.1.$noComp {string insert, start of string} {
+ run {tcl::string::insert 0123 0 _}
+} _0123
+test string-31.2.$noComp {string insert, middle of string} {
+ run {tcl::string::insert 0123 2 _}
+} 01_23
+test string-31.3.$noComp {string insert, end of string} {
+ run {tcl::string::insert 0123 4 _}
+} 0123_
+test string-31.4.$noComp {string insert, start of string, end-relative} {
+ run {tcl::string::insert 0123 end-4 _}
+} _0123
+test string-31.5.$noComp {string insert, middle of string, end-relative} {
+ run {tcl::string::insert 0123 end-2 _}
+} 01_23
+test string-31.6.$noComp {string insert, end of string, end-relative} {
+ run {tcl::string::insert 0123 end _}
+} 0123_
+test string-31.7.$noComp {string insert, empty target string} {
+ run {tcl::string::insert {} 0 _}
+} _
+test string-31.8.$noComp {string insert, empty insert string} {
+ run {tcl::string::insert 0123 0 {}}
+} 0123
+test string-31.9.$noComp {string insert, empty strings} {
+ run {tcl::string::insert {} 0 {}}
+} {}
+test string-31.10.$noComp {string insert, negative index} {
+ run {tcl::string::insert 0123 -1 _}
+} _0123
+test string-31.11.$noComp {string insert, index beyond end} {
+ run {tcl::string::insert 0123 5 _}
+} 0123_
+test string-31.12.$noComp {string insert, start of string, pure byte array} {
+ run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]}
+} _0123
+test string-31.13.$noComp {string insert, middle of string, pure byte array} {
+ run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
+} 01_23
+test string-31.14.$noComp {string insert, end of string, pure byte array} {
+ run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]}
+} 0123_
+test string-31.15.$noComp {string insert, pure byte array, neither shared} {
+ run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]}
+} 01_23
+test string-31.16.$noComp {string insert, pure byte array, first shared} {
+ run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
+ [makeByteArray _]}
+} 01_23
+test string-31.17.$noComp {string insert, pure byte array, second shared} {
+ run {tcl::string::insert [makeByteArray 0123] 2\
+ [makeShared [makeByteArray _]]}
+} 01_23
+test string-31.18.$noComp {string insert, pure byte array, both shared} {
+ run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\
+ [makeShared [makeByteArray _]]}
+} 01_23
+test string-31.19.$noComp {string insert, start of string, pure Unicode} {
+ run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]}
+} _0123
+test string-31.20.$noComp {string insert, middle of string, pure Unicode} {
+ run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]}
+} 01_23
+test string-31.21.$noComp {string insert, end of string, pure Unicode} {
+ run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]}
+} 0123_
+test string-31.22.$noComp {string insert, str start, pure Uni, first shared} {
+ run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]}
+} _0123
+test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} {
+ run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]}
+} 01_23
+test string-31.24.$noComp {string insert, string end, pure Uni, both shared} {
+ run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\
+ [makeShared [makeUnicode _]]}
+} 0123_
+test string-31.25.$noComp {string insert, neither byte array nor Unicode} {
+ run {tcl::string::insert [makeList a b c] 1 zzzzzz}
+} {azzzzzz b c}
+test string-31.26.$noComp {[11229bad5f] string insert, compiler} -setup {
+ set i 2
+} -body {
+ run {tcl::string::insert abcd $i xyz}
+} -cleanup {
+ unset i
+} -result abxyzcd
+
+test string-32.1.$noComp {string is dict} {
+ string is dict {a b c d}
+} 1
+test string-32.1a.$noComp {string is dict} {
+ string is dict {a b c}
+} 0
+test string-32.2.$noComp {string is dict} {
+ string is dict "a \{b c"
+} 0
+test string-32.3.$noComp {string is dict} {
+ string is dict {a {b c}d e}
+} 0
+test string-32.4.$noComp {string is dict} {
+ string is dict {}
+} 1
+test string-32.5.$noComp {string is dict} {
+ string is dict -strict {a b c d}
+} 1
+test string-32.5a.$noComp {string is dict} {
+ string is dict -strict {a b c}
+} 0
+test string-32.6.$noComp {string is dict} {
+ string is dict -strict "a \{b c"
+} 0
+test string-32.7.$noComp {string is dict} {
+ string is dict -strict {a {b c}d e}
+} 0
+test string-32.8.$noComp {string is dict} {
+ string is dict -strict {}
+} 1
+test string-32.9.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c d}] $x
+} {1 {}}
+test string-32.9a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c}] $x
+} {0 -1}
+test string-32.10.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c d"] $x
+} {0 2}
+test string-32.10a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c"] $x
+} {0 2}
+test string-32.11.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b {b c}d e}] $x
+} {0 4}
+test string-32.12.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {}] $x
+} {1 {}}
+test string-32.13.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x { {b c}d e}] $x
+} {0 2}
+test string-32.14.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "\uABCD {b c}d e"] $x
+} {0 2}
+test string-32.15.$noComp {string is dict, valid dict} {
+ string is dict {a b c d e f}
+} 1
+test string-32.16.$noComp {string is dict, invalid dict} {
+ string is dict a
+} 0
+test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} {
+ string is dict {{a b c d e f g h}}
+} 0
}; # foreach noComp {0 1}
+
+test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints {
+ testutf16string deprecated
+} -body {
+ # This simple test suffices because the bug has nothing to do with
+ # the actual encoding conversion. The test was added because these
+ # functions are no longer called within the Tcl core and thus
+ # not tested by either `string`, not `encoding` tests.
+ testutf16string "abcde"
+} -result abcde
+
# cleanup
rename MemStress {}
+rename makeByteArray {}
+rename makeUnicode {}
+rename makeList {}
+rename makeShared {}
catch {rename foo {}}
::tcltest::cleanupTests
return
diff --git a/tests/stringComp.test b/tests/stringComp.test
deleted file mode 100644
index 95a738c..0000000
--- a/tests/stringComp.test
+++ /dev/null
@@ -1,801 +0,0 @@
-# Commands covered: string
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# This differs from the original string tests in that the tests call
-# things in procs, which uses the compiled string code instead of
-# the runtime parse string code. The tests of import should match
-# their equivalent number in string.test.
-#
-# Copyright (c) 2001 by ActiveState Corporation.
-# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
-#
-# 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 Tcltest [info patchlevel]]
-
-# Some tests require the testobj command
-
-testConstraint testobj [expr {[info commands testobj] != {}}]
-testConstraint memory [llength [info commands memory]]
-if {[testConstraint memory]} {
- proc getbytes {} {
- set lines [split [memory info] \n]
- return [lindex $lines 3 3]
- }
- proc leaktest {script {iterations 3}} {
- set end [getbytes]
- for {set i 0} {$i < $iterations} {incr i} {
- uplevel 1 $script
- set tmp $end
- set end [getbytes]
- }
- return [expr {$end - $tmp}]
- }
-}
-
-test stringComp-1.1 {error conditions} {
- proc foo {} {string gorp a b}
- list [catch {foo} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
-test stringComp-1.2 {error conditions} {
- proc foo {} {string}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
-test stringComp-1.3 {error condition - undefined method during compile} {
- # We don't want this to complain about 'never' because it may never
- # be called, or string may get redefined. This must compile OK.
- proc foo {str i} {
- if {"yes" == "no"} { string never called but complains here }
- string index $str $i
- }
- foo abc 0
-} a
-
-## Test string compare|equal over equal constraints
-## Use result for string compare, and negate it for string equal
-## The body will be tested both in and outside a proc
-set i 0
-foreach {tname tbody tresult tcode} {
- {too few args} {
- string compare a
- } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
- {bad args} {
- string compare a b c
- } {bad option "a": must be -nocase or -length} {error}
- {bad args} {
- string compare -length -nocase str1 str2
- } {expected integer but got "-nocase"} {error}
- {too many args} {
- string compare -length 10 -nocase str1 str2 str3
- } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
- {compare with length unspecified} {
- string compare -length 10 10
- } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
- {basic operation fail} {
- string compare abcde abdef
- } {-1} {}
- {basic operation success} {
- string compare abcde abcde
- } {0} {}
- {with length} {
- string compare -length 2 abcde abxyz
- } {0} {}
- {with special index} {
- string compare -length end-3 abcde abxyz
- } {expected integer but got "end-3"} {error}
- {unicode} {
- string compare ab\u7266 ab\u7267
- } {-1} {}
- {unicode} {string compare \334 \u00dc} 0 {}
- {unicode} {string compare \334 \u00fc} -1 {}
- {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {}
- {high bit} {
- # This test fails if the underlying comparison
- # is using signed chars instead of unsigned chars.
- # (like SunOS's default memcmp thus the compat/memcmp.c)
- string compare "\x80" "@"
- # Nb this tests works also in utf-8 space because \x80 is
- # translated into a 2 or more bytelength but whose first byte has
- # the high bit set.
- } {1} {}
- {-nocase 1} {string compare -nocase abcde abdef} {-1} {}
- {-nocase 2} {string compare -nocase abcde Abdef} {-1} {}
- {-nocase 3} {string compare -nocase abcde ABCDE} {0} {}
- {-nocase 4} {string compare -nocase abcde abcde} {0} {}
- {-nocase unicode} {
- string compare -nocase \334 \u00dc
- } 0 {}
- {-nocase unicode} {
- string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334
- } 0 {}
- {-nocase with length} {
- string compare -length 2 -nocase abcde Abxyz
- } {0} {}
- {-nocase with length} {
- string compare -nocase -length 3 abcde Abxyz
- } {-1} {}
- {-nocase with length <= 0} {
- string compare -nocase -length -1 abcde AbCdEf
- } {-1} {}
- {-nocase with excessive length} {
- string compare -nocase -length 50 AbCdEf abcde
- } {1} {}
- {-len unicode} {
- # These are strings that are 6 BYTELENGTH long, but the length
- # shouldn't make a different because there are actually 3 CHARS long
- string compare -len 5 \334\334\334 \334\334\374
- } -1 {}
- {-nocase with special index} {
- string compare -nocase -length end-3 Abcde abxyz
- } {expected integer but got "end-3"} error
- {null strings} {
- string compare "" ""
- } 0 {}
- {null strings} {
- string compare "" foo
- } -1 {}
- {null strings} {
- string compare foo ""
- } 1 {}
- {-nocase null strings} {
- string compare -nocase "" ""
- } 0 {}
- {-nocase null strings} {
- string compare -nocase "" foo
- } -1 {}
- {-nocase null strings} {
- string compare -nocase foo ""
- } 1 {}
- {with length, unequal strings, partial first string} {
- string compare -length 2 abc abde
- } 0 {}
- {with length, unequal strings 2, full first string} {
- string compare -length 2 ab abde
- } 0 {}
- {with NUL character vs. other ASCII} {
- # Be careful here, since UTF-8 rep comparison with memcmp() of
- # these puts chars in the wrong order
- string compare \x00 \x01
- } -1 {}
- {high bit} {
- string compare "a\x80" "a@"
- } 1 {}
- {high bit} {
- string compare "a\x00" "a\x01"
- } -1 {}
- {high bit} {
- string compare "\x00\x00" "\x00\x01"
- } -1 {}
- {binary equal} {
- string compare [binary format a100 0] [binary format a100 0]
- } 0 {}
- {binary neq} {
- string compare [binary format a100a 0 1] [binary format a100a 0 0]
- } 1 {}
- {binary neq inequal length} {
- string compare [binary format a20a 0 1] [binary format a100a 0 0]
- } 1 {}
-} {
- if {$tname eq ""} { continue }
- if {$tcode eq ""} { set tcode ok }
- test stringComp-2.[incr i] "string compare, $tname" \
- -body [list eval $tbody] \
- -returnCodes $tcode -result $tresult
- test stringComp-2.[incr i] "string compare bc, $tname" \
- -body "[list proc foo {} $tbody];foo" \
- -returnCodes $tcode -result $tresult
- if {"error" ni $tcode} {
- set tresult [expr {!$tresult}]
- } else {
- set tresult [string map {compare equal} $tresult]
- }
- set tbody [string map {compare equal} $tbody]
- test stringComp-2.[incr i] "string equal, $tname" \
- -body [list eval $tbody] \
- -returnCodes $tcode -result $tresult
- test stringComp-2.[incr i] "string equal bc, $tname" \
- -body "[list proc foo {} $tbody];foo" \
- -returnCodes $tcode -result $tresult
-}
-
-# need a few extra tests short abbr cmd
-test stringComp-3.1 {string compare, shortest method name} {
- proc foo {} {string co abcde ABCDE}
- foo
-} 1
-test stringComp-3.2 {string equal, shortest method name} {
- proc foo {} {string e abcde ABCDE}
- foo
-} 0
-test stringComp-3.3 {string equal -nocase} {
- proc foo {} {string eq -nocase abcde ABCDE}
- foo
-} 1
-
-test stringComp-4.1 {string first, too few args} {
- proc foo {} {string first a}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
-test stringComp-4.2 {string first, bad args} {
- proc foo {} {string first a b c}
- list [catch {foo} msg] $msg
-} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}}
-test stringComp-4.3 {string first, too many args} {
- proc foo {} {string first a b 5 d}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}}
-test stringComp-4.4 {string first} {
- proc foo {} {string first bq abcdefgbcefgbqrs}
- foo
-} 12
-test stringComp-4.5 {string first} {
- proc foo {} {string fir bcd abcdefgbcefgbqrs}
- foo
-} 1
-test stringComp-4.6 {string first} {
- proc foo {} {string f b abcdefgbcefgbqrs}
- foo
-} 1
-test stringComp-4.7 {string first} {
- proc foo {} {string first xxx x123xx345xxx789xxx012}
- foo
-} 9
-test stringComp-4.8 {string first} {
- proc foo {} {string first "" x123xx345xxx789xxx012}
- foo
-} -1
-test stringComp-4.9 {string first, unicode} {
- proc foo {} {string first x abc\u7266x}
- foo
-} 4
-test stringComp-4.10 {string first, unicode} {
- proc foo {} {string first \u7266 abc\u7266x}
- foo
-} 3
-test stringComp-4.11 {string first, start index} {
- proc foo {} {string first \u7266 abc\u7266x 3}
- foo
-} 3
-test stringComp-4.12 {string first, start index} {
- proc foo {} {string first \u7266 abc\u7266x 4}
- foo
-} -1
-test stringComp-4.13 {string first, start index} {
- proc foo {} {string first \u7266 abc\u7266x end-2}
- foo
-} 3
-test stringComp-4.14 {string first, negative start index} {
- proc foo {} {string first b abc -1}
- foo
-} 1
-
-test stringComp-5.1 {string index} {
- proc foo {} {string index}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string index string charIndex"}}
-test stringComp-5.2 {string index} {
- proc foo {} {string index a b c}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string index string charIndex"}}
-test stringComp-5.3 {string index} {
- proc foo {} {string index abcde 0}
- foo
-} a
-test stringComp-5.4 {string index} {
- proc foo {} {string in abcde 4}
- foo
-} e
-test stringComp-5.5 {string index} {
- proc foo {} {string index abcde 5}
- foo
-} {}
-test stringComp-5.6 {string index} {
- proc foo {} {string index abcde -10}
- list [catch {foo} msg] $msg
-} {0 {}}
-test stringComp-5.7 {string index} {
- proc foo {} {string index a xyz}
- list [catch {foo} msg] $msg
-} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}}
-test stringComp-5.8 {string index} {
- proc foo {} {string index abc end}
- foo
-} c
-test stringComp-5.9 {string index} {
- proc foo {} {string index abc end-1}
- foo
-} b
-test stringComp-5.10 {string index, unicode} {
- proc foo {} {string index abc\u7266d 4}
- foo
-} d
-test stringComp-5.11 {string index, unicode} {
- proc foo {} {string index abc\u7266d 3}
- foo
-} \u7266
-test stringComp-5.12 {string index, unicode over char length, under byte length} {
- proc foo {} {string index \334\374\334\374 6}
- foo
-} {}
-test stringComp-5.13 {string index, bytearray object} {
- proc foo {} {string index [binary format a5 fuz] 0}
- foo
-} f
-test stringComp-5.14 {string index, bytearray object} {
- proc foo {} {string index [binary format I* {0x50515253 0x52}] 3}
- foo
-} S
-test stringComp-5.15 {string index, bytearray object} {
- proc foo {} {
- set b [binary format I* {0x50515253 0x52}]
- set i1 [string index $b end-6]
- set i2 [string index $b 1]
- string compare $i1 $i2
- }
- foo
-} 0
-test stringComp-5.16 {string index, bytearray object with string obj shimmering} {
- proc foo {} {
- set str "0123456789\x00 abcdedfghi"
- binary scan $str H* dump
- string compare [string index $str 10] \x00
- }
- foo
-} 0
-test stringComp-5.17 {string index, bad integer} -body {
- proc foo {} {string index "abc" 0o8}
- list [catch {foo} msg] $msg
-} -match glob -result {1 {*invalid octal number*}}
-test stringComp-5.18 {string index, bad integer} -body {
- proc foo {} {string index "abc" end-0o0289}
- list [catch {foo} msg] $msg
-} -match glob -result {1 {*invalid octal number*}}
-test stringComp-5.19 {string index, bytearray object out of bounds} {
- proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
- foo
-} {}
-test stringComp-5.20 {string index, bytearray object out of bounds} {
- proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
- foo
-} {}
-
-
-proc largest_int {} {
- # This will give us what the largest valid int on this machine is,
- # so we can test for overflow properly below on >32 bit systems
- set int 1
- set exp 7; # assume we get at least 8 bits
- while {$int > 0} { set int [expr {1 << [incr exp]}] }
- return [expr {$int-1}]
-}
-
-## string is
-## not yet bc
-
-catch {rename largest_int {}}
-
-## string last
-## not yet bc
-
-## string length
-## not yet bc
-test stringComp-8.1 {string bytelength} {
- proc foo {} {string bytelength}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string bytelength string"}}
-test stringComp-8.2 {string bytelength} {
- proc foo {} {string bytelength a b}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string bytelength string"}}
-test stringComp-8.3 {string bytelength} {
- proc foo {} {string bytelength "\u00c7"}
- foo
-} 2
-test stringComp-8.4 {string bytelength} {
- proc foo {} {string b ""}
- foo
-} 0
-
-## string length
-##
-test stringComp-9.1 {string length} {
- proc foo {} {string length}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string length string"}}
-test stringComp-9.2 {string length} {
- proc foo {} {string length a b}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string length string"}}
-test stringComp-9.3 {string length} {
- proc foo {} {string length "a little string"}
- foo
-} 15
-test stringComp-9.4 {string length} {
- proc foo {} {string le ""}
- foo
-} 0
-test stringComp-9.5 {string length, unicode} {
- proc foo {} {string le "abcd\u7266"}
- foo
-} 5
-test stringComp-9.6 {string length, bytearray object} {
- proc foo {} {string length [binary format a5 foo]}
- foo
-} 5
-test stringComp-9.7 {string length, bytearray object} {
- proc foo {} {string length [binary format I* {0x50515253 0x52}]}
- foo
-} 8
-
-## string map
-## not yet bc
-
-## string match
-##
-test stringComp-11.1 {string match, too few args} {
- proc foo {} {string match a}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
-test stringComp-11.2 {string match, too many args} {
- proc foo {} {string match a b c d}
- list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
-test stringComp-11.3 {string match} {
- proc foo {} {string match abc abc}
- foo
-} 1
-test stringComp-11.4 {string match} {
- proc foo {} {string mat abc abd}
- foo
-} 0
-test stringComp-11.5 {string match} {
- proc foo {} {string match ab*c abc}
- foo
-} 1
-test stringComp-11.6 {string match} {
- proc foo {} {string match ab**c abc}
- foo
-} 1
-test stringComp-11.7 {string match} {
- proc foo {} {string match ab* abcdef}
- foo
-} 1
-test stringComp-11.8 {string match} {
- proc foo {} {string match *c abc}
- foo
-} 1
-test stringComp-11.9 {string match} {
- proc foo {} {string match *3*6*9 0123456789}
- foo
-} 1
-test stringComp-11.10 {string match} {
- proc foo {} {string match *3*6*9 01234567890}
- foo
-} 0
-test stringComp-11.11 {string match} {
- proc foo {} {string match a?c abc}
- foo
-} 1
-test stringComp-11.12 {string match} {
- proc foo {} {string match a??c abc}
- foo
-} 0
-test stringComp-11.13 {string match} {
- proc foo {} {string match ?1??4???8? 0123456789}
- foo
-} 1
-test stringComp-11.14 {string match} {
- proc foo {} {string match {[abc]bc} abc}
- foo
-} 1
-test stringComp-11.15 {string match} {
- proc foo {} {string match {a[abc]c} abc}
- foo
-} 1
-test stringComp-11.16 {string match} {
- proc foo {} {string match {a[xyz]c} abc}
- foo
-} 0
-test stringComp-11.17 {string match} {
- proc foo {} {string match {12[2-7]45} 12345}
- foo
-} 1
-test stringComp-11.18 {string match} {
- proc foo {} {string match {12[ab2-4cd]45} 12345}
- foo
-} 1
-test stringComp-11.19 {string match} {
- proc foo {} {string match {12[ab2-4cd]45} 12b45}
- foo
-} 1
-test stringComp-11.20 {string match} {
- proc foo {} {string match {12[ab2-4cd]45} 12d45}
- foo
-} 1
-test stringComp-11.21 {string match} {
- proc foo {} {string match {12[ab2-4cd]45} 12145}
- foo
-} 0
-test stringComp-11.22 {string match} {
- proc foo {} {string match {12[ab2-4cd]45} 12545}
- foo
-} 0
-test stringComp-11.23 {string match} {
- proc foo {} {string match {a\*b} a*b}
- foo
-} 1
-test stringComp-11.24 {string match} {
- proc foo {} {string match {a\*b} ab}
- foo
-} 0
-test stringComp-11.25 {string match} {
- proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
- foo
-} 1
-test stringComp-11.26 {string match} {
- proc foo {} {string match ** ""}
- foo
-} 1
-test stringComp-11.27 {string match} {
- proc foo {} {string match *. ""}
- foo
-} 0
-test stringComp-11.28 {string match} {
- proc foo {} {string match "" ""}
- foo
-} 1
-test stringComp-11.29 {string match} {
- proc foo {} {string match \[a a}
- foo
-} 1
-test stringComp-11.30 {string match, bad args} {
- proc foo {} {string match - b c}
- list [catch {foo} msg] $msg
-} {1 {bad option "-": must be -nocase}}
-test stringComp-11.31 {string match case} {
- proc foo {} {string match a A}
- foo
-} 0
-test stringComp-11.32 {string match nocase} {
- proc foo {} {string match -n a A}
- foo
-} 1
-test stringComp-11.33 {string match nocase} {
- proc foo {} {string match -nocase a\334 A\374}
- foo
-} 1
-test stringComp-11.34 {string match nocase} {
- proc foo {} {string match -nocase a*f ABCDEf}
- foo
-} 1
-test stringComp-11.35 {string match case, false hope} {
- # This is true because '_' lies between the A-Z and a-z ranges
- proc foo {} {string match {[A-z]} _}
- foo
-} 1
-test stringComp-11.36 {string match nocase range} {
- # This is false because although '_' lies between the A-Z and a-z ranges,
- # we lower case the end points before checking the ranges.
- proc foo {} {string match -nocase {[A-z]} _}
- foo
-} 0
-test stringComp-11.37 {string match nocase} {
- proc foo {} {string match -nocase {[A-fh-Z]} g}
- foo
-} 0
-test stringComp-11.38 {string match case, reverse range} {
- proc foo {} {string match {[A-fh-Z]} g}
- foo
-} 1
-test stringComp-11.39 {string match, *\ case} {
- proc foo {} {string match {*\abc} abc}
- foo
-} 1
-test stringComp-11.40 {string match, *special case} {
- proc foo {} {string match {*[ab]} abc}
- foo
-} 0
-test stringComp-11.41 {string match, *special case} {
- proc foo {} {string match {*[ab]*} abc}
- foo
-} 1
-test stringComp-11.42 {string match, *special case} {
- proc foo {} {string match "*\\" "\\"}
- foo
-} 0
-test stringComp-11.43 {string match, *special case} {
- proc foo {} {string match "*\\\\" "\\"}
- foo
-} 1
-test stringComp-11.44 {string match, *special case} {
- proc foo {} {string match "*???" "12345"}
- foo
-} 1
-test stringComp-11.45 {string match, *special case} {
- proc foo {} {string match "*???" "12"}
- foo
-} 0
-test stringComp-11.46 {string match, *special case} {
- proc foo {} {string match "*\\*" "abc*"}
- foo
-} 1
-test stringComp-11.47 {string match, *special case} {
- proc foo {} {string match "*\\*" "*"}
- foo
-} 1
-test stringComp-11.48 {string match, *special case} {
- proc foo {} {string match "*\\*" "*abc"}
- foo
-} 0
-test stringComp-11.49 {string match, *special case} {
- proc foo {} {string match "?\\*" "a*"}
- foo
-} 1
-test stringComp-11.50 {string match, *special case} {
- proc foo {} {string match "\\" "\\"}
- foo
-} 0
-test stringComp-11.51 {string match; *, -nocase and UTF-8} {
- proc foo {} {string match -nocase [binary format I 717316707] \
- [binary format I 2028036707]}
- foo
-} 1
-test stringComp-11.52 {string match, null char in string} {
- proc foo {} {
- set ptn "*abc*"
- foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
- lappend out [string match $ptn $elem]
- }
- set out
- }
- foo
-} {1 1 1 1}
-test stringComp-11.53 {string match, null char in pattern} {
- proc foo {} {
- set out ""
- foreach {ptn elem} [list \
- "*\u0000abc\u0000" "\u0000abc\u0000" \
- "*\u0000abc\u0000" "\u0000abc\u0000ef" \
- "*\u0000abc\u0000*" "\u0000abc\u0000ef" \
- "*\u0000abc\u0000" "@\u0000abc\u0000ef" \
- "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \
- ] {
- lappend out [string match $ptn $elem]
- }
- set out
- }
- foo
-} {1 0 1 0 1}
-test stringComp-11.54 {string match, failure} {
- proc foo {} {
- set longString ""
- for {set i 0} {$i < 10} {incr i} {
- append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
- }
- list [string match *cba* $longString] \
- [string match *a*l*\u0000* $longString] \
- [string match *a*l*\u0000*123 $longString] \
- [string match *a*l*\u0000*123* $longString] \
- [string match *a*l*\u0000*cba* $longString] \
- [string match *===* $longString]
- }
- foo
-} {0 1 1 1 0 0}
-
-## string range
-test stringComp-12.1 {Bug 3588366: end-offsets before start} {
- apply {s {
- string range $s 0 end-5
- }} 12345
-} {}
-
-## string repeat
-## not yet bc
-
-## string replace
-test stringComp-14.1 {Bug 82e7f67325} {
- apply {x {
- set a [join $x {}]
- lappend b [string length [string replace ___! 0 2 $a]]
- lappend b [string length [string replace ___! 0 2 $a[unset a]]]
- }} {a b}
-} {3 3}
-test stringComp-14.2 {Bug 82e7f67325} memory {
- # As in stringComp-14.1, but make sure we don't retain too many refs
- leaktest {
- apply {x {
- set a [join $x {}]
- lappend b [string length [string replace ___! 0 2 $a]]
- lappend b [string length [string replace ___! 0 2 $a[unset a]]]
- }} {a b}
- }
-} {0}
-test stringComp-14.3 {Bug 0dca3bfa8f} {
- apply {arg {
- set argCopy $arg
- set arg [string replace $arg 1 2 aa]
- # Crashes in comparison before fix
- expr {$arg ne $argCopy}
- }} abcde
-} 1
-test stringComp-14.4 {Bug 1af8de570511} {
- apply {{x y} {
- # Generate an unshared string value
- set val ""
- for { set i 0 } { $i < $x } { incr i } {
- set val [format "0%s" $val]
- }
- string replace $val[unset val] 1 1 $y
- }} 4 x
-} 0x00
-test stringComp-14.5 {} {
- string length [string replace [string repeat a\u00fe 2] 3 end {}]
-} 3
-
-## string tolower
-## not yet bc
-
-## string toupper
-## not yet bc
-
-## string totitle
-## not yet bc
-
-## string trim*
-## not yet bc
-
-## string word*
-## not yet bc
-
-## string cat
-test stringComp-29.1 {string cat, no arg} {
- proc foo {} {string cat}
- foo
-} ""
-test stringComp-29.2 {string cat, single arg} {
- proc foo {} {
- set x FOO
- string compare $x [string cat $x]
- }
- foo
-} 0
-test stringComp-29.3 {string cat, two args} {
- proc foo {} {
- set x FOO
- string compare $x$x [string cat $x $x]
- }
- foo
-} 0
-test stringComp-29.4 {string cat, many args} {
- proc foo {} {
- set x FOO
- set n 260
- set xx [string repeat $x $n]
- set vv [string repeat {$x} $n]
- set vvs [string repeat {$x } $n]
- set r1 [string compare $xx [subst $vv]]
- set r2 [string compare $xx [eval "string cat $vvs"]]
- list $r1 $r2
- }
- foo
-} {0 0}
-
-
-# cleanup
-catch {rename foo {}}
-::tcltest::cleanupTests
-return
-
-# Local Variables:
-# mode: tcl
-# End:
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 2c91546..6fbdc05 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -6,8 +6,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1995-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -18,13 +18,14 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint testobj [llength [info commands testobj]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
-test stringObj-1.1 {string type registration} testobj {
+test stringObj-1.1 {string type registration} {testobj deprecated} {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first >= 0}]
@@ -55,27 +56,27 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob
lappend result [testobj refcount 1]
} {{} 512 foo string 2}
-test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} testobj {
+test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 test
teststringobj setlength 1 3
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {3 4 tes}
+} {3 3 tes}
test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj setlength 1 10
teststringobj length 1
} 10
-test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj {
+test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 abcdef
teststringobj append 1 xyzq -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {10 20 abcdefxyzq}
-test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj {
+} {10 10 abcdefxyzq}
+test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj setlength 1 0
@@ -95,7 +96,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj {
teststringobj append 1 123 -1
teststringobj get 1
} {x y bbCC123}
-test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj {
+test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 xyz
teststringobj setlength 1 15
@@ -107,7 +108,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj {
teststringobj append 1 abcdef -1
lappend result [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {15 15 16 32 xy12345678abcdef}
+} {15 15 16 16 xy12345678abcdef}
test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj {
testobj freeallvars
@@ -133,13 +134,13 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj {
teststringobj appendstrings 1 { 123 } abcdefg
list [teststringobj length 1] [teststringobj get 1]
} {15 {abc 123 abcdefg}}
-test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj {
+test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 123 abcdefg
list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
-} {10 20 123abcdefg}
-test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
+} {10 10 123abcdefg}
+test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
@@ -148,7 +149,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testob
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
} {10 10 ab34567890}
-test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
+test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 abc
teststringobj setlength 1 10
@@ -156,8 +157,8 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testob
teststringobj appendstrings 1 34567890x
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {11 22 ab34567890x}
-test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
+} {11 11 ab34567890x}
+test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
@@ -170,14 +171,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj {
teststringobj get 1
} adcfoobarsoom
-test stringObj-7.1 {SetStringFromAny procedure} testobj {
+test stringObj-7.1 {SetStringFromAny procedure} {testobj deprecated} {
testobj freeallvars
teststringobj set2 1 [list a b]
teststringobj append 1 x -1
list [teststringobj length 1] [teststringobj length2 1] \
[teststringobj get 1]
-} {4 8 {a bx}}
-test stringObj-7.2 {SetStringFromAny procedure, null object} testobj {
+} {4 4 {a bx}}
+test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} {
testobj freeallvars
testobj newobj 1
teststringobj appendstrings 1 {}
@@ -195,7 +196,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj {
[string length $x] [testobj objtype $x]
} {6 string 6 string}
-test stringObj-8.1 {DupStringInternalRep procedure} testobj {
+test stringObj-8.1 {DupStringInternalRep procedure} {testobj deprecated} {
testobj freeallvars
teststringobj set 1 {}
teststringobj append 1 abcde -1
@@ -204,21 +205,21 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj {
[teststringobj maxchars 1] [teststringobj get 1] \
[teststringobj length 2] [teststringobj length2 2] \
[teststringobj maxchars 2] [teststringobj get 2]
-} {5 10 0 abcde 5 5 0 abcde}
+} {5 5 5 abcde 5 5 5 abcde}
test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
string length $x
set y $x
- list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \
+ list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string"
+} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string"
test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} testobj {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
set y $x
string length $x
- list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \
+ list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string"
+} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string"
test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} testobj {
set x abcdefghi
string length $x
@@ -235,31 +236,31 @@ test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj {
} {string string abcdefghijkl abcdefghi string string}
test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
testdstring free
- testdstring append \u00ae\u00bf\u00ef -1
+ testdstring append \xAE\xBF\xEF -1
set y [testdstring get]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string none abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none"
+} "string none abc\xEF\xBF\xAEghi\xAE\xBF\xEF \xAE\xBF\xEF string none"
test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
string length $x
list [testobj objtype $x] [append x $x] [testobj objtype $x] \
[append x $x] [testobj objtype $x]
-} "string abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi string\
-abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi\
+} "string abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi string\
+abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi\
string"
test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} {
set x abcdefghi
testdstring free
- testdstring append \u00ae\u00bf\u00ef -1
+ testdstring append \xAE\xBF\xEF -1
set y [testdstring get]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string none abcdefghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none"
+} "string none abcdefghi\xAE\xBF\xEF \xAE\xBF\xEF string none"
test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} {
set x abcdefghi
testdstring free
@@ -277,14 +278,14 @@ test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj {
} {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\
string}
test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
testdstring free
testdstring append jkl -1
set y [testdstring get]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string none abc\u00ef\u00bf\u00aeghijkl jkl string none"
+} "string none abc\xEF\xBF\xAEghijkl jkl string none"
test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj {
set x [expr {4 * 5}]
set y [expr {4 + 5}]
@@ -305,19 +306,19 @@ test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} testobj {
[set y] [testobj objtype $x] [testobj objtype $y]
} {string int abcdefghi9 9 string int}
test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} testobj {
- set x abc\u00ef\u00bf\u00aeghi
+ set x abc\xEF\xBF\xAEghi
set y [expr {4 + 5}]
string length $x
list [testobj objtype $x] [testobj objtype $y] [append x $y] \
[set y] [testobj objtype $x] [testobj objtype $y]
-} "string int abc\u00ef\u00bf\u00aeghi9 9 string int"
+} "string int abc\xEF\xBF\xAEghi9 9 string int"
test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj {
# bug 2678, in <=8.2.0, the second obj (the one to append) in
# Tcl_AppendObjToObj was not correctly checked to see if it was all one
# byte chars, so a Unicode string would be added as one byte chars.
set x abcdef
set len [string length $x]
- set y a\u00fcb\u00e5c\u00ef
+ set y a\xFCb\xE5c\xEF
set len [string length $y]
append x $y
string length $x
@@ -326,7 +327,7 @@ test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} tes
lappend q [string index $x $i]
}
set q
-} "a b c d e f a \u00fc b \u00e5 c \u00ef"
+} "a b c d e f a \xFC b \xE5 c \xEF"
test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring} {
testdstring free
@@ -336,41 +337,30 @@ test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring
[testobj objtype $x] [testobj objtype $y]
} [list none bcde string string]
test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} {
- # Because this test does not use \uXXXX notation below instead of
- # hard-coding the values, it may fail in multibyte locales. However, we
- # need to test that the parser produces untyped objects even when there
- # are high-ASCII characters in the input (like "ï"). I don't know what
- # else to do but inline those characters here.
testdstring free
- testdstring append "abc\u00ef\u00efdef" -1
+ testdstring append "abcïïdef" -1
set x [testdstring get]
list [testobj objtype $x] [set y [string range $x 1 end-1]] \
[testobj objtype $x] [testobj objtype $y]
-} [list none "bc\u00EF\u00EFde" string string]
+} [list none "bcïïde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
- # set x "abcïïdef"
- # Use \uXXXX notation below instead of hard-coding the values, otherwise
- # the test will fail in multibyte locales.
- set x "abc\u00EF\u00EFdef"
+ set x "abcïïdef"
string length $x
list [testobj objtype $x] [set y [string range $x 1 end-1]] \
[testobj objtype $x] [testobj objtype $y]
-} [list string "bc\u00EF\u00EFde" string string]
+} [list string "bcïïde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj {
- # set a "ïa¿b®cï¿d®"
- # Use \uXXXX notation below instead of hard-coding the values, otherwise
- # the test will fail in multibyte locales.
- set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
+ set a "ïa¿b®cï¿d®"
set result [list]
while {[string length $a] > 0} {
set a [string range $a 1 end-1]
lappend result $a
}
set result
-} [list a\u00BFb\u00AEc\u00EF\u00BFd \
- \u00BFb\u00AEc\u00EF\u00BF \
- b\u00AEc\u00EF \
- \u00AEc \
+} [list a\xBFb\xAEc\xEF\xBFd \
+ \xBFb\xAEc\xEF\xBF \
+ b\xAEc\xEF \
+ \xAEc \
{}]
test stringObj-11.1 {UpdateStringOfString} testobj {
@@ -392,15 +382,15 @@ test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} testobj {
list [string index $x end] [string index $x end-1]
} {i h}
test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} testobj {
- string index "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef" 0
-} "\u00ef"
+ string index "\xEFa\xBFb\xAEc\xAE\xBFd\xEF" 0
+} "\xEF"
test stringObj-12.5 {Tcl_GetUniChar} testobj {
- set x "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef"
+ set x "\xEFa\xBFb\xAEc\xAE\xBFd\xEF"
list [string index $x 4] [string index $x 0]
-} "\u00ae \u00ef"
+} "\xAE \xEF"
test stringObj-12.6 {Tcl_GetUniChar} testobj {
- string index "\u00efa\u00bfb\u00aec\u00ef\u00bfd\u00ae" end
-} "\u00ae"
+ string index "\xEFa\xBFb\xAEc\xEF\xBFd\xAE" end
+} "\xAE"
test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} testobj {
set a ""
@@ -414,19 +404,19 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj {
list [string length $a] [string length $a]
} {6 6}
test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
- string length "\u00ae"
+ string length "\xAE"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
# string length "○○"
# Use \uXXXX notation below instead of hard-coding the values, otherwise
# the test will fail in multibyte locales.
- string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
+ string length "\xEF\xBF\xAE\xEF\xBF\xAE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj {
# set a "ïa¿b®cï¿d®"
# Use \uXXXX notation below instead of hard-coding the values, otherwise
# the test will fail in multibyte locales.
- set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
+ set a "\xEFa\xBFb\xAEc\xEF\xBFd\xAE"
list [string length $a] [string length $a]
} {10 10}
test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
@@ -439,9 +429,9 @@ test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestr
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj {
teststringobj set 1 foo
- teststringobj getunicode 1
+ teststringobj maxchars 1
teststringobj append 1 bar -1
- teststringobj getunicode 1
+ teststringobj maxchars 1
teststringobj append 1 bar -1
teststringobj setlength 1 0
teststringobj append 1 bar -1
@@ -464,53 +454,73 @@ 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 {
+test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} {
teststringobj set 1 foo
teststringobj appendself2 1 0
} foofoo
-test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj {
+test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} {
teststringobj set 1 foo
teststringobj appendself2 1 1
} foooo
-test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj {
+test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} {
teststringobj set 1 foo
teststringobj appendself2 1 2
} fooo
-test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj {
+test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj deprecated} {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
-test stringObj-16.0 {Tcl_GetRange: normal case} testobj {
+test stringObj-16.0 {Tcl_GetRange: normal case} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 1 3
} bcd
-test stringObj-16.1 {Tcl_GetRange: first > end} testobj {
+test stringObj-16.1 {Tcl_GetRange: first > end} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 10 5
} {}
-test stringObj-16.2 {Tcl_GetRange: last > end} testobj {
+test stringObj-16.2 {Tcl_GetRange: last > end} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 3 13
} de
-test stringObj-16.3 {Tcl_GetRange: first = -1} testobj {
+test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 -1 3
} abcd
-test stringObj-16.4 {Tcl_GetRange: last = -1} testobj {
+test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 1 -1
} bcde
-test stringObj-16.5 {Tcl_GetRange: fist = last = -1} testobj {
+test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} {testobj deprecated} {
teststringobj set 1 abcde
teststringobj range 1 -1 -1
} abcde
-test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj {
+test stringObj-16.6 {Tcl_GetRange: old anomaly} {testobj deprecated} {
# Older implementations could return "cde"
teststringobj set 1 abcde
teststringobj range 1 2 0
} {}
-
+test stringObj-16.7 {Tcl_GetRange: first = 0x7FFFFFFF-1} {testobj deprecated} {
+ teststringobj set 1 abcde
+ teststringobj range 1 [expr {0x7FFFFFFF-1}] 3
+} {}
+test stringObj-16.8 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} {
+ teststringobj set 1 abcde
+ teststringobj range 1 1 [expr {0x7FFFFFFF-1}]
+} bcde
+test stringObj-16.9 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} {
+ teststringobj set 1 abcde
+ teststringobj range 1 1 [expr {0x7FFFFFFF - 1}]
+} bcde
+test stringObj-16.10 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} {
+ teststringobj set 1 abcde
+ teststringobj range 1 [expr {0x7FFFFFFF-1}] [expr {0x7FFFFFFF-1}]
+} {}
+test stringObj-16.11 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} {
+ teststringobj set 1 abcde
+ set i [expr {0x7FFFFFFF - 1}]
+ teststringobj range 1 $i $i
+} {}
if {[testConstraint testobj]} {
testobj freeallvars
@@ -519,3 +529,7 @@ if {[testConstraint testobj]} {
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/subst.test b/tests/subst.test
index 8a8b3f1..da59c3b 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -4,19 +4,19 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1994 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright © 1994 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 1998-2000 Ajuba Solutions.
#
# 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.1
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
@@ -48,7 +48,7 @@ test subst-3.2 {backslash substitutions with utf chars} {
# 'j' is just a char that doesn't mean anything, and \344 is 'ä'
# that also doesn't mean anything, but is multi-byte in UTF-8.
list [subst \j] [subst \\j] [subst \\344] [subst \\\344]
-} "j j \344 \344"
+} "j j ä ä"
test subst-4.1 {variable substitutions} {
set a 44
diff --git a/tests/switch.test b/tests/switch.test
index a7211cb..3d106c0 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
diff --git a/tests/tailcall.test b/tests/tailcall.test
index 6b09cde..0016845 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -4,7 +4,7 @@
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
-# Copyright (c) 2008 by Miguel Sofer.
+# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testnrelevels [llength [info commands testnrelevels]]
diff --git a/tests/tcltest.test b/tests/tcltest.test
index d16c76b..114ce30 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -2,8 +2,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2000 Ajuba Solutions
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2000 Ajuba Solutions
# All rights reserved.
# Note that there are several places where the value of
@@ -18,7 +18,7 @@
#
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.1
+ package require tcltest 2.5
namespace import -force ::tcltest::*
}
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index 1a473e9..409a2cc 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -5,14 +5,22 @@ if {[package provide tcltests] ne {}} return
package require tcltest 2.5
namespace import ::tcltest::*
-
-testConstraint exec [llength [info commands exec]]
+testConstraint exec [llength [info commands exec]]
+testConstraint deprecated [expr {![tcl::build-info no-deprecate]}]
+testConstraint debug [tcl::build-info debug]
+testConstraint purify [tcl::build-info purify]
+testConstraint debugpurify [
+ expr {
+ ![tcl::build-info memdebug]
+ && [testConstraint debug]
+ && [testConstraint purify]
+ }]
testConstraint fcopy [llength [info commands fcopy]]
testConstraint fileevent [llength [info commands fileevent]]
-testConstraint thread [
- expr {0 == [catch {package require Thread 2.7-}]}]
+testConstraint thread [expr {![catch {package require Thread 2.7-}]}]
testConstraint notValgrind [expr {![testConstraint valgrind]}]
+
namespace eval ::tcltests {
@@ -26,6 +34,18 @@ namespace eval ::tcltests {
}
+ # Stolen from dict.test
+ proc scriptmemcheck script {
+ set end [lindex [split [memory info] \n] 3 3]
+ for {set i 0} {$i < 5} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [lindex [split [memory info] \n] 3 3]
+ }
+ expr {$end - $tmp}
+ }
+
+
proc tempdir_alternate {} {
close [file tempfile tempfile]
set tmpdir [file dirname $tempfile]
@@ -42,8 +62,59 @@ namespace eval ::tcltests {
error [list {could not create temporary directory}]
}
+ # Generates test cases for 0, min and max number of arguments for a command.
+ # Expected result is as generated by Tcl_WrongNumArgs
+ # Only works if optional arguments come after fixed arguments
+ # E.g.
+ # testnumargs "zipfs mount" "" "?mountpoint? ?zipfile? ?password?"
+ # testnumargs "lappend" "varName" "?value ...?"
+ proc testnumargs {cmd {fixed {}} {optional {}} args} {
+ variable count
+ set minargs [llength $fixed]
+ set maxargs [expr {$minargs + [llength $optional]}]
+ if {[regexp {\.\.\.\??$} [lindex $optional end]]} {
+ unset maxargs; # No upper limit on num of args
+ }
+ set message "wrong # args: should be \"$cmd"
+ if {[llength $fixed]} {
+ append message " $fixed"
+ }
+ if {[llength $optional]} {
+ append message " $optional"
+ }
+ if {[llength $fixed] == 0 && [llength $optional] == 0} {
+ append message " \""
+ } else {
+ append message "\""
+ }
+ set label [join $cmd -]
+ if {$minargs > 0} {
+ set arguments [lrepeat [expr {$minargs-1}] x]
+ test $label-minargs-[incr count($label-minargs)] \
+ "$label no arguments" \
+ -body "$cmd" \
+ -result $message -returnCodes error \
+ {*}$args
+ if {$minargs > 1} {
+ test $label-minargs-[incr count($label-minargs)] \
+ "$label missing arguments" \
+ -body "$cmd $arguments" \
+ -result $message -returnCodes error \
+ {*}$args
+ }
+ }
+ if {[info exists maxargs]} {
+ set arguments [lrepeat [expr {$maxargs+1}] x]
+ test $label-maxargs-[incr count($label-maxargs)] \
+ "$label extra arguments" \
+ -body "$cmd $arguments" \
+ -result $message -returnCodes error \
+ {*}$args
+ }
+ }
+
init
package provide tcltests 0.1
-
}
+
diff --git a/tests/thread.test b/tests/thread.test
index 92f3a06..636d7a8 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -4,13 +4,17 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
#
# 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::*
+}
# when thread::release is used, -wait is passed in order allow the thread to
# be fully finalized, which avoids valgrind "still reachable" reports.
@@ -19,7 +23,7 @@ package require tcltest 2.5
source [file join [file dirname [info script]] tcltests.tcl]
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Some tests require the testthread command
diff --git a/tests/timer.test b/tests/timer.test
index 48d88b6..52c0b8a 100644
--- a/tests/timer.test
+++ b/tests/timer.test
@@ -7,8 +7,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -367,7 +367,7 @@ test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
}
} -body {
set x "hello world"
- after 1 "set x ab\0cd"
+ after 1 "set x ab\x00cd"
after 10
update
string length $x
@@ -378,7 +378,7 @@ test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
}
} -body {
set x "hello world"
- after 1 set x ab\0cd
+ after 1 set x ab\x00cd
after 10
update
string length $x
@@ -389,8 +389,8 @@ test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup
}
} -body {
set x "hello world"
- after 1 set x ab\0cd
- after cancel "set x ab\0ef"
+ after 1 set x ab\x00cd
+ after cancel "set x ab\x00ef"
llength [after info]
} -cleanup {
foreach i [after info] {
@@ -403,8 +403,8 @@ test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup
}
} -body {
set x "hello world"
- after 1 set x ab\0cd
- after cancel set x ab\0ef
+ after 1 set x ab\x00cd
+ after cancel set x ab\x00ef
llength [after info]
} -cleanup {
foreach i [after info] {
@@ -417,7 +417,7 @@ test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
}
} -body {
set x "hello world"
- after idle "set x ab\0cd"
+ after idle "set x ab\x00cd"
update
string length $x
} -result {5}
@@ -427,7 +427,7 @@ test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
}
} -body {
set x "hello world"
- after idle set x ab\0cd
+ after idle set x ab\x00cd
update
string length $x
} -result {5}
@@ -438,7 +438,7 @@ test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup {
} -body {
set x "hello world"
set id junk
- set id [after 10 set x ab\0cd]
+ set id [after 10 set x ab\x00cd]
update
string length [lindex [lindex [after info $id] 0] 2]
} -cleanup {
diff --git a/tests/tm.test b/tests/tm.test
index ed14567..a1959e6 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -3,10 +3,9 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 2004 by Donal K. Fellows.
+# Copyright © 2004 Donal K. Fellows.
# All rights reserved.
-package require Tcl 8.5-
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
@@ -200,7 +199,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
- regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
+ regexp {^(\d+)\.(\d+)} [package provide tcl] - major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
diff --git a/tests/trace.test b/tests/trace.test
index e303e9a..2b16e2f 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,7 +17,9 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
+
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
@@ -871,7 +873,7 @@ test trace-14.4 "trace command, wrong # args errors" {
test trace-14.5 {trace command, invalid option} {
list [catch {trace gorp} msg] $msg
-} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
+} [list 1 "bad option \"gorp\": must be add, info, or remove"]
# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those
@@ -898,19 +900,19 @@ foreach type {variable command execution} err $errs abbvlist $abbvs {
}
rename x {}
-test trace-14.7 {trace command, "trace variable" errors} {
+test trace-14.7 {trace command, "trace variable" errors} deprecated {
list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
-test trace-14.8 {trace command, "trace variable" errors} {
+test trace-14.8 {trace command, "trace variable" errors} deprecated {
list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
-test trace-14.9 {trace command, "trace variable" errors} {
+test trace-14.9 {trace command, "trace variable" errors} deprecated {
list [catch {trace variable x y} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
-test trace-14.10 {trace command, "trace variable" errors} {
+test trace-14.10 {trace command, "trace variable" errors} deprecated {
list [catch {trace variable x y z w} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
-test trace-14.11 {trace command, "trace variable" errors} {
+test trace-14.11 {trace command, "trace variable" errors} deprecated {
list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index 8ac3ccc..09a34dd 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright © 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testchmod [llength [info commands testchmod]]
# File permissions broken on wsl without some "exotic" wsl configuration
@@ -98,7 +98,7 @@ test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup {
cleanup
} -constraints {unix notRoot notWsl} -body {
file mkdir td1/td2/td3
- file attributes td1/td2 -permissions 0o000
+ file attributes td1/td2 -permissions 0
file rename td1/td2/td3 td2
} -returnCodes error -cleanup {
file attributes td1/td2 -permissions 0o755
@@ -112,7 +112,7 @@ test unixFCmd-1.2 {TclpRenameFile: EEXIST} -setup {
file rename td2 td1
} -returnCodes error -cleanup {
cleanup
-} -result {error renaming "td2" to "td1/td2": file already exists}
+} -result {error renaming "td2" to "td1/td2": file exists}
test unixFCmd-1.3 {TclpRenameFile: EINVAL} -setup {
cleanup
} -constraints {unix notRoot} -body {
@@ -225,7 +225,7 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup {
close [open tf1 a]
file attributes tf1 -permissions 0o472
file copy tf1 tf2
- format 0o%03o [file attributes tf2 -permissions]
+ file attributes tf2 -permissions
} -cleanup {
cleanup
} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
@@ -338,15 +338,15 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot notWsl} -body {
close [open foo.test w]
- list [file attributes foo.test -permissions 0o000] \
- [format 0o%03o [file attributes foo.test -permissions]]
+ list [file attributes foo.test -permissions 0] \
+ [file attributes foo.test -permissions]
} -cleanup {
file delete -force -- foo.test
-} -result {{} 0o000}
+} -result {{} 00000}
test unixFCmd-17.2 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
} -constraints {unix notRoot} -returnCodes error -body {
- file attributes foo.test -permissions 0o000
+ file attributes foo.test -permissions 0
} -result {could not set permissions for file "foo.test": no such file or directory}
test unixFCmd-17.3 {SetPermissionsAttribute} -setup {
catch {file delete -force -- foo.test}
@@ -372,16 +372,16 @@ proc permcheck {testnum permList expected} {
set result {}
foreach permstr $permList {
file attributes foo.test -permissions $permstr
- lappend result [format 0o%03o [file attributes foo.test -permissions]]
+ lappend result [file attributes foo.test -permissions]
}
set result
} $expected
}
permcheck unixFCmd-17.5 rwxrwxrwx 0o777
permcheck unixFCmd-17.6 r--r---w- 0o442
-permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {0o000 0o740 0o540 0o547}
+permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547}
permcheck unixFCmd-17.11 --x--x--x 0o111
-permcheck unixFCmd-17.12 {0 a+rwx} {0o000 0o777}
+permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777}
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
@@ -392,7 +392,7 @@ test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
set nd $cd/tstdir
file mkdir $nd
cd $nd
- file attributes $nd -permissions 0o000
+ file attributes $nd -permissions 0
pwd
} -returnCodes error -cleanup {
cd $cd
diff --git a/tests/unixFile.test b/tests/unixFile.test
index 3669cce..e2a634a 100644
--- a/tests/unixFile.test
+++ b/tests/unixFile.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 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.
@@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testfindexecutable [llength [info commands testfindexecutable]]
diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test
index a4270d6..bf22449 100644
--- a/tests/unixForkEvent.test
+++ b/tests/unixForkEvent.test
@@ -2,14 +2,16 @@
# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1997 Sun Microsystems, Inc.
+# Copyright © 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.
-package require tcltest 2.5
-namespace import -force ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
testConstraint testfork [llength [info commands testfork]]
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 5f02031..3a9fa6d 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -4,17 +4,22 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
-package require tcltest 2.5
-namespace import ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
+
+# Some tests require the testgetencpath command
+testConstraint testgetencpath [llength [info commands testgetencpath]]
test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} {
set x {}
@@ -96,7 +101,9 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
} -match regexp -result {^(iso8859-15?|utf-8)$}
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
catch {set oldlc_all $env(LC_ALL)}
-} -constraints {unix stdio} -body {
+ catch {set oldtcl_library $env(TCL_LIBRARY)}
+ unset -nocomplain env(TCL_LIBRARY)
+} -constraints {unix stdio knownBug} -body {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
@@ -114,6 +121,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup {
} -cleanup {
unset -nocomplain env(LANG) env(LC_ALL)
catch {set env(LC_ALL) $oldlc_all}
+ catch {set env(TCL_LIBRARY) $oldtcl_library}
} -result 0
test unixInit-4.1 {TclpSetVariables} {unix} {
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 7d32555..8ab0edb 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -18,16 +18,11 @@ if {"::tcltest" ni [namespace children]} {
# When run in a Tk shell, these tests hang.
testConstraint noTk [expr {0 != [catch {package present Tk}]}]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
-# Darwin always uses a threaded notifier
-testConstraint unthreaded [expr {
- ![::tcl::pkgconfig get threaded]
- && $tcl_platform(os) ne "Darwin"
-}]
# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
-test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body {
+test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body {
catch {vwait x}
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
@@ -38,7 +33,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -
catch { close $f }
catch { removeFile foo }
}
-test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body {
+test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body {
catch {vwait x}
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
diff --git a/tests/unknown.test b/tests/unknown.test
index 7600cba..cb0a7c4 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -4,15 +4,17 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
-package require tcltest 2.5
-namespace import ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
unset -nocomplain x
catch {rename unknown unknown.old}
diff --git a/tests/unload.test b/tests/unload.test
index 0b10492..24b5e8d 100644
--- a/tests/unload.test
+++ b/tests/unload.test
@@ -4,9 +4,9 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1995 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
-# Copyright (c) 2003-2004 Georgios Petasis
+# Copyright © 1995 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2003-2004 Georgios Petasis
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Figure out what extension is used for shared libraries on this
# platform.
@@ -53,22 +53,22 @@ proc loadIfNotPresent {pkg args} {
# Basic tests: parameter testing...
test unload-1.1 {basic errors} -returnCodes error -body {
unload
-} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"}
+} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"}
test unload-1.2 {basic errors} -returnCodes error -body {
unload a b c d
-} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"}
+} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"}
test unload-1.3 {basic errors} -returnCodes error -body {
unload a b foobar
} -result {could not find interpreter "foobar"}
test unload-1.4 {basic errors} -returnCodes error -body {
unload {}
-} -result {must specify either file name or package name}
+} -result {must specify either file name or prefix}
test unload-1.5 {basic errors} -returnCodes error -body {
unload {} {}
-} -result {must specify either file name or package name}
+} -result {must specify either file name or prefix}
test unload-1.6 {basic errors} -returnCodes error -body {
unload {} Unknown
-} -result {package "Unknown" is loaded statically and cannot be unloaded}
+} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded}
test unload-1.7 {-nocomplain switch} {
unload -nocomplain {} Unknown
} {}
@@ -77,22 +77,22 @@ set pkgua_loaded {}
set pkgua_detached {}
set pkgua_unloaded {}
# Tests for loading/unloading in trusted (non-safe) interpreters...
-test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] {
+test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] {
loadIfNotPresent pkga
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
-test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] {
+test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}}
-test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} -setup {
+test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup {
loadIfNotPresent pkga
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkga$ext]
} -result {file "*" cannot be unloaded under a trusted interpreter}
-test unload-2.4 {basic unloading of unloadable package, with guess for package name} -setup {
+test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup {
loadIfNotPresent pkgua
} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
@@ -100,7 +100,7 @@ test unload-2.4 {basic unloading of unloadable package, with guess for package n
[info commands pkgua_*] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} -result {. {} {} {} {} . . .}
-test unload-2.5 {reloading of unloaded package, with guess for package name} -setup {
+test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup {
if {$pkgua_loaded eq ""} {
loadIfNotPresent pkgua
unload [file join $testDir pkgua$ext]
@@ -111,7 +111,7 @@ test unload-2.5 {reloading of unloaded package, with guess for package name} -se
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
-test unload-2.6 {basic unloading of re-loaded package, with guess for package name} -setup {
+test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -setup {
# Establish expected state
if {$pkgua_loaded eq ""} {
loadIfNotPresent pkgua
@@ -132,17 +132,17 @@ child eval {
set pkgua_detached {}
set pkgua_unloaded {}
}
-test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \
+test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \
[list $dll $loaded] {
catch {rename pkgb_sub {}}
load [file join $testDir pkgb$ext] Pkgb child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
-test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \
+test unload-3.2 {basic loading of unloadable package in a safe interpreter} \
[list $dll $loaded] {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
- [load [file join $testDir pkgua$ext] Pkgua child] \
+ [load [file join $testDir pkgua$ext] pkgua child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
@@ -152,14 +152,14 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkga$ext] {} child
} -result {file "*" has never been loaded in this interpreter}
-test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup {
+test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup {
if {[lsearch -index 1 [info loaded child] Pkgb] < 0} {
load [file join $testDir pkgb$ext] Pkgb child
}
} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
unload [file join $testDir pkgb$ext] {} child
} -result {file "*" cannot be unloaded under a safe interpreter}
-test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup {
+test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup {
if {[lsearch -index 1 [info loaded child] Pkgua] < 0} {
load [file join $testDir pkgua$ext] Pkgua child
}
@@ -169,7 +169,7 @@ test unload-3.5 {basic unloading of an unloadable package from a safe interprete
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. {} {}} {} {} {. . .}}
-test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} -setup {
+test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup {
if {[child eval set pkgua_loaded] eq ""} {
load [file join $testDir pkgua$ext] {} child
unload [file join $testDir pkgua$ext] {} child
@@ -181,7 +181,7 @@ test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
-test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} -setup {
+test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup {
if {[child eval set pkgua_loaded] eq ""} {
load [file join $testDir pkgua$ext] {} child
unload [file join $testDir pkgua$ext] {} child
@@ -189,7 +189,7 @@ test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, w
}
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
- [unload [file join $testDir pkgua$ext] Pkgua child] \
+ [unload [file join $testDir pkgua$ext] pKgUa child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{.. . .} {} {} {.. .. ..}}
@@ -203,7 +203,7 @@ child-trusted eval {
}
array set load {M 0 C 0 T 0}
## Load package in main trusted interpreter...
-test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} -setup {
+test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for prefix} -setup {
set pkgua_loaded ""
set pkgua_detached ""
set pkgua_unloaded ""
@@ -215,7 +215,7 @@ test unload-4.1 {loading of unloadable package in trusted interpreter, with gues
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-safe interpreter...
-test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup {
+test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup {
child eval {
set pkgua_loaded ""
set pkgua_detached ""
@@ -224,23 +224,23 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter, with
incr load(C)
} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
- [load [file join $testDir pkgua$ext] Pkgua child] \
+ [load [file join $testDir pkgua$ext] pkgua child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-trusted interpreter...
-test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup {
+test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup {
incr load(T)
} -constraints [list $dll $loaded] -body {
list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
- [load [file join $testDir pkgua$ext] Pkgua child-trusted] \
+ [load [file join $testDir pkgua$ext] pkgua child-trusted] \
[child-trusted eval pkgua_eq abc def] \
[lsort [child-trusted eval info commands pkgua_*]] \
[child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Unload the package from the main trusted interpreter...
-test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} -setup {
+test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup {
if {!$load(M)} {
load [file join $testDir pkgua$ext]
}
@@ -259,7 +259,7 @@ test unload-4.4 {basic unloading of unloadable package from trusted interpreter,
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child safe interpreter...
-test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup {
+test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
if {!$load(C)} {
load [file join $testDir pkgua$ext] {} child
}
@@ -274,7 +274,7 @@ test unload-4.5 {basic unloading of unloadable package from a safe interpreter,
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child trusted interpreter...
-test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup {
+test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
if {!$load(T)} {
load [file join $testDir pkgua$ext] {} child-trusted
}
@@ -291,7 +291,7 @@ test unload-5.1 {unload a module loaded from vfs} \
set dir [pwd]
cd $testDir
testsimplefilesystem 1
- load simplefs:/pkgua$ext Pkgua
+ load simplefs:/pkgua$ext pkgua
} \
-body {
list [catch {unload simplefs:/pkgua$ext} msg] $msg
diff --git a/tests/uplevel.test b/tests/uplevel.test
index fa3be92..de21361 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -147,27 +147,27 @@ test uplevel-4.15 {level parsing} {
test uplevel-4.16 {level parsing} {
apply {{} {uplevel #[expr 1] {}}}
} {}
-test uplevel-4.17 {level parsing} {
+test uplevel-4.17 {level parsing} -returnCodes error -body {
apply {{} {uplevel -0xffffffff {}}}
-} {}
-test uplevel-4.18 {level parsing} {
+} -result {bad level "-0xffffffff"}
+test uplevel-4.18 {level parsing} -returnCodes error -body {
apply {{} {uplevel #-0xffffffff {}}}
-} {}
-test uplevel-4.19 {level parsing} {
+} -result {bad level "#-0xffffffff"}
+test uplevel-4.19 {level parsing} -returnCodes error -body {
apply {{} {uplevel [expr -0xffffffff] {}}}
-} {}
-test uplevel-4.20 {level parsing} {
+} -result {bad level "-4294967295"}
+test uplevel-4.20 {level parsing} -returnCodes error -body {
apply {{} {uplevel #[expr -0xffffffff] {}}}
-} {}
+} -result {bad level "#-4294967295"}
test uplevel-4.21 {level parsing} -body {
apply {{} {uplevel -1 {}}}
-} -returnCodes error -result {invalid command name "-1"}
+} -returnCodes error -result {bad level "-1"}
test uplevel-4.22 {level parsing} -body {
apply {{} {uplevel #-1 {}}}
} -returnCodes error -result {bad level "#-1"}
test uplevel-4.23 {level parsing} -body {
apply {{} {uplevel [expr -1] {}}}
-} -returnCodes error -result {invalid command name "-1"}
+} -returnCodes error -result {bad level "-1"}
test uplevel-4.24 {level parsing} -body {
apply {{} {uplevel #[expr -1] {}}}
} -returnCodes error -result {bad level "#-1"}
@@ -185,13 +185,13 @@ test uplevel-4.28 {level parsing} -body {
} -returnCodes error -result {bad level "#4294967295"}
test uplevel-4.29 {level parsing} -body {
apply {{} {uplevel 0.2 {}}}
-} -returnCodes error -result {bad level "0.2"}
+} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.30 {level parsing} -body {
apply {{} {uplevel #0.2 {}}}
} -returnCodes error -result {bad level "#0.2"}
test uplevel-4.31 {level parsing} -body {
apply {{} {uplevel [expr 0.2] {}}}
-} -returnCodes error -result {bad level "0.2"}
+} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.32 {level parsing} -body {
apply {{} {uplevel #[expr 0.2] {}}}
} -returnCodes error -result {bad level "#0.2"}
@@ -203,7 +203,7 @@ test uplevel-4.34 {level parsing} -body {
} -returnCodes error -result {bad level "#.2"}
test uplevel-4.35 {level parsing} -body {
apply {{} {uplevel [expr .2] {}}}
-} -returnCodes error -result {bad level "0.2"}
+} -returnCodes error -result {invalid command name "0.2"}
test uplevel-4.36 {level parsing} -body {
apply {{} {uplevel #[expr .2] {}}}
} -returnCodes error -result {bad level "#0.2"}
diff --git a/tests/upvar.test b/tests/upvar.test
index 1ba6605..8a1319e 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -4,9 +4,9 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
@@ -249,6 +249,33 @@ test upvar-6.3 {retargeting an upvar} {
p1
} {abcde 44}
+
+
+test upvar-6.4 {
+ retargeting a variable created by upvar to itself is allowed
+} -body {
+ catch {
+ unset x
+ }
+ catch {
+ unset y
+ }
+ set res {}
+ set x abcde
+ set res [catch {
+ upvar 0 x x
+ } cres copts]
+ lappend res [dict get $copts -errorcode]
+ upvar 0 x y
+ lappend res $y
+ upvar 0 y y
+ lappend res $y
+ return $res
+} -cleanup {
+ upvar 0 {} y
+} -result {1 {TCL UPVAR SELF} abcde abcde}
+
+
test upvar-7.1 {upvar to same level} {
set x 44
set y 55
diff --git a/tests/utf.test b/tests/utf.test
index c9abb08..0b639d8 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -2,8 +2,8 @@
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -14,18 +14,9 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
-testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
-testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
-testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}]
-testConstraint utf32 [expr {[testConstraint fullutf]
- && [string length [format %c 0x10000]] == 1}]
-
-testConstraint Uesc [expr {"\U0041" eq "A"}]
-testConstraint pre388 [expr {"\x741" eq "A"}]
-testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]]
- && [string length [teststringbytes \uD83D\uDCA9]] == 4}]
+source [file join [file dirname [info script]] tcltests.tcl]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testfindfirst [llength [info commands testfindfirst]]
@@ -50,7 +41,7 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\xE0" eq [testbytestring \xC3\xA0]}
} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
- expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]}
+ expr {"乎" eq [testbytestring \xE4\xB9\x8E]}
} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]}
@@ -58,12 +49,9 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]}
} 1
-test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf testbytestring} {
+test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 1
-test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {Uesc ucs2 testbytestring} {
- expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
-} 0
test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {"\uD842" eq [testbytestring \xED\xA1\x82]}
} 1
@@ -76,15 +64,31 @@ test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring
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} {
+test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
-test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} {
- expr {"\UD842" eq "\uD842"}
-} 1
-test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} {
+test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {testbytestring} {
expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]}
} 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
+ return $hi\uDE02
+} \uD83D\uDE02
+test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
+ set lo [testbytestring \x80]
+ string length [testbytestring \xC0]$lo
+} 2
+test utf-1.17 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
+ set hi [testbytestring \xC0]
+ string length $hi[testbytestring \x80]
+} 2
+test utf-1.18 {Tcl_UniCharToUtf: surrogate pairs from concat} {
+ string cat \uD83D \uDE02
+} \uD83D\uDE02
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
@@ -107,22 +111,10 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring \xE4\xB9\x8E]
} 1
-test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} {
- string length [testbytestring \xF0\x90\x80\x80]
-} 2
-test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 {
- string length \U010000
-} 2
-test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 {
- string length \U010000
+test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {
+ string length 𐀀
} 1
-test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} {
- string length [testbytestring \xF4\x8F\xBF\xBF]
-} 2
-test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 {
- string length \U10FFFF
-} 2
-test utf-2.9.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf32 {
+test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {
string length \U10FFFF
} 1
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
@@ -173,12 +165,9 @@ test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars t
test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1
} 3
-test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} {
+test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring deprecated} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 2
-test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring utf32} {
- testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
-} 1
test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} {
testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end
} 8
@@ -225,10 +214,7 @@ test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0]G
} 1
-test utf-6.11.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\x00]
-} 1
-test utf-6.11.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} {
@@ -285,19 +271,13 @@ test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF8]
} 1
-test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2]
-} 1
-test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.30 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\x00]
} 1
test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2]G
} 1
-test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0]
-} 1
-test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.32 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\x00]
} 1
test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} {
@@ -355,7 +335,7 @@ test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0]G
} 1
test utf-6.51 {Tcl_UtfNext} testutfnext {
- testutfnext \u8820
+ testutfnext 蠠
} 3
test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xD0]
@@ -388,30 +368,27 @@ test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF8]
} 1
test utf-6.62 {Tcl_UtfNext} testutfnext {
- testutfnext \u8820G
+ testutfnext 蠠G
} 3
test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xA0\xA0]
} 3
test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xD0]
+ testutfnext 蠠[testbytestring \xD0]
} 3
test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xE8]
+ testutfnext 蠠[testbytestring \xE8]
} 3
test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xF2]
+ testutfnext 蠠[testbytestring \xF2]
} 3
test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xF8]
+ testutfnext 蠠[testbytestring \xF8]
} 3
test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0]G
} 1
-test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]
-} 1
-test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.69 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 4
test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} {
@@ -426,40 +403,22 @@ test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} {
test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF8]
} 1
-test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
-} 1
-test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.74 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 4
-test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
-} 1
-test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.75 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 4
-test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
-} 1
-test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.76 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 4
-test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
-} 1
-test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.77 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 4
-test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
-} 1
-test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.78 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 4
-test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
-} 1
-test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} {
+test utf-6.79 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 4
test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext {
@@ -483,177 +442,32 @@ test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x80\x80\x80]
} 1
-test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF0\x90\x80\x80]
-} 1
-test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring fullutf} {
+test utf-6.87 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 4
-test utf-6.88.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\x00]
-} 1
-test utf-6.88.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring fullutf} {
+test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
-test utf-6.89.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \x80\x80\x00]
-} 1
-test utf-6.89.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring fullutf} {
+test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x00]
} 2
-test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF4\x8F\xBF\xBF]
-} 1
-test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring fullutf} {
+test utf-6.90 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 4
test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
testutfnext [testbytestring \xF4\x90\x80\x80]
} 1
-test utf-6.92.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0]
-} 1
-test utf-6.92.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring fullutf} {
+test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0]
} 3
-test utf-6.93.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \x80\x80\x80]
-} 1
-test utf-6.93.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring fullutf} {
+test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80]
} 3
-test utf-6.94.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0]
-} 1
-test utf-6.94.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} {
+test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0\xA0]
} 3
-test utf-6.95.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} {
+test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80\x80]
-} 1
-test utf-6.95.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \x80\x80\x80\x80]
-} 3
-test utf-6.96 {Tcl_UtfNext, read limits} testutfnext {
- testutfnext G 0
-} 0
-test utf-6.97 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0] 0
-} 0
-test utf-6.98 {Tcl_UtfNext, read limits} testutfnext {
- testutfnext AG 1
-} 1
-test utf-6.99 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext A[testbytestring \xA0] 1
-} 1
-test utf-6.100 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xD0\xA0]G 1
-} 0
-test utf-6.101 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xD0\xA0]G 2
-} 2
-test utf-6.102 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xD0\xA0\xA0] 1
-} 0
-test utf-6.103 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xD0\xA0\xA0] 2
-} 2
-test utf-6.104 {Tcl_UtfNext, read limits} testutfnext {
- testutfnext \u8820G 1
-} 0
-test utf-6.105 {Tcl_UtfNext, read limits} testutfnext {
- testutfnext \u8820G 2
-} 0
-test utf-6.106 {Tcl_UtfNext, read limits} testutfnext {
- testutfnext \u8820G 3
-} 3
-test utf-6.107 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xA0] 1
-} 0
-test utf-6.108 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xA0] 2
-} 0
-test utf-6.109 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext \u8820[testbytestring \xA0] 3
-} 3
-# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext
-test utf-6.110 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 1
-} 0
-# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext
-test utf-6.111 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 2
-} 0
-test utf-6.112.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3
-} 1
-test utf-6.112.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 3
-} 0
-test utf-6.113.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4
-} 1
-test utf-6.113.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0]G 4
-} 4
-# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext
-test utf-6.114 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 1
-} 0
-# This testcase actually tests Tcl_UtfCharComplete, not Tcl_UtfNext
-test utf-6.115 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 2
-} 0
-test utf-6.116.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3
-} 1
-test utf-6.116.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 3
-} 0
-test utf-6.117.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4
-} 1
-test utf-6.117.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] 4
-} 4
-test utf-6.118 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0]G 0
-} 0
-test utf-6.119 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0]G 1
-} 0
-test utf-6.120 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0] 1
-} 0
-test utf-6.121 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0]G 2
-} 0
-test utf-6.122 {Tcl_UtfNext, read limits} {testutfnext testbytestring} {
- testutfnext [testbytestring \xA0\xA0\xA0] 2
-} 0
-test utf-6.123.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0]G 3
-} 1
-test utf-6.123.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xA0\xA0\xA0]G 3
-} 3
-test utf-6.124.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3
-} 1
-test utf-6.124.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0] 3
-} 3
-test utf-6.125.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4
-} 1
-test utf-6.125.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0]G 4
-} 3
-test utf-6.126.0 {Tcl_UtfNext, read limits} {testutfnext testbytestring ucs2} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4
-} 1
-test utf-6.126.1 {Tcl_UtfNext, read limits} {testutfnext testbytestring fullutf} {
- testutfnext [testbytestring \xA0\xA0\xA0\xA0\xA0] 4
} 3
test utf-7.1 {Tcl_UtfPrev} testutfprev {
@@ -719,22 +533,13 @@ test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3
} 2
-test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0]
-} 2
-test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0]
} 1
-test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
-} 2
-test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 1
-test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
-} 2
-test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 1
test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} {
@@ -776,32 +581,23 @@ test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4
} 3
-test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0\xA0]
-} 3
-test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 1
-test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
-} 3
-test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 1
-test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
-} 3
-test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 1
test utf-7.16 {Tcl_UtfPrev} testutfprev {
- testutfprev A\u8820
+ testutfprev A蠠
} 1
test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xA0\xA0] 4
} 1
test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
- testutfprev A\u8820[testbytestring \xF8] 4
+ testutfprev A蠠[testbytestring \xF8] 4
} 1
test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0]
@@ -824,10 +620,7 @@ test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev [testbytestring A\xF8\xA0\xA0\xA0]
} 4
-test utf-7.20.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
- testutfprev [testbytestring A\xF2\xA0\xA0\xA0]
-} 4
-test utf-7.20.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
+test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev [testbytestring A\xF2\xA0\xA0\xA0]
} 1
test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring} {
@@ -890,22 +683,13 @@ test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 2
} 1
-test utf-7.39.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF0\x90\x80\x80]
-} 4
-test utf-7.39.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
+test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80]
} 1
-test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF0\x90\x80\x80] 4
-} 3
-test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
+test utf-7.40 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 1
-test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF0\x90\x80\x80] 3
-} 2
-test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
+test utf-7.41 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 1
test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
@@ -927,33 +711,24 @@ test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {test
testutfprev [testbytestring \xE8\xA0]
} 0
test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev {
- testutfprev \u8820 2
+ testutfprev 蠠 2
} 0
test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0\x00] 2
} 0
-test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
-} 4
-test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
+test utf-7.48 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
} 1
-test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
-} 3
-test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
+test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 1
-test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
- testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
-} 2
-test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
+test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 1
-test utf-7.48.6 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
+test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2
} 1
-test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
+test utf-7.49 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80]
} 4
test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
@@ -970,141 +745,63 @@ test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} a
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
- string index \u4E4E\u25A 0
-} \u4E4E
+ string index 乎ɚ 0
+} 乎
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} c
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
- string index \u4E4E\u25A\xFF\u543 2
-} \xFF
-test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
- string index \uD842 0
-} \uD842
-test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} utf32 {
- string index \uD842 0
-} \uD842
-test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 {
+ string index 乎ɚÿՃ 2
+} ÿ
+test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} {
string index \uD842 0
} \uD842
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \uDC42 0
} \uDC42
-test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
- string index \uD83D\uDE00G 0
-} \uD83D
-test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 0
-} \U1F600
-test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 0
-} \U1F600
-test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
- string index \uD83D\uDE00G 1
-} \uDE00
-test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 1
-} G
-test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 1
-} {}
-test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
- string index \uD83D\uDE00G 2
+test utf-8.7 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 0
+} 😀
+test utf-8.8 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 1
} G
-test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 2
+test utf-8.9 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 2
} {}
-test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 2
+test utf-8.10 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 0
+} 😀
+test utf-8.11 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 1
} G
-test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
- string index \U1F600G 0
-} \uFFFD
-test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 0
-} \U1F600
-test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 0
-} \U1F600
-test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
- string index \U1F600G 1
-} G
-test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 1
-} G
-test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 1
-} {}
-test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
- string index \U1F600G 2
-} {}
-test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} utf32 {
- string index \U1F600G 2
+test utf-8.12 {Tcl_UniCharAtIndex: Emoji} {
+ string index 😀G 2
} {}
-test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
- string index \U1F600G 2
-} G
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} abc
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
- string range \u4E4E\u25A\xFF\u543klmnop 1 5
-} \u25A\xFF\u543kl
-test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 {
- string range \uD83D\uDE00G 0 0
-} \uD83D
-test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} utf32 {
- string range \U1F600G 0 0
-} \U1F600
-test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
- string range \U1F600G 0 0
-} \U1F600
-test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
- string range \uD83D\uDE00G 1 1
-} \uDE00
-test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 1 1
-} G
-test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 1 1
-} {}
-test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
- string range \uD83D\uDE00G 2 2
+ string range 乎ɚÿՃklmnop 1 5
+} ɚÿՃkl
+test utf-9.3 {Tcl_UtfAtIndex: index = 0, Emoji} {
+ string range 😀G 0 0
+} 😀
+test utf-9.4 {Tcl_UtfAtIndex: index > 0, Emoji} {
+ string range 😀G 1 1
} G
-test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 2 2
+test utf-9.5 {Tcl_UtfAtIndex: index > 0, Emoji} {
+ string range 😀G 2 2
} {}
-test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 2 2
-} G
-test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} {
- string range \U1F600G 0 0
-} \uFFFD
-test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} utf32 {
- string range \U1F600G 0 0
-} \U1F600
-test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
- string range \U1F600G 0 0
-} \U1F600
-test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
- string range \U1F600G 1 1
+test utf-9.6 {Tcl_UtfAtIndex: index = 0, Emoji} {
+ string range 😀G 0 0
+} 😀
+test utf-9.7 {Tcl_UtfAtIndex: index > 0, Emoji} {
+ string range 😀G 1 1
} G
-test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 1 1
-} G
-test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 1 1
-} {}
-test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
- string range \U1F600G 2 2
+test utf-9.8 {Tcl_UtfAtIndex: index > 0, Emoji} {
+ string range 😀G 2 2
} {}
-test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} utf32 {
- string range \U1F600G 2 2
-} {}
-test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
- string range \U1F600G 2 2
-} G
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
@@ -1122,10 +819,10 @@ test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"}
} 1
-test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {fullutf testbytestring} {
+test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {testbytestring} {
expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"}
} 1
-test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {fullutf testbytestring} {
+test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {testbytestring} {
expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"}
} 1
@@ -1166,8 +863,7 @@ bsCheck \x 120
bsCheck \xa 10
bsCheck \xA 10
bsCheck \x41 65
-bsCheck \x541 65 pre388 ;# == \x41
-bsCheck \x541 84 !pre388 ;# == \x54 1
+bsCheck \x541 84
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
@@ -1176,25 +872,24 @@ bsCheck \uA 10
bsCheck \340 224
bsCheck \uA1 161
bsCheck \u4E21 20001
-bsCheck \741 225 pre388 ;# == \341
-bsCheck \741 60 !pre388 ;# == \74 1
+bsCheck \741 60
bsCheck \U 85
bsCheck \Uk 85
-bsCheck \U41 65 Uesc
-bsCheck \Ua 10 Uesc
-bsCheck \UA 10 Uesc
-bsCheck \UA1 161 Uesc
-bsCheck \U4E21 20001 Uesc
-bsCheck \U004E21 20001 Uesc
-bsCheck \U00004E21 20001 Uesc
-bsCheck \U0000004E21 78 Uesc
-bsCheck \U00110000 69632 fullutf
-bsCheck \U01100000 69632 fullutf
-bsCheck \U11000000 69632 fullutf
-bsCheck \U0010FFFF 1114111 fullutf
-bsCheck \U010FFFF0 1114111 fullutf
-bsCheck \U10FFFF00 1114111 fullutf
-bsCheck \UFFFFFFFF 1048575 fullutf
+bsCheck \U41 65
+bsCheck \Ua 10
+bsCheck \UA 10
+bsCheck \UA1 161
+bsCheck \U4E21 20001
+bsCheck \U004E21 20001
+bsCheck \U00004E21 20001
+bsCheck \U0000004E21 78
+bsCheck \U00110000 69632
+bsCheck \U01100000 69632
+bsCheck \U11000000 69632
+bsCheck \U0010FFFF 1114111
+bsCheck \U010FFFF0 1114111
+bsCheck \U10FFFF00 1114111
+bsCheck \UFFFFFFFF 1048575
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
@@ -1206,17 +901,17 @@ test utf-11.3 {Tcl_UtfToUpper} {
string toupper \xE3gh
} \xC3GH
test utf-11.4 {Tcl_UtfToUpper} {
- string toupper \u01E3gh
-} \u01E2GH
+ string toupper ǣgh
+} ǢGH
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
- string toupper \u10D0\u1C90
-} \u1C90\u1C90
-test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
- string toupper \U10428
-} \U10400
-test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
- string toupper \uD801\uDC28
-} \uD801\uDC00
+ string toupper აᲐ
+} ᲐᲐ
+test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {
+ string toupper 𐐨
+} 𐐀
+test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} {
+ string toupper 𐐨
+} 𐐀
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \uDC24\uD824
} \uDC24\uD824
@@ -1228,23 +923,23 @@ test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
- string tolower \xC3GH
-} \xE3gh
+ string tolower ÃGH
+} ãgh
test utf-12.4 {Tcl_UtfToLower} {
- string tolower \u01E2GH
-} \u01E3gh
+ string tolower ǢGH
+} ǣgh
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
- string tolower \u10D0\u1C90
-} \u10D0\u10D0
+ string tolower აᲐ
+} აა
test utf-12.6 {Tcl_UtfToLower low/high surrogate)} {
string tolower \uDC24\uD824
} \uDC24\uD824
-test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} fullutf {
- string tolower \U10400
-} \U10428
-test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
- string tolower \uD801\uDC00
-} \uD801\uDC28
+test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {
+ string tolower 𐐀
+} 𐐨
+test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} {
+ string tolower 𐐀
+} 𐐨
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
@@ -1253,26 +948,26 @@ test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
- string totitle \xE3GH
-} \xC3gh
+ string totitle ãGH
+} Ãgh
test utf-13.4 {Tcl_UtfToTitle} {
- string totitle \u01F3AB
-} \u01F2ab
+ string totitle dzAB
+} Dzab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
- string totitle \u10D0\u1C90
-} \u10D0\u1C90
+ string totitle აᲐ
+} აᲐ
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
- string totitle \u1C90\u10D0
-} \u1C90\u10D0
+ string totitle Აა
+} Აა
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} {
string totitle \uDC24\uD824
} \uDC24\uD824
-test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
- string totitle \U10428\U10400
-} \U10400\U10428
-test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
- string totitle \uD801\uDC28\uD801\uDC00
-} \uD801\uDC00\uD801\uDC28
+test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {
+ string totitle 𐐨𐐀
+} 𐐀𐐨
+test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} {
+ string totitle 𐐨𐐀
+} 𐐀𐐨
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
@@ -1291,8 +986,8 @@ test utf-15.1 {Tcl_UniCharToUpper, negative delta} {
string toupper aA
} AA
test utf-15.2 {Tcl_UniCharToUpper, positive delta} {
- string toupper \u0178\xFF
-} \u0178\u0178
+ string toupper Ÿÿ
+} ŸŸ
test utf-15.3 {Tcl_UniCharToUpper, no delta} {
string toupper !
} !
@@ -1301,25 +996,25 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
- string tolower \u0178\xFF\uA78D\u01C5
-} \xFF\xFF\u0265\u01C6
+ string tolower ŸÿꞍDž
+} ÿÿɥdž
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
test utf-18.1 {Tcl_UniCharToTitle, add one for title} {
- string totitle \u01C4
-} \u01C5
+ string totitle DŽ
+} Dž
test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} {
- string totitle \u01C6
-} \u01C5
+ string totitle dž
+} Dž
test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} {
- string totitle \u017F
-} \x53
+ string totitle ſ
+} S
test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} {
- string totitle \xFF
-} \u0178
+ string totitle ÿ
+} Ÿ
test utf-18.5 {Tcl_UniCharToTitle, no delta} {
string totitle !
} !
@@ -1330,7 +1025,7 @@ test utf-19.1 {TclUniCharLen} -body {
unset -nocomplain foo
} -result {1 4}
-test utf-20.1 {TclUniCharNcmp} utf32 {
+test utf-20.1 {TclUniCharNcmp} {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
@@ -1345,23 +1040,23 @@ test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
test utf-21.1 {TclUniCharIsAlnum} {
# this returns 1 with Unicode 7 compliance
- string is alnum \u1040\u021F\u0220
+ string is alnum ၀ȟȠ
} 1
test utf-21.2 {unicode alnum char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
- list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F]
+ list [regexp {^[[:alnum:]]+$} ၀ȟȠ] [regexp {^\w+$} ၀ȟȠ_‿⁀⁔︳︴﹍﹎﹏_]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
- regexp {^[[:print:]]+$} \uFBC1
+ regexp {^[[:print:]]+$} ﯁
} 1
test utf-21.4 {TclUniCharIsGraph} {
# [Bug 3464428]
- string is graph \u0120
+ string is graph Ġ
} 1
test utf-21.5 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
- regexp {^[[:graph:]]+$} \u0120
+ regexp {^[[:graph:]]+$} Ġ
} 1
test utf-21.6 {TclUniCharIsGraph} {
# [Bug 3464428]
@@ -1396,25 +1091,25 @@ test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
} 10
test utf-22.2 {TclUniCharIsWordChar} {
- string wordend "x\u5080z123_bar\u203C fg" 0
+ string wordend "x傀z123_bar‼ fg" 0
} 10
test utf-23.1 {TclUniCharIsAlpha} {
# this returns 1 with Unicode 7 compliance
- string is alpha \u021F\u0220\u037F\u052F
+ string is alpha ȟȠͿԯ
} 1
test utf-23.2 {unicode alpha char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
- regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F
+ regexp {^[[:alpha:]]+$} ȟȠͿԯ
} 1
test utf-24.1 {TclUniCharIsDigit} {
# this returns 1 with Unicode 7 compliance
- string is digit \u1040\uABF0
+ string is digit ၀꯰
} 1
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
- list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0]
+ list [regexp {^[[:digit:]]+$} ၀꯰] [regexp {^\d+$} ၀꯰]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
@@ -1443,8 +1138,8 @@ proc UniCharCaseCmpTest {order one two {constraints {}}} {
} -body {
teststringobj set 1 $one
teststringobj set 2 $two
- teststringobj getunicode 1
- teststringobj getunicode 2
+ teststringobj maxchars 1
+ teststringobj maxchars 2
set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]]
if {$result eq [string map {< -1 = 0 > 1} $order]} {
set result ok
@@ -1460,10 +1155,10 @@ UniCharCaseCmpTest < a b
UniCharCaseCmpTest > b a
UniCharCaseCmpTest > B a
UniCharCaseCmpTest > aBcB abca
-UniCharCaseCmpTest < \uFFFF [format %c 0x10000] utf32
-UniCharCaseCmpTest < \uFFFF \U10000 utf32
-UniCharCaseCmpTest > [format %c 0x10000] \uFFFF utf32
-UniCharCaseCmpTest > \U10000 \uFFFF utf32
+UniCharCaseCmpTest < \uFFFF [format %c 0x10000]
+UniCharCaseCmpTest < \uFFFF \U10000
+UniCharCaseCmpTest > [format %c 0x10000] \uFFFF
+UniCharCaseCmpTest > \U10000 \uFFFF
test utf-26.1 {Tcl_UniCharDString} -setup {
@@ -1472,7 +1167,7 @@ test utf-26.1 {Tcl_UniCharDString} -setup {
testobj freeallvars
} -body {
teststringobj set 1 foo
- teststringobj getunicode 1
+ teststringobj maxchars 1
teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10
scan [string index [teststringobj get 1] 11] %c
} -result 128
@@ -1490,7 +1185,7 @@ proc GetUniCharTest {s index result} {
incr count
}
variable count 1
-set errorIndicator [expr 0xFFFD]; # Decimalize U+FFFD
+set errorIndicator -1
GetUniCharTest abcd -2 $errorIndicator
GetUniCharTest abcd -1 $errorIndicator
GetUniCharTest abcd 0 97 ;# a -> ASCII 97
diff --git a/tests/utfext.test b/tests/utfext.test
new file mode 100644
index 0000000..d2da50b
--- /dev/null
+++ b/tests/utfext.test
@@ -0,0 +1,90 @@
+# This file contains a collection of tests for Tcl_UtfToExternal and
+# Tcl_UtfToExternal. Sourcing this file into Tcl runs the tests and generates
+# errors. No output means no errors found.
+#
+# Copyright (c) 2023 Ashok P. Nadkarni
+#
+# 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]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint testencoding [llength [info commands testencoding]]
+
+# Maps encoded bytes string to utf-8 equivalents, both in hex
+# encoding utf-8 encdata
+lappend utfExtMap {*}{
+ ascii 414243 414243
+}
+
+# Simple test with basic flags
+proc testbasic {direction enc hexin hexout {flags {start end}}} {
+ if {$direction eq "toutf"} {
+ set cmd Tcl_ExternalToUtf
+ } else {
+ set cmd Tcl_UtfToExternal
+ }
+ set in [binary decode hex $hexin]
+ set out [binary decode hex $hexout]
+ set dstlen 40 ;# Should be enough for all encoding tests
+
+ # The C wrapper fills entire destination buffer with FF.
+ # Anything beyond expected output should have FF's
+ set filler [string repeat \xFF $dstlen]
+ set result [string range "$out$filler" 0 $dstlen-1]
+ test $cmd-$enc-$hexin-[join $flags -] "$cmd - $enc - $hexin - $flags" -body \
+ [list testencoding $cmd $enc $in $flags {} $dstlen] \
+ -result [list ok {} $result] -constraints testencoding
+ foreach profile [encoding profiles] {
+ set flags2 [linsert $flags end profile$profile]
+ test $cmd-$enc-$hexin-[join $flags2 -] "$cmd - $enc - $hexin - $flags" -body \
+ [list testencoding $cmd $enc $in $flags2 {} $dstlen] \
+ -result [list ok {} $result] -constraints testencoding
+ }
+}
+
+#
+# Basic tests
+foreach {enc utfhex hex} $utfExtMap {
+ # Basic test - TCL_ENCODING_START|TCL_ENCODING_END
+ # Note by default output should be terminated with \0
+ testbasic toutf $enc $hex ${utfhex}00 {start end}
+ testbasic fromutf $enc $utfhex ${hex}00 {start end}
+
+ # Test TCL_ENCODING_NO_TERMINATE
+ testbasic toutf $enc $hex $utfhex {start end noterminate}
+ # knownBug - noterminate not obeyed by fromutf
+ # testbasic fromutf $enc $utfhex $hex {start end noterminate}
+}
+
+# Test for insufficient space
+test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body {
+ testencoding Tcl_UtfToExternal ucs-2 A {start end} {} 1
+} -result [list nospace {} \xFF] -constraints testencoding
+
+# Another bug - char limit not obeyed
+# % set cv 2
+# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
+# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
+
+test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body {
+ set src \x82\x4f\x82\x50\x82
+ lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf
+ set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+ lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding
+
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/util.test b/tests/util.test
index 11ee3fa..c3b9f2d 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -1,8 +1,8 @@
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
-# Copyright (c) 1995-1998 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1995-1998 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -13,13 +13,17 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint controversialNaN 1
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
+testConstraint testprint [llength [info commands testprint]]
+
+testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}]
+
# Big test for correct ordering of data in [expr]
@@ -29,9 +33,9 @@ proc testIEEE {} {
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
# little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \
ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \
ieeeValues(-Normal)
binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
ieeeValues(-Subnormal)
@@ -41,23 +45,23 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \
ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \
ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \
ieeeValues(NaN)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \
+ binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \
ieeeValues(-NaN)
- binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \
+ binary scan \xEF\xCD\xAB\x89\x67\x45\xFB\xFF d \
ieeeValues(-NaN(3456789abcdef))
set ieeeValues(littleEndian) 1
return 1
}
{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Normal)
binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-Subnormal)
@@ -67,15 +71,15 @@ proc testIEEE {} {
ieeeValues(+0)
binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \
ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(NaN)
- binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \
+ binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \
ieeeValues(-NaN)
- binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \
+ binary scan \xFF\xFB\x45\x67\x89\xAB\xCD\xEF d \
ieeeValues(-NaN(3456789abcdef))
set ieeeValues(littleEndian) 0
return 1
@@ -203,9 +207,9 @@ test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a { } c
} {a c}
test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} {
- # Check for Bug #227512. If this violates C isspace, then it returns \xc3.
- concat \xe0
-} \xe0
+ # Check for Bug #227512. If this violates C isspace, then it returns \xC3.
+ concat \xE0
+} \xE0
test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj {
# Check for Bug #1447328 (actually, bugs in its original "fix"). One of the
# symptoms was Bug #2055782.
@@ -238,14 +242,14 @@ test util-5.6 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *3*6*9 01234567890
} 0
test util-5.7 {Tcl_StringMatch: UTF-8} {
- Wrapper_Tcl_StringMatch *u \u4e4fu
+ Wrapper_Tcl_StringMatch *u 乏u
} 1
test util-5.8 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch a?c abc
} 1
test util-5.9 {Tcl_StringMatch: UTF-8} {
# skip one character in string
- Wrapper_Tcl_StringMatch a?c a\u4e4fc
+ Wrapper_Tcl_StringMatch a?c a乏c
} 1
test util-5.10 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch a??c abc
@@ -258,15 +262,15 @@ test util-5.12 {Tcl_StringMatch} {
} 1
test util-5.13 {Tcl_StringMatch: UTF-8} {
# string += Tcl_UtfToUniChar(string, &ch);
- Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc"
+ Wrapper_Tcl_StringMatch "\[乏xy\]bc" "乏bc"
} 1
test util-5.14 {Tcl_StringMatch} {
- # if ((*pattern == ']') || (*pattern == '\0'))
+ # if ((*pattern == ']') || (*pattern == '\x00'))
# badly formed pattern
Wrapper_Tcl_StringMatch {[]} {[]}
} 0
test util-5.15 {Tcl_StringMatch} {
- # if ((*pattern == ']') || (*pattern == '\0'))
+ # if ((*pattern == ']') || (*pattern == '\x00'))
# badly formed pattern
Wrapper_Tcl_StringMatch {[} {[}
} 0
@@ -276,17 +280,17 @@ test util-5.16 {Tcl_StringMatch} {
test util-5.17 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
- Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
+ Wrapper_Tcl_StringMatch "a\[a乏c]c" "a乏c"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
- # proper advance: wrong answer would match on UTF trail byte of \u4e4f
- Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc]
+ # proper advance: wrong answer would match on UTF trail byte of 乏
+ Wrapper_Tcl_StringMatch {a[a乏c]c} [testbytestring a\x8Fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
- Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc"
+ Wrapper_Tcl_StringMatch {a[a乏c]c} "acc"
} 1
test util-5.20 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a[xyz]c} abc
@@ -295,13 +299,13 @@ test util-5.21 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[2-7]45} 12345
} 1
test util-5.22 {Tcl_StringMatch: UTF-8 range} {
- Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "0"
+ Wrapper_Tcl_StringMatch "\[一-乏]" "0"
} 0
test util-5.23 {Tcl_StringMatch: UTF-8 range} {
- Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\u4e33"
+ Wrapper_Tcl_StringMatch "\[一-乏]" "丳"
} 1
test util-5.24 {Tcl_StringMatch: UTF-8 range} {
- Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\uff08"
+ Wrapper_Tcl_StringMatch "\[一-乏]" "("
} 0
test util-5.25 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12345
@@ -355,16 +359,16 @@ test util-5.41 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]]x} Ax
} 1
test util-5.42 {Tcl_StringMatch: skip correct number of ']'} {
- Wrapper_Tcl_StringMatch {[A-]]x} \ue1x
+ Wrapper_Tcl_StringMatch {[A-]]x} \xE1x
} 0
test util-5.43 {Tcl_StringMatch: skip correct number of ']'} {
- Wrapper_Tcl_StringMatch \[A-]\ue1]x \ue1x
+ Wrapper_Tcl_StringMatch \[A-]\xE1]x \xE1x
} 1
test util-5.44 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]h]x} hx
} 1
test util-5.45 {Tcl_StringMatch} {
- # if (*pattern == '\0')
+ # if (*pattern == '\x00')
# badly formed pattern, still treats as a set
Wrapper_Tcl_StringMatch {[a} a
} 1
@@ -387,11 +391,11 @@ test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-5.52 {Tcl_StringMatch} {
- Wrapper_Tcl_StringMatch \[a\u0000 a\x80
+ Wrapper_Tcl_StringMatch \[a\x00 a\x80
} 0
-test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup {
+test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
@@ -399,7 +403,7 @@ test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup {
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.4}
-test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup {
+test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
@@ -407,7 +411,7 @@ test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup {
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.39999999999}
-test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup {
+test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
@@ -415,7 +419,7 @@ test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup {
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.4}
-test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup {
+test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 5
} -body {
@@ -430,7 +434,7 @@ test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr {3.0e98}]
} {x3e+98}
-test util-7.1 {TclPrecTraceProc - unset callbacks} -setup {
+test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 7
@@ -440,7 +444,7 @@ test util-7.1 {TclPrecTraceProc - unset callbacks} -setup {
} -cleanup {
set ::tcl_precision $old_precision
} -result {7 7}
-test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup {
+test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 12
@@ -452,7 +456,7 @@ test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -set
} -cleanup {
set ::tcl_precision $old_precision
} -result {12 6}
-test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup {
+test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 12
@@ -465,7 +469,7 @@ test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup {
} -cleanup {
set ::tcl_precision $old_precision
} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
-test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup {
+test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 12
@@ -482,27 +486,27 @@ test util-8.1 {TclNeedSpace - correct utf-8 handling} {
# which calls on TclNeedSpace(). If [interp target]
# is ever updated, this test will no longer test
# TclNeedSpace.
- interp create \u5420
- interp create [list \u5420 foo]
- interp alias {} fooset [list \u5420 foo] set
+ interp create 吠
+ interp create [list 吠 foo]
+ interp alias {} fooset [list 吠 foo] set
set result [interp target {} fooset]
- interp delete \u5420
+ interp delete 吠
set result
-} "\u5420 foo"
+} "吠 foo"
test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring {
# Bug 411825
# This tests the same bug as the previous test, but
# should be more future-proof, as the DString
# operations will likely continue to call TclNeedSpace
testdstring free
- testdstring append \u5420 -1
+ testdstring append 吠 -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring {
# Bug 411825 - new variant reported by Dossy Shiobara
testdstring free
- testdstring append \u00A0 -1
+ testdstring append \xA0 -1
testdstring element foo
llength [testdstring get]
} 2
@@ -574,188 +578,252 @@ test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring {
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
-test util-9.0.0 {TclGetIntForIndex} {
+test util-9.0.0 {Tcl_GetIntForIndex} {
string index abcd 0
} a
-test util-9.0.1 {TclGetIntForIndex} {
+test util-9.0.1 {Tcl_GetIntForIndex} {
string index abcd 0x0
} a
-test util-9.0.2 {TclGetIntForIndex} {
+test util-9.0.2 {Tcl_GetIntForIndex} {
string index abcd -0x0
} a
-test util-9.0.3 {TclGetIntForIndex} {
+test util-9.0.3 {Tcl_GetIntForIndex} {
string index abcd { 0 }
} a
-test util-9.0.4 {TclGetIntForIndex} {
+test util-9.0.4 {Tcl_GetIntForIndex} {
string index abcd { 0x0 }
} a
-test util-9.0.5 {TclGetIntForIndex} {
+test util-9.0.5 {Tcl_GetIntForIndex} {
string index abcd { -0x0 }
} a
-test util-9.0.6 {TclGetIntForIndex} {
+test util-9.0.6 {Tcl_GetIntForIndex} {
string index abcd 01
} b
-test util-9.0.7 {TclGetIntForIndex} {
+test util-9.0.7 {Tcl_GetIntForIndex} {
string index abcd { 01 }
} b
-test util-9.1.0 {TclGetIntForIndex} {
+test util-9.0.8 {Tcl_GetIntForIndex} {
+ string index abcd { 0d0 }
+} a
+test util-9.0.9 {Tcl_GetIntForIndex} {
+ string index abcd { -0d0 }
+} a
+test util-9.1.0 {Tcl_GetIntForIndex} {
string index abcd 3
} d
-test util-9.1.1 {TclGetIntForIndex} {
+test util-9.1.1 {Tcl_GetIntForIndex} {
string index abcd { 3 }
} d
-test util-9.1.2 {TclGetIntForIndex} {
+test util-9.1.2 {Tcl_GetIntForIndex} {
string index abcdefghijk 0xa
} k
-test util-9.1.3 {TclGetIntForIndex} {
+test util-9.1.3 {Tcl_GetIntForIndex} {
string index abcdefghijk { 0xa }
} k
-test util-9.2.0 {TclGetIntForIndex} {
+test util-9.1.4 {Tcl_GetIntForIndex} {
+ string index abcdefghijk 0d10
+} k
+test util-9.1.5 {Tcl_GetIntForIndex} {
+ string index abcdefghijk { 0d10 }
+} k
+test util-9.2.0 {Tcl_GetIntForIndex} {
string index abcd end
} d
-test util-9.2.1 {TclGetIntForIndex} -body {
+test util-9.2.1 {Tcl_GetIntForIndex} -body {
string index abcd { end}
} -returnCodes error -match glob -result *
-test util-9.2.2 {TclGetIntForIndex} -body {
+test util-9.2.2 {Tcl_GetIntForIndex} -body {
string index abcd {end }
} -returnCodes error -match glob -result *
-test util-9.3 {TclGetIntForIndex} {
+test util-9.3 {Tcl_GetIntForIndex} -body {
# Deprecated
string index abcd en
-} d
-test util-9.4 {TclGetIntForIndex} {
+} -returnCodes error -match glob -result *
+test util-9.4 {Tcl_GetIntForIndex} -body {
# Deprecated
string index abcd e
-} d
-test util-9.5.0 {TclGetIntForIndex} {
+} -returnCodes error -match glob -result *
+test util-9.5.0 {Tcl_GetIntForIndex} {
string index abcd end-1
} c
-test util-9.5.1 {TclGetIntForIndex} {
+test util-9.5.1 {Tcl_GetIntForIndex} {
string index abcd {end-1 }
} c
-test util-9.5.2 {TclGetIntForIndex} -body {
+test util-9.5.2 {Tcl_GetIntForIndex} -body {
string index abcd { end-1}
} -returnCodes error -match glob -result *
-test util-9.6 {TclGetIntForIndex} {
+test util-9.6 {Tcl_GetIntForIndex} {
string index abcd end+-1
} c
-test util-9.7 {TclGetIntForIndex} {
+test util-9.7 {Tcl_GetIntForIndex} {
string index abcd end+1
} {}
-test util-9.8 {TclGetIntForIndex} {
+test util-9.8 {Tcl_GetIntForIndex} {
string index abcd end--1
} {}
-test util-9.9.0 {TclGetIntForIndex} {
+test util-9.9.0 {Tcl_GetIntForIndex} {
string index abcd 0+0
} a
-test util-9.9.1 {TclGetIntForIndex} {
+test util-9.9.1 {Tcl_GetIntForIndex} {
string index abcd { 0+0 }
} a
-test util-9.10 {TclGetIntForIndex} {
+test util-9.10 {Tcl_GetIntForIndex} {
string index abcd 0-0
} a
-test util-9.11 {TclGetIntForIndex} {
+test util-9.11 {Tcl_GetIntForIndex} {
string index abcd 1+0
} b
-test util-9.12 {TclGetIntForIndex} {
+test util-9.12 {Tcl_GetIntForIndex} {
string index abcd 1-0
} b
-test util-9.13 {TclGetIntForIndex} {
+test util-9.13 {Tcl_GetIntForIndex} {
string index abcd 1+1
} c
-test util-9.14 {TclGetIntForIndex} {
+test util-9.14 {Tcl_GetIntForIndex} {
string index abcd 1-1
} a
-test util-9.15 {TclGetIntForIndex} {
+test util-9.15 {Tcl_GetIntForIndex} {
string index abcd -1+2
} b
-test util-9.16 {TclGetIntForIndex} {
+test util-9.16 {Tcl_GetIntForIndex} {
string index abcd -1--2
} b
-test util-9.17 {TclGetIntForIndex} {
+test util-9.17 {Tcl_GetIntForIndex} {
string index abcd { -1+2 }
} b
-test util-9.18 {TclGetIntForIndex} {
+test util-9.18 {Tcl_GetIntForIndex} {
string index abcd { -1--2 }
} b
-test util-9.19 {TclGetIntForIndex} -body {
+test util-9.19 {Tcl_GetIntForIndex} -body {
string index a {}
} -returnCodes error -match glob -result *
-test util-9.20 {TclGetIntForIndex} -body {
+test util-9.20 {Tcl_GetIntForIndex} -body {
string index a { }
} -returnCodes error -match glob -result *
-test util-9.21 {TclGetIntForIndex} -body {
+test util-9.21 {Tcl_GetIntForIndex} -body {
string index a " \r\t\n"
} -returnCodes error -match glob -result *
-test util-9.22 {TclGetIntForIndex} -body {
+test util-9.22 {Tcl_GetIntForIndex} -body {
string index a +
} -returnCodes error -match glob -result *
-test util-9.23 {TclGetIntForIndex} -body {
+test util-9.23 {Tcl_GetIntForIndex} -body {
string index a -
} -returnCodes error -match glob -result *
-test util-9.24 {TclGetIntForIndex} -body {
+test util-9.24 {Tcl_GetIntForIndex} -body {
string index a x
} -returnCodes error -match glob -result *
-test util-9.25 {TclGetIntForIndex} -body {
+test util-9.25 {Tcl_GetIntForIndex} -body {
string index a +x
} -returnCodes error -match glob -result *
-test util-9.26 {TclGetIntForIndex} -body {
+test util-9.26 {Tcl_GetIntForIndex} -body {
string index a -x
} -returnCodes error -match glob -result *
-test util-9.27 {TclGetIntForIndex} -body {
+test util-9.27 {Tcl_GetIntForIndex} -body {
string index a 0y
} -returnCodes error -match glob -result *
-test util-9.28 {TclGetIntForIndex} -body {
+test util-9.28 {Tcl_GetIntForIndex} -body {
string index a 1*
} -returnCodes error -match glob -result *
-test util-9.29 {TclGetIntForIndex} -body {
+test util-9.29 {Tcl_GetIntForIndex} -body {
string index a 0+
} -returnCodes error -match glob -result *
-test util-9.30 {TclGetIntForIndex} -body {
+test util-9.30 {Tcl_GetIntForIndex} -body {
string index a {0+ }
} -returnCodes error -match glob -result *
-test util-9.31 {TclGetIntForIndex} -body {
+test util-9.31 {Tcl_GetIntForIndex} -body {
string index a 0x
} -returnCodes error -match glob -result *
-test util-9.32 {TclGetIntForIndex} -body {
- string index a 0x1FFFFFFFF+0
+test util-9.31.1 {Tcl_GetIntForIndex} -body {
+ string index a 0d
} -returnCodes error -match glob -result *
-test util-9.33 {TclGetIntForIndex} -body {
+test util-9.32 {Tcl_GetIntForIndex} -body {
+ string index a 0x1FFFFFFFF+0
+} -result {}
+test util-9.33 {Tcl_GetIntForIndex} -body {
string index a 100000000000+0
-} -returnCodes error -match glob -result *
-test util-9.34 {TclGetIntForIndex} -body {
+} -result {}
+test util-9.33.1 {Tcl_GetIntForIndex} -body {
+ string index a 0d100000000000+0
+} -result {}
+test util-9.34 {Tcl_GetIntForIndex} -body {
string index a 1.0
} -returnCodes error -match glob -result *
-test util-9.35 {TclGetIntForIndex} -body {
+test util-9.35 {Tcl_GetIntForIndex} -body {
string index a 1e23
} -returnCodes error -match glob -result *
-test util-9.36 {TclGetIntForIndex} -body {
+test util-9.36 {Tcl_GetIntForIndex} -body {
string index a 1.5e2
} -returnCodes error -match glob -result *
-test util-9.37 {TclGetIntForIndex} -body {
+test util-9.37 {Tcl_GetIntForIndex} -body {
string index a 0+x
} -returnCodes error -match glob -result *
-test util-9.38 {TclGetIntForIndex} -body {
+test util-9.38 {Tcl_GetIntForIndex} -body {
string index a 0+0x
} -returnCodes error -match glob -result *
-test util-9.39 {TclGetIntForIndex} -body {
+test util-9.39 {Tcl_GetIntForIndex} -body {
string index a 0+0xg
} -returnCodes error -match glob -result *
-test util-9.40 {TclGetIntForIndex} -body {
+test util-9.40 {Tcl_GetIntForIndex} -body {
string index a 0+0xg
} -returnCodes error -match glob -result *
-test util-9.41 {TclGetIntForIndex} -body {
+test util-9.41 {Tcl_GetIntForIndex} -body {
string index a 0+1.0
} -returnCodes error -match glob -result *
-test util-9.42 {TclGetIntForIndex} -body {
+test util-9.42 {Tcl_GetIntForIndex} -body {
string index a 0+1e2
} -returnCodes error -match glob -result *
-test util-9.43 {TclGetIntForIndex} -body {
+test util-9.43 {Tcl_GetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
-test util-9.44 {TclGetIntForIndex} -body {
+test util-9.44 {Tcl_GetIntForIndex} -body {
string index a 0+1000000000000
+} -result {}
+test util-9.45 {Tcl_GetIntForIndex} -body {
+ string index abcd end+2305843009213693950
+} -result {}
+test util-9.46 {Tcl_GetIntForIndex} -body {
+ string index abcd end+4294967294
+} -result {}
+# TIP 502
+test util-9.47 {Tcl_GetIntForIndex} -body {
+ string index abcd 0x10000000000000000
+} -result {}
+test util-9.48 {Tcl_GetIntForIndex} {
+ string index abcd -0x10000000000000000
+} {}
+test util-9.49 {Tcl_GetIntForIndex} -body {
+ string index abcd end*1
+} -returnCodes error -match glob -result *
+test util-9.50 {Tcl_GetIntForIndex} -body {
+ string index abcd {end- 1}
+} -returnCodes error -match glob -result *
+test util-9.51 {Tcl_GetIntForIndex} -body {
+ string index abcd end-end
+} -returnCodes error -match glob -result *
+test util-9.52 {Tcl_GetIntForIndex} -body {
+ string index abcd end-x
} -returnCodes error -match glob -result *
+test util-9.53 {Tcl_GetIntForIndex} -body {
+ string index abcd end-0.1
+} -returnCodes error -match glob -result *
+test util-9.54 {Tcl_GetIntForIndex} {
+ string index abcd end-0x10000000000000000
+} {}
+test util-9.55 {Tcl_GetIntForIndex} -body {
+ string index abcd end+0x10000000000000000
+} -result {}
+test util-9.56 {Tcl_GetIntForIndex} -body {
+ string index abcd end--0x10000000000000000
+} -result {}
+test util-9.57 {Tcl_GetIntForIndex} {
+ string index abcd end+-0x10000000000000000
+} {}
+test util-9.58 {Tcl_GetIntForIndex} -body {
+ string index abcd end--0x8000000000000000
+} -result {}
+test util-9.59 {Tcl_GetIntForIndex} {
+ string index abcd 0-0x10000000000000000
+} {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
@@ -2165,7 +2233,6 @@ test util-15.8 {smallest normal} {*}{
}
}
-set saved_precision $::tcl_precision
foreach ::tcl_precision {0 12} {
for {set e -312} {$e < -9} {incr e} {
test util-16.1.$::tcl_precision.$e {shortening of numbers} \
@@ -2179,7 +2246,7 @@ for {set e -9} {$e < -4} {incr e} {
}
set tcl_precision 12
for {set e -9} {$e < -4} {incr e} {
- test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} \
+ test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \
"expr {1.1e$e}" 1.1e[format %+03d $e]
}
foreach ::tcl_precision {0 12} {
@@ -2209,1828 +2276,1828 @@ foreach ::tcl_precision {0 12} {
}
}
set tcl_precision 17
-test util-16.1.17.-300 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \
{expr {1e-300}} \
1e-300
-test util-16.1.17.-299 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \
{expr {1e-299}} \
9.9999999999999999e-300
-test util-16.1.17.-298 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \
{expr {1e-298}} \
9.9999999999999991e-299
-test util-16.1.17.-297 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \
{expr {1e-297}} \
1e-297
-test util-16.1.17.-296 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \
{expr {1e-296}} \
1e-296
-test util-16.1.17.-295 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \
{expr {1e-295}} \
1.0000000000000001e-295
-test util-16.1.17.-294 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \
{expr {1e-294}} \
1e-294
-test util-16.1.17.-293 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \
{expr {1e-293}} \
1.0000000000000001e-293
-test util-16.1.17.-292 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \
{expr {1e-292}} \
1.0000000000000001e-292
-test util-16.1.17.-291 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \
{expr {1e-291}} \
9.9999999999999996e-292
-test util-16.1.17.-290 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \
{expr {1e-290}} \
1.0000000000000001e-290
-test util-16.1.17.-289 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \
{expr {1e-289}} \
1e-289
-test util-16.1.17.-288 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \
{expr {1e-288}} \
1.0000000000000001e-288
-test util-16.1.17.-287 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \
{expr {1e-287}} \
1e-287
-test util-16.1.17.-286 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \
{expr {1e-286}} \
1.0000000000000001e-286
-test util-16.1.17.-285 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \
{expr {1e-285}} \
1.0000000000000001e-285
-test util-16.1.17.-284 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \
{expr {1e-284}} \
1e-284
-test util-16.1.17.-283 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \
{expr {1e-283}} \
9.9999999999999995e-284
-test util-16.1.17.-282 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \
{expr {1e-282}} \
1e-282
-test util-16.1.17.-281 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \
{expr {1e-281}} \
1e-281
-test util-16.1.17.-280 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \
{expr {1e-280}} \
9.9999999999999996e-281
-test util-16.1.17.-279 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \
{expr {1e-279}} \
1.0000000000000001e-279
-test util-16.1.17.-278 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \
{expr {1e-278}} \
9.9999999999999994e-279
-test util-16.1.17.-277 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \
{expr {1e-277}} \
9.9999999999999997e-278
-test util-16.1.17.-276 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \
{expr {1e-276}} \
1.0000000000000001e-276
-test util-16.1.17.-275 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \
{expr {1e-275}} \
9.9999999999999993e-276
-test util-16.1.17.-274 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \
{expr {1e-274}} \
9.9999999999999997e-275
-test util-16.1.17.-273 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \
{expr {1e-273}} \
1.0000000000000001e-273
-test util-16.1.17.-272 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \
{expr {1e-272}} \
9.9999999999999993e-273
-test util-16.1.17.-271 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \
{expr {1e-271}} \
9.9999999999999996e-272
-test util-16.1.17.-270 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \
{expr {1e-270}} \
1e-270
-test util-16.1.17.-269 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \
{expr {1e-269}} \
9.9999999999999996e-270
-test util-16.1.17.-268 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \
{expr {1e-268}} \
9.9999999999999996e-269
-test util-16.1.17.-267 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \
{expr {1e-267}} \
9.9999999999999998e-268
-test util-16.1.17.-266 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \
{expr {1e-266}} \
9.9999999999999998e-267
-test util-16.1.17.-265 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \
{expr {1e-265}} \
9.9999999999999998e-266
-test util-16.1.17.-264 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \
{expr {1e-264}} \
1e-264
-test util-16.1.17.-263 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \
{expr {1e-263}} \
1e-263
-test util-16.1.17.-262 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \
{expr {1e-262}} \
1e-262
-test util-16.1.17.-261 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \
{expr {1e-261}} \
9.9999999999999998e-262
-test util-16.1.17.-260 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \
{expr {1e-260}} \
9.9999999999999996e-261
-test util-16.1.17.-259 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \
{expr {1e-259}} \
1.0000000000000001e-259
-test util-16.1.17.-258 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \
{expr {1e-258}} \
9.9999999999999995e-259
-test util-16.1.17.-257 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \
{expr {1e-257}} \
9.9999999999999998e-258
-test util-16.1.17.-256 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \
{expr {1e-256}} \
9.9999999999999998e-257
-test util-16.1.17.-255 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \
{expr {1e-255}} \
1e-255
-test util-16.1.17.-254 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \
{expr {1e-254}} \
9.9999999999999991e-255
-test util-16.1.17.-253 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \
{expr {1e-253}} \
1.0000000000000001e-253
-test util-16.1.17.-252 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \
{expr {1e-252}} \
9.9999999999999994e-253
-test util-16.1.17.-251 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \
{expr {1e-251}} \
1e-251
-test util-16.1.17.-250 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \
{expr {1e-250}} \
1.0000000000000001e-250
-test util-16.1.17.-249 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \
{expr {1e-249}} \
1.0000000000000001e-249
-test util-16.1.17.-248 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \
{expr {1e-248}} \
9.9999999999999998e-249
-test util-16.1.17.-247 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \
{expr {1e-247}} \
1e-247
-test util-16.1.17.-246 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \
{expr {1e-246}} \
9.9999999999999996e-247
-test util-16.1.17.-245 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \
{expr {1e-245}} \
9.9999999999999993e-246
-test util-16.1.17.-244 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \
{expr {1e-244}} \
9.9999999999999993e-245
-test util-16.1.17.-243 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \
{expr {1e-243}} \
1e-243
-test util-16.1.17.-242 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \
{expr {1e-242}} \
9.9999999999999997e-243
-test util-16.1.17.-241 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \
{expr {1e-241}} \
9.9999999999999997e-242
-test util-16.1.17.-240 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \
{expr {1e-240}} \
9.9999999999999997e-241
-test util-16.1.17.-239 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \
{expr {1e-239}} \
1.0000000000000001e-239
-test util-16.1.17.-238 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \
{expr {1e-238}} \
9.9999999999999999e-239
-test util-16.1.17.-237 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \
{expr {1e-237}} \
9.9999999999999999e-238
-test util-16.1.17.-236 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \
{expr {1e-236}} \
1e-236
-test util-16.1.17.-235 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \
{expr {1e-235}} \
9.9999999999999996e-236
-test util-16.1.17.-234 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \
{expr {1e-234}} \
9.9999999999999996e-235
-test util-16.1.17.-233 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \
{expr {1e-233}} \
9.9999999999999996e-234
-test util-16.1.17.-232 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \
{expr {1e-232}} \
1e-232
-test util-16.1.17.-231 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \
{expr {1e-231}} \
9.9999999999999999e-232
-test util-16.1.17.-230 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \
{expr {1e-230}} \
1e-230
-test util-16.1.17.-229 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \
{expr {1e-229}} \
1.0000000000000001e-229
-test util-16.1.17.-228 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \
{expr {1e-228}} \
1e-228
-test util-16.1.17.-227 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \
{expr {1e-227}} \
9.9999999999999994e-228
-test util-16.1.17.-226 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \
{expr {1e-226}} \
9.9999999999999992e-227
-test util-16.1.17.-225 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \
{expr {1e-225}} \
9.9999999999999996e-226
-test util-16.1.17.-224 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \
{expr {1e-224}} \
1e-224
-test util-16.1.17.-223 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \
{expr {1e-223}} \
9.9999999999999997e-224
-test util-16.1.17.-222 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \
{expr {1e-222}} \
1e-222
-test util-16.1.17.-221 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \
{expr {1e-221}} \
1e-221
-test util-16.1.17.-220 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \
{expr {1e-220}} \
9.9999999999999999e-221
-test util-16.1.17.-219 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \
{expr {1e-219}} \
1e-219
-test util-16.1.17.-218 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \
{expr {1e-218}} \
1e-218
-test util-16.1.17.-217 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \
{expr {1e-217}} \
1.0000000000000001e-217
-test util-16.1.17.-216 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \
{expr {1e-216}} \
1e-216
-test util-16.1.17.-215 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \
{expr {1e-215}} \
1e-215
-test util-16.1.17.-214 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \
{expr {1e-214}} \
9.9999999999999991e-215
-test util-16.1.17.-213 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \
{expr {1e-213}} \
9.9999999999999995e-214
-test util-16.1.17.-212 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \
{expr {1e-212}} \
9.9999999999999995e-213
-test util-16.1.17.-211 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \
{expr {1e-211}} \
1.0000000000000001e-211
-test util-16.1.17.-210 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \
{expr {1e-210}} \
1e-210
-test util-16.1.17.-209 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \
{expr {1e-209}} \
1e-209
-test util-16.1.17.-208 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \
{expr {1e-208}} \
1.0000000000000001e-208
-test util-16.1.17.-207 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \
{expr {1e-207}} \
9.9999999999999993e-208
-test util-16.1.17.-206 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \
{expr {1e-206}} \
1e-206
-test util-16.1.17.-205 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \
{expr {1e-205}} \
1e-205
-test util-16.1.17.-204 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \
{expr {1e-204}} \
1e-204
-test util-16.1.17.-203 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \
{expr {1e-203}} \
1e-203
-test util-16.1.17.-202 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \
{expr {1e-202}} \
1e-202
-test util-16.1.17.-201 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \
{expr {1e-201}} \
9.9999999999999995e-202
-test util-16.1.17.-200 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \
{expr {1e-200}} \
9.9999999999999998e-201
-test util-16.1.17.-199 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \
{expr {1e-199}} \
9.9999999999999998e-200
-test util-16.1.17.-198 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \
{expr {1e-198}} \
9.9999999999999991e-199
-test util-16.1.17.-197 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \
{expr {1e-197}} \
9.9999999999999999e-198
-test util-16.1.17.-196 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \
{expr {1e-196}} \
1e-196
-test util-16.1.17.-195 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \
{expr {1e-195}} \
1.0000000000000001e-195
-test util-16.1.17.-194 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \
{expr {1e-194}} \
1e-194
-test util-16.1.17.-193 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \
{expr {1e-193}} \
1e-193
-test util-16.1.17.-192 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \
{expr {1e-192}} \
1.0000000000000001e-192
-test util-16.1.17.-191 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \
{expr {1e-191}} \
1e-191
-test util-16.1.17.-190 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \
{expr {1e-190}} \
1e-190
-test util-16.1.17.-189 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \
{expr {1e-189}} \
1.0000000000000001e-189
-test util-16.1.17.-188 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \
{expr {1e-188}} \
9.9999999999999995e-189
-test util-16.1.17.-187 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \
{expr {1e-187}} \
1e-187
-test util-16.1.17.-186 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \
{expr {1e-186}} \
9.9999999999999991e-187
-test util-16.1.17.-185 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \
{expr {1e-185}} \
9.9999999999999999e-186
-test util-16.1.17.-184 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \
{expr {1e-184}} \
1.0000000000000001e-184
-test util-16.1.17.-183 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \
{expr {1e-183}} \
1e-183
-test util-16.1.17.-182 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \
{expr {1e-182}} \
1e-182
-test util-16.1.17.-181 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \
{expr {1e-181}} \
1e-181
-test util-16.1.17.-180 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \
{expr {1e-180}} \
1e-180
-test util-16.1.17.-179 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \
{expr {1e-179}} \
1e-179
-test util-16.1.17.-178 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \
{expr {1e-178}} \
9.9999999999999995e-179
-test util-16.1.17.-177 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \
{expr {1e-177}} \
9.9999999999999995e-178
-test util-16.1.17.-176 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \
{expr {1e-176}} \
1e-176
-test util-16.1.17.-175 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \
{expr {1e-175}} \
1e-175
-test util-16.1.17.-174 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \
{expr {1e-174}} \
1e-174
-test util-16.1.17.-173 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \
{expr {1e-173}} \
1e-173
-test util-16.1.17.-172 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \
{expr {1e-172}} \
1e-172
-test util-16.1.17.-171 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \
{expr {1e-171}} \
9.9999999999999998e-172
-test util-16.1.17.-170 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \
{expr {1e-170}} \
9.9999999999999998e-171
-test util-16.1.17.-169 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \
{expr {1e-169}} \
1e-169
-test util-16.1.17.-168 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \
{expr {1e-168}} \
1e-168
-test util-16.1.17.-167 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \
{expr {1e-167}} \
1e-167
-test util-16.1.17.-166 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \
{expr {1e-166}} \
1e-166
-test util-16.1.17.-165 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \
{expr {1e-165}} \
1e-165
-test util-16.1.17.-164 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \
{expr {1e-164}} \
9.9999999999999996e-165
-test util-16.1.17.-163 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \
{expr {1e-163}} \
9.9999999999999992e-164
-test util-16.1.17.-162 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \
{expr {1e-162}} \
9.9999999999999995e-163
-test util-16.1.17.-161 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \
{expr {1e-161}} \
1e-161
-test util-16.1.17.-160 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \
{expr {1e-160}} \
9.9999999999999999e-161
-test util-16.1.17.-159 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \
{expr {1e-159}} \
9.9999999999999999e-160
-test util-16.1.17.-158 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \
{expr {1e-158}} \
1.0000000000000001e-158
-test util-16.1.17.-157 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \
{expr {1e-157}} \
9.9999999999999994e-158
-test util-16.1.17.-156 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \
{expr {1e-156}} \
1e-156
-test util-16.1.17.-155 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \
{expr {1e-155}} \
1e-155
-test util-16.1.17.-154 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \
{expr {1e-154}} \
9.9999999999999997e-155
-test util-16.1.17.-153 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \
{expr {1e-153}} \
1e-153
-test util-16.1.17.-152 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \
{expr {1e-152}} \
1.0000000000000001e-152
-test util-16.1.17.-151 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \
{expr {1e-151}} \
9.9999999999999994e-152
-test util-16.1.17.-150 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \
{expr {1e-150}} \
1e-150
-test util-16.1.17.-149 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \
{expr {1e-149}} \
9.9999999999999998e-150
-test util-16.1.17.-148 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \
{expr {1e-148}} \
9.9999999999999994e-149
-test util-16.1.17.-147 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \
{expr {1e-147}} \
9.9999999999999997e-148
-test util-16.1.17.-146 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \
{expr {1e-146}} \
1e-146
-test util-16.1.17.-145 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \
{expr {1e-145}} \
9.9999999999999991e-146
-test util-16.1.17.-144 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \
{expr {1e-144}} \
9.9999999999999995e-145
-test util-16.1.17.-143 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \
{expr {1e-143}} \
9.9999999999999995e-144
-test util-16.1.17.-142 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \
{expr {1e-142}} \
1e-142
-test util-16.1.17.-141 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \
{expr {1e-141}} \
1e-141
-test util-16.1.17.-140 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \
{expr {1e-140}} \
9.9999999999999998e-141
-test util-16.1.17.-139 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \
{expr {1e-139}} \
1e-139
-test util-16.1.17.-138 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \
{expr {1e-138}} \
1.0000000000000001e-138
-test util-16.1.17.-137 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \
{expr {1e-137}} \
9.9999999999999998e-138
-test util-16.1.17.-136 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \
{expr {1e-136}} \
1e-136
-test util-16.1.17.-135 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \
{expr {1e-135}} \
1e-135
-test util-16.1.17.-134 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \
{expr {1e-134}} \
1e-134
-test util-16.1.17.-133 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \
{expr {1e-133}} \
1.0000000000000001e-133
-test util-16.1.17.-132 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \
{expr {1e-132}} \
9.9999999999999999e-133
-test util-16.1.17.-131 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \
{expr {1e-131}} \
9.9999999999999999e-132
-test util-16.1.17.-130 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \
{expr {1e-130}} \
1.0000000000000001e-130
-test util-16.1.17.-129 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \
{expr {1e-129}} \
9.9999999999999993e-130
-test util-16.1.17.-128 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \
{expr {1e-128}} \
1.0000000000000001e-128
-test util-16.1.17.-127 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \
{expr {1e-127}} \
1e-127
-test util-16.1.17.-126 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \
{expr {1e-126}} \
9.9999999999999995e-127
-test util-16.1.17.-125 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \
{expr {1e-125}} \
1e-125
-test util-16.1.17.-124 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \
{expr {1e-124}} \
9.9999999999999993e-125
-test util-16.1.17.-123 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \
{expr {1e-123}} \
1.0000000000000001e-123
-test util-16.1.17.-122 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \
{expr {1e-122}} \
1.0000000000000001e-122
-test util-16.1.17.-121 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \
{expr {1e-121}} \
9.9999999999999998e-122
-test util-16.1.17.-120 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \
{expr {1e-120}} \
9.9999999999999998e-121
-test util-16.1.17.-119 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \
{expr {1e-119}} \
1e-119
-test util-16.1.17.-118 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \
{expr {1e-118}} \
9.9999999999999999e-119
-test util-16.1.17.-117 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \
{expr {1e-117}} \
1e-117
-test util-16.1.17.-116 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \
{expr {1e-116}} \
9.9999999999999999e-117
-test util-16.1.17.-115 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \
{expr {1e-115}} \
1.0000000000000001e-115
-test util-16.1.17.-114 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \
{expr {1e-114}} \
1.0000000000000001e-114
-test util-16.1.17.-113 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \
{expr {1e-113}} \
9.9999999999999998e-114
-test util-16.1.17.-112 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \
{expr {1e-112}} \
9.9999999999999995e-113
-test util-16.1.17.-111 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \
{expr {1e-111}} \
1.0000000000000001e-111
-test util-16.1.17.-110 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \
{expr {1e-110}} \
1.0000000000000001e-110
-test util-16.1.17.-109 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \
{expr {1e-109}} \
9.9999999999999999e-110
-test util-16.1.17.-108 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \
{expr {1e-108}} \
1e-108
-test util-16.1.17.-107 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \
{expr {1e-107}} \
1e-107
-test util-16.1.17.-106 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \
{expr {1e-106}} \
9.9999999999999994e-107
-test util-16.1.17.-105 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \
{expr {1e-105}} \
9.9999999999999997e-106
-test util-16.1.17.-104 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \
{expr {1e-104}} \
9.9999999999999993e-105
-test util-16.1.17.-103 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \
{expr {1e-103}} \
9.9999999999999996e-104
-test util-16.1.17.-102 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \
{expr {1e-102}} \
9.9999999999999993e-103
-test util-16.1.17.-101 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \
{expr {1e-101}} \
1.0000000000000001e-101
-test util-16.1.17.-100 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \
{expr {1e-100}} \
1e-100
-test util-16.1.17.-99 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \
{expr {1e-99}} \
1e-99
-test util-16.1.17.-98 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \
{expr {1e-98}} \
9.9999999999999994e-99
-test util-16.1.17.-97 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \
{expr {1e-97}} \
1e-97
-test util-16.1.17.-96 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \
{expr {1e-96}} \
9.9999999999999991e-97
-test util-16.1.17.-95 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \
{expr {1e-95}} \
9.9999999999999999e-96
-test util-16.1.17.-94 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \
{expr {1e-94}} \
9.9999999999999996e-95
-test util-16.1.17.-93 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \
{expr {1e-93}} \
9.999999999999999e-94
-test util-16.1.17.-92 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \
{expr {1e-92}} \
9.9999999999999999e-93
-test util-16.1.17.-91 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \
{expr {1e-91}} \
1e-91
-test util-16.1.17.-90 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \
{expr {1e-90}} \
9.9999999999999999e-91
-test util-16.1.17.-89 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \
{expr {1e-89}} \
1e-89
-test util-16.1.17.-88 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \
{expr {1e-88}} \
9.9999999999999993e-89
-test util-16.1.17.-87 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \
{expr {1e-87}} \
1e-87
-test util-16.1.17.-86 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \
{expr {1e-86}} \
1.0000000000000001e-86
-test util-16.1.17.-85 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \
{expr {1e-85}} \
9.9999999999999998e-86
-test util-16.1.17.-84 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \
{expr {1e-84}} \
1e-84
-test util-16.1.17.-83 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \
{expr {1e-83}} \
1e-83
-test util-16.1.17.-82 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \
{expr {1e-82}} \
9.9999999999999996e-83
-test util-16.1.17.-81 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \
{expr {1e-81}} \
9.9999999999999996e-82
-test util-16.1.17.-80 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \
{expr {1e-80}} \
9.9999999999999996e-81
-test util-16.1.17.-79 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \
{expr {1e-79}} \
1e-79
-test util-16.1.17.-78 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \
{expr {1e-78}} \
1e-78
-test util-16.1.17.-77 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \
{expr {1e-77}} \
9.9999999999999993e-78
-test util-16.1.17.-76 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \
{expr {1e-76}} \
9.9999999999999993e-77
-test util-16.1.17.-75 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \
{expr {1e-75}} \
9.9999999999999996e-76
-test util-16.1.17.-74 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \
{expr {1e-74}} \
9.9999999999999996e-75
-test util-16.1.17.-73 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \
{expr {1e-73}} \
1e-73
-test util-16.1.17.-72 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \
{expr {1e-72}} \
9.9999999999999997e-73
-test util-16.1.17.-71 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \
{expr {1e-71}} \
9.9999999999999992e-72
-test util-16.1.17.-70 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \
{expr {1e-70}} \
1e-70
-test util-16.1.17.-69 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \
{expr {1e-69}} \
9.9999999999999996e-70
-test util-16.1.17.-68 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \
{expr {1e-68}} \
1.0000000000000001e-68
-test util-16.1.17.-67 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \
{expr {1e-67}} \
9.9999999999999994e-68
-test util-16.1.17.-66 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \
{expr {1e-66}} \
9.9999999999999998e-67
-test util-16.1.17.-65 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \
{expr {1e-65}} \
9.9999999999999992e-66
-test util-16.1.17.-64 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \
{expr {1e-64}} \
9.9999999999999997e-65
-test util-16.1.17.-63 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \
{expr {1e-63}} \
1.0000000000000001e-63
-test util-16.1.17.-62 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \
{expr {1e-62}} \
1e-62
-test util-16.1.17.-61 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \
{expr {1e-61}} \
1e-61
-test util-16.1.17.-60 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \
{expr {1e-60}} \
9.9999999999999997e-61
-test util-16.1.17.-59 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \
{expr {1e-59}} \
1e-59
-test util-16.1.17.-58 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \
{expr {1e-58}} \
1e-58
-test util-16.1.17.-57 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \
{expr {1e-57}} \
9.9999999999999995e-58
-test util-16.1.17.-56 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \
{expr {1e-56}} \
1e-56
-test util-16.1.17.-55 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \
{expr {1e-55}} \
9.9999999999999999e-56
-test util-16.1.17.-54 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \
{expr {1e-54}} \
1e-54
-test util-16.1.17.-53 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \
{expr {1e-53}} \
1e-53
-test util-16.1.17.-52 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \
{expr {1e-52}} \
1e-52
-test util-16.1.17.-51 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \
{expr {1e-51}} \
1e-51
-test util-16.1.17.-50 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \
{expr {1e-50}} \
1e-50
-test util-16.1.17.-49 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \
{expr {1e-49}} \
9.9999999999999994e-50
-test util-16.1.17.-48 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \
{expr {1e-48}} \
9.9999999999999997e-49
-test util-16.1.17.-47 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \
{expr {1e-47}} \
9.9999999999999997e-48
-test util-16.1.17.-46 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \
{expr {1e-46}} \
1e-46
-test util-16.1.17.-45 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \
{expr {1e-45}} \
9.9999999999999998e-46
-test util-16.1.17.-44 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \
{expr {1e-44}} \
9.9999999999999995e-45
-test util-16.1.17.-43 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \
{expr {1e-43}} \
1.0000000000000001e-43
-test util-16.1.17.-42 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \
{expr {1e-42}} \
1e-42
-test util-16.1.17.-41 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \
{expr {1e-41}} \
1e-41
-test util-16.1.17.-40 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \
{expr {1e-40}} \
9.9999999999999993e-41
-test util-16.1.17.-39 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \
{expr {1e-39}} \
9.9999999999999993e-40
-test util-16.1.17.-38 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \
{expr {1e-38}} \
9.9999999999999996e-39
-test util-16.1.17.-37 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \
{expr {1e-37}} \
1.0000000000000001e-37
-test util-16.1.17.-36 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \
{expr {1e-36}} \
9.9999999999999994e-37
-test util-16.1.17.-35 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \
{expr {1e-35}} \
1e-35
-test util-16.1.17.-34 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \
{expr {1e-34}} \
9.9999999999999993e-35
-test util-16.1.17.-33 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \
{expr {1e-33}} \
1.0000000000000001e-33
-test util-16.1.17.-32 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \
{expr {1e-32}} \
1.0000000000000001e-32
-test util-16.1.17.-31 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \
{expr {1e-31}} \
1.0000000000000001e-31
-test util-16.1.17.-30 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \
{expr {1e-30}} \
1.0000000000000001e-30
-test util-16.1.17.-29 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \
{expr {1e-29}} \
9.9999999999999994e-30
-test util-16.1.17.-28 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \
{expr {1e-28}} \
9.9999999999999997e-29
-test util-16.1.17.-27 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \
{expr {1e-27}} \
1e-27
-test util-16.1.17.-26 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \
{expr {1e-26}} \
1e-26
-test util-16.1.17.-25 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \
{expr {1e-25}} \
1e-25
-test util-16.1.17.-24 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \
{expr {1e-24}} \
9.9999999999999992e-25
-test util-16.1.17.-23 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \
{expr {1e-23}} \
9.9999999999999996e-24
-test util-16.1.17.-22 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \
{expr {1e-22}} \
1e-22
-test util-16.1.17.-21 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \
{expr {1e-21}} \
9.9999999999999991e-22
-test util-16.1.17.-20 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \
{expr {1e-20}} \
9.9999999999999995e-21
-test util-16.1.17.-19 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \
{expr {1e-19}} \
9.9999999999999998e-20
-test util-16.1.17.-18 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \
{expr {1e-18}} \
1.0000000000000001e-18
-test util-16.1.17.-17 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \
{expr {1e-17}} \
1.0000000000000001e-17
-test util-16.1.17.-16 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \
{expr {1e-16}} \
9.9999999999999998e-17
-test util-16.1.17.-15 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \
{expr {1e-15}} \
1.0000000000000001e-15
-test util-16.1.17.-14 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \
{expr {1e-14}} \
1e-14
-test util-16.1.17.-13 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \
{expr {1e-13}} \
1e-13
-test util-16.1.17.-12 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \
{expr {1e-12}} \
9.9999999999999998e-13
-test util-16.1.17.-11 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \
{expr {1e-11}} \
9.9999999999999994e-12
-test util-16.1.17.-10 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \
{expr {1e-10}} \
1e-10
-test util-16.1.17.-9 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \
{expr {1e-9}} \
1.0000000000000001e-09
-test util-16.1.17.-8 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \
{expr {1e-8}} \
1e-08
-test util-16.1.17.-7 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \
{expr {1e-7}} \
9.9999999999999995e-08
-test util-16.1.17.-6 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \
{expr {1e-6}} \
9.9999999999999995e-07
-test util-16.1.17.-5 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \
{expr {1e-5}} \
1.0000000000000001e-05
-test util-16.1.17.-4 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \
{expr {1e-4}} \
0.0001
-test util-16.1.17.-3 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \
{expr {1e-3}} \
0.001
-test util-16.1.17.-2 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \
{expr {1e-2}} \
0.01
-test util-16.1.17.-1 {8.4 compatible formatting of doubles} \
+test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \
{expr {1e-1}} \
0.10000000000000001
-test util-16.1.17.0 {8.4 compatible formatting of doubles} \
+test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \
{expr {1e0}} \
1.0
-test util-16.1.17.1 {8.4 compatible formatting of doubles} \
+test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \
{expr {1e1}} \
10.0
-test util-16.1.17.2 {8.4 compatible formatting of doubles} \
+test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \
{expr {1e2}} \
100.0
-test util-16.1.17.3 {8.4 compatible formatting of doubles} \
+test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \
{expr {1e3}} \
1000.0
-test util-16.1.17.4 {8.4 compatible formatting of doubles} \
+test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \
{expr {1e4}} \
10000.0
-test util-16.1.17.5 {8.4 compatible formatting of doubles} \
+test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \
{expr {1e5}} \
100000.0
-test util-16.1.17.6 {8.4 compatible formatting of doubles} \
+test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \
{expr {1e6}} \
1000000.0
-test util-16.1.17.7 {8.4 compatible formatting of doubles} \
+test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \
{expr {1e7}} \
10000000.0
-test util-16.1.17.8 {8.4 compatible formatting of doubles} \
+test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \
{expr {1e8}} \
100000000.0
-test util-16.1.17.9 {8.4 compatible formatting of doubles} \
+test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \
{expr {1e9}} \
1000000000.0
-test util-16.1.17.10 {8.4 compatible formatting of doubles} \
+test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \
{expr {1e10}} \
10000000000.0
-test util-16.1.17.11 {8.4 compatible formatting of doubles} \
+test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \
{expr {1e11}} \
100000000000.0
-test util-16.1.17.12 {8.4 compatible formatting of doubles} \
+test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \
{expr {1e12}} \
1000000000000.0
-test util-16.1.17.13 {8.4 compatible formatting of doubles} \
+test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \
{expr {1e13}} \
10000000000000.0
-test util-16.1.17.14 {8.4 compatible formatting of doubles} \
+test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \
{expr {1e14}} \
100000000000000.0
-test util-16.1.17.15 {8.4 compatible formatting of doubles} \
+test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \
{expr {1e15}} \
1000000000000000.0
-test util-16.1.17.16 {8.4 compatible formatting of doubles} \
+test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \
{expr {1e16}} \
10000000000000000.0
-test util-16.1.17.17 {8.4 compatible formatting of doubles} \
+test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \
{expr {1e17}} \
1e+17
-test util-16.1.17.18 {8.4 compatible formatting of doubles} \
+test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \
{expr {1e18}} \
1e+18
-test util-16.1.17.19 {8.4 compatible formatting of doubles} \
+test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \
{expr {1e19}} \
1e+19
-test util-16.1.17.20 {8.4 compatible formatting of doubles} \
+test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \
{expr {1e20}} \
1e+20
-test util-16.1.17.21 {8.4 compatible formatting of doubles} \
+test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \
{expr {1e21}} \
1e+21
-test util-16.1.17.22 {8.4 compatible formatting of doubles} \
+test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \
{expr {1e22}} \
1e+22
-test util-16.1.17.23 {8.4 compatible formatting of doubles} \
+test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \
{expr {1e23}} \
9.9999999999999992e+22
-test util-16.1.17.24 {8.4 compatible formatting of doubles} \
+test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \
{expr {1e24}} \
9.9999999999999998e+23
-test util-16.1.17.25 {8.4 compatible formatting of doubles} \
+test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \
{expr {1e25}} \
1.0000000000000001e+25
-test util-16.1.17.26 {8.4 compatible formatting of doubles} \
+test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \
{expr {1e26}} \
1e+26
-test util-16.1.17.27 {8.4 compatible formatting of doubles} \
+test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \
{expr {1e27}} \
1e+27
-test util-16.1.17.28 {8.4 compatible formatting of doubles} \
+test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \
{expr {1e28}} \
9.9999999999999996e+27
-test util-16.1.17.29 {8.4 compatible formatting of doubles} \
+test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \
{expr {1e29}} \
9.9999999999999991e+28
-test util-16.1.17.30 {8.4 compatible formatting of doubles} \
+test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \
{expr {1e30}} \
1e+30
-test util-16.1.17.31 {8.4 compatible formatting of doubles} \
+test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \
{expr {1e31}} \
9.9999999999999996e+30
-test util-16.1.17.32 {8.4 compatible formatting of doubles} \
+test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \
{expr {1e32}} \
1.0000000000000001e+32
-test util-16.1.17.33 {8.4 compatible formatting of doubles} \
+test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \
{expr {1e33}} \
9.9999999999999995e+32
-test util-16.1.17.34 {8.4 compatible formatting of doubles} \
+test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \
{expr {1e34}} \
9.9999999999999995e+33
-test util-16.1.17.35 {8.4 compatible formatting of doubles} \
+test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \
{expr {1e35}} \
9.9999999999999997e+34
-test util-16.1.17.36 {8.4 compatible formatting of doubles} \
+test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \
{expr {1e36}} \
1e+36
-test util-16.1.17.37 {8.4 compatible formatting of doubles} \
+test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \
{expr {1e37}} \
9.9999999999999995e+36
-test util-16.1.17.38 {8.4 compatible formatting of doubles} \
+test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \
{expr {1e38}} \
9.9999999999999998e+37
-test util-16.1.17.39 {8.4 compatible formatting of doubles} \
+test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \
{expr {1e39}} \
9.9999999999999994e+38
-test util-16.1.17.40 {8.4 compatible formatting of doubles} \
+test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \
{expr {1e40}} \
1e+40
-test util-16.1.17.41 {8.4 compatible formatting of doubles} \
+test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \
{expr {1e41}} \
1e+41
-test util-16.1.17.42 {8.4 compatible formatting of doubles} \
+test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \
{expr {1e42}} \
1e+42
-test util-16.1.17.43 {8.4 compatible formatting of doubles} \
+test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \
{expr {1e43}} \
1e+43
-test util-16.1.17.44 {8.4 compatible formatting of doubles} \
+test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \
{expr {1e44}} \
1.0000000000000001e+44
-test util-16.1.17.45 {8.4 compatible formatting of doubles} \
+test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \
{expr {1e45}} \
9.9999999999999993e+44
-test util-16.1.17.46 {8.4 compatible formatting of doubles} \
+test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \
{expr {1e46}} \
9.9999999999999999e+45
-test util-16.1.17.47 {8.4 compatible formatting of doubles} \
+test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \
{expr {1e47}} \
1e+47
-test util-16.1.17.48 {8.4 compatible formatting of doubles} \
+test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \
{expr {1e48}} \
1e+48
-test util-16.1.17.49 {8.4 compatible formatting of doubles} \
+test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \
{expr {1e49}} \
9.9999999999999995e+48
-test util-16.1.17.50 {8.4 compatible formatting of doubles} \
+test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \
{expr {1e50}} \
1.0000000000000001e+50
-test util-16.1.17.51 {8.4 compatible formatting of doubles} \
+test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \
{expr {1e51}} \
9.9999999999999999e+50
-test util-16.1.17.52 {8.4 compatible formatting of doubles} \
+test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \
{expr {1e52}} \
9.9999999999999999e+51
-test util-16.1.17.53 {8.4 compatible formatting of doubles} \
+test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \
{expr {1e53}} \
9.9999999999999999e+52
-test util-16.1.17.54 {8.4 compatible formatting of doubles} \
+test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \
{expr {1e54}} \
1.0000000000000001e+54
-test util-16.1.17.55 {8.4 compatible formatting of doubles} \
+test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \
{expr {1e55}} \
1e+55
-test util-16.1.17.56 {8.4 compatible formatting of doubles} \
+test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \
{expr {1e56}} \
1.0000000000000001e+56
-test util-16.1.17.57 {8.4 compatible formatting of doubles} \
+test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \
{expr {1e57}} \
1e+57
-test util-16.1.17.58 {8.4 compatible formatting of doubles} \
+test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \
{expr {1e58}} \
9.9999999999999994e+57
-test util-16.1.17.59 {8.4 compatible formatting of doubles} \
+test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \
{expr {1e59}} \
9.9999999999999997e+58
-test util-16.1.17.60 {8.4 compatible formatting of doubles} \
+test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \
{expr {1e60}} \
9.9999999999999995e+59
-test util-16.1.17.61 {8.4 compatible formatting of doubles} \
+test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \
{expr {1e61}} \
9.9999999999999995e+60
-test util-16.1.17.62 {8.4 compatible formatting of doubles} \
+test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \
{expr {1e62}} \
1e+62
-test util-16.1.17.63 {8.4 compatible formatting of doubles} \
+test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \
{expr {1e63}} \
1.0000000000000001e+63
-test util-16.1.17.64 {8.4 compatible formatting of doubles} \
+test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \
{expr {1e64}} \
1e+64
-test util-16.1.17.65 {8.4 compatible formatting of doubles} \
+test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \
{expr {1e65}} \
9.9999999999999999e+64
-test util-16.1.17.66 {8.4 compatible formatting of doubles} \
+test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \
{expr {1e66}} \
9.9999999999999995e+65
-test util-16.1.17.67 {8.4 compatible formatting of doubles} \
+test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \
{expr {1e67}} \
9.9999999999999998e+66
-test util-16.1.17.68 {8.4 compatible formatting of doubles} \
+test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \
{expr {1e68}} \
9.9999999999999995e+67
-test util-16.1.17.69 {8.4 compatible formatting of doubles} \
+test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \
{expr {1e69}} \
1.0000000000000001e+69
-test util-16.1.17.70 {8.4 compatible formatting of doubles} \
+test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \
{expr {1e70}} \
1.0000000000000001e+70
-test util-16.1.17.71 {8.4 compatible formatting of doubles} \
+test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \
{expr {1e71}} \
1e+71
-test util-16.1.17.72 {8.4 compatible formatting of doubles} \
+test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \
{expr {1e72}} \
9.9999999999999994e+71
-test util-16.1.17.73 {8.4 compatible formatting of doubles} \
+test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \
{expr {1e73}} \
9.9999999999999998e+72
-test util-16.1.17.74 {8.4 compatible formatting of doubles} \
+test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \
{expr {1e74}} \
9.9999999999999995e+73
-test util-16.1.17.75 {8.4 compatible formatting of doubles} \
+test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \
{expr {1e75}} \
9.9999999999999993e+74
-test util-16.1.17.76 {8.4 compatible formatting of doubles} \
+test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \
{expr {1e76}} \
1e+76
-test util-16.1.17.77 {8.4 compatible formatting of doubles} \
+test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \
{expr {1e77}} \
9.9999999999999998e+76
-test util-16.1.17.78 {8.4 compatible formatting of doubles} \
+test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \
{expr {1e78}} \
1e+78
-test util-16.1.17.79 {8.4 compatible formatting of doubles} \
+test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \
{expr {1e79}} \
9.9999999999999997e+78
-test util-16.1.17.80 {8.4 compatible formatting of doubles} \
+test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \
{expr {1e80}} \
1e+80
-test util-16.1.17.81 {8.4 compatible formatting of doubles} \
+test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \
{expr {1e81}} \
9.9999999999999992e+80
-test util-16.1.17.82 {8.4 compatible formatting of doubles} \
+test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \
{expr {1e82}} \
9.9999999999999996e+81
-test util-16.1.17.83 {8.4 compatible formatting of doubles} \
+test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \
{expr {1e83}} \
1e+83
-test util-16.1.17.84 {8.4 compatible formatting of doubles} \
+test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \
{expr {1e84}} \
1.0000000000000001e+84
-test util-16.1.17.85 {8.4 compatible formatting of doubles} \
+test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \
{expr {1e85}} \
1e+85
-test util-16.1.17.86 {8.4 compatible formatting of doubles} \
+test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \
{expr {1e86}} \
1e+86
-test util-16.1.17.87 {8.4 compatible formatting of doubles} \
+test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \
{expr {1e87}} \
9.9999999999999996e+86
-test util-16.1.17.88 {8.4 compatible formatting of doubles} \
+test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \
{expr {1e88}} \
9.9999999999999996e+87
-test util-16.1.17.89 {8.4 compatible formatting of doubles} \
+test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \
{expr {1e89}} \
9.9999999999999999e+88
-test util-16.1.17.90 {8.4 compatible formatting of doubles} \
+test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \
{expr {1e90}} \
9.9999999999999997e+89
-test util-16.1.17.91 {8.4 compatible formatting of doubles} \
+test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \
{expr {1e91}} \
1.0000000000000001e+91
-test util-16.1.17.92 {8.4 compatible formatting of doubles} \
+test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \
{expr {1e92}} \
1e+92
-test util-16.1.17.93 {8.4 compatible formatting of doubles} \
+test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \
{expr {1e93}} \
1e+93
-test util-16.1.17.94 {8.4 compatible formatting of doubles} \
+test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \
{expr {1e94}} \
1e+94
-test util-16.1.17.95 {8.4 compatible formatting of doubles} \
+test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \
{expr {1e95}} \
1e+95
-test util-16.1.17.96 {8.4 compatible formatting of doubles} \
+test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \
{expr {1e96}} \
1e+96
-test util-16.1.17.97 {8.4 compatible formatting of doubles} \
+test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \
{expr {1e97}} \
1.0000000000000001e+97
-test util-16.1.17.98 {8.4 compatible formatting of doubles} \
+test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \
{expr {1e98}} \
1e+98
-test util-16.1.17.99 {8.4 compatible formatting of doubles} \
+test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \
{expr {1e99}} \
9.9999999999999997e+98
-test util-16.1.17.100 {8.4 compatible formatting of doubles} \
+test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \
{expr {1e100}} \
1e+100
-test util-16.1.17.101 {8.4 compatible formatting of doubles} \
+test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \
{expr {1e101}} \
9.9999999999999998e+100
-test util-16.1.17.102 {8.4 compatible formatting of doubles} \
+test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \
{expr {1e102}} \
9.9999999999999998e+101
-test util-16.1.17.103 {8.4 compatible formatting of doubles} \
+test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \
{expr {1e103}} \
1e+103
-test util-16.1.17.104 {8.4 compatible formatting of doubles} \
+test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \
{expr {1e104}} \
1e+104
-test util-16.1.17.105 {8.4 compatible formatting of doubles} \
+test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \
{expr {1e105}} \
9.9999999999999994e+104
-test util-16.1.17.106 {8.4 compatible formatting of doubles} \
+test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \
{expr {1e106}} \
1.0000000000000001e+106
-test util-16.1.17.107 {8.4 compatible formatting of doubles} \
+test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \
{expr {1e107}} \
9.9999999999999997e+106
-test util-16.1.17.108 {8.4 compatible formatting of doubles} \
+test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \
{expr {1e108}} \
1e+108
-test util-16.1.17.109 {8.4 compatible formatting of doubles} \
+test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \
{expr {1e109}} \
9.9999999999999998e+108
-test util-16.1.17.110 {8.4 compatible formatting of doubles} \
+test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \
{expr {1e110}} \
1e+110
-test util-16.1.17.111 {8.4 compatible formatting of doubles} \
+test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \
{expr {1e111}} \
9.9999999999999996e+110
-test util-16.1.17.112 {8.4 compatible formatting of doubles} \
+test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \
{expr {1e112}} \
9.9999999999999993e+111
-test util-16.1.17.113 {8.4 compatible formatting of doubles} \
+test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \
{expr {1e113}} \
1e+113
-test util-16.1.17.114 {8.4 compatible formatting of doubles} \
+test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \
{expr {1e114}} \
1e+114
-test util-16.1.17.115 {8.4 compatible formatting of doubles} \
+test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \
{expr {1e115}} \
1e+115
-test util-16.1.17.116 {8.4 compatible formatting of doubles} \
+test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \
{expr {1e116}} \
1e+116
-test util-16.1.17.117 {8.4 compatible formatting of doubles} \
+test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \
{expr {1e117}} \
1.0000000000000001e+117
-test util-16.1.17.118 {8.4 compatible formatting of doubles} \
+test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \
{expr {1e118}} \
9.9999999999999997e+117
-test util-16.1.17.119 {8.4 compatible formatting of doubles} \
+test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \
{expr {1e119}} \
9.9999999999999994e+118
-test util-16.1.17.120 {8.4 compatible formatting of doubles} \
+test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \
{expr {1e120}} \
9.9999999999999998e+119
-test util-16.1.17.121 {8.4 compatible formatting of doubles} \
+test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \
{expr {1e121}} \
1e+121
-test util-16.1.17.122 {8.4 compatible formatting of doubles} \
+test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \
{expr {1e122}} \
1e+122
-test util-16.1.17.123 {8.4 compatible formatting of doubles} \
+test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \
{expr {1e123}} \
9.9999999999999998e+122
-test util-16.1.17.124 {8.4 compatible formatting of doubles} \
+test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \
{expr {1e124}} \
9.9999999999999995e+123
-test util-16.1.17.125 {8.4 compatible formatting of doubles} \
+test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \
{expr {1e125}} \
9.9999999999999992e+124
-test util-16.1.17.126 {8.4 compatible formatting of doubles} \
+test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \
{expr {1e126}} \
9.9999999999999992e+125
-test util-16.1.17.127 {8.4 compatible formatting of doubles} \
+test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \
{expr {1e127}} \
9.9999999999999995e+126
-test util-16.1.17.128 {8.4 compatible formatting of doubles} \
+test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \
{expr {1e128}} \
1.0000000000000001e+128
-test util-16.1.17.129 {8.4 compatible formatting of doubles} \
+test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \
{expr {1e129}} \
1e+129
-test util-16.1.17.130 {8.4 compatible formatting of doubles} \
+test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \
{expr {1e130}} \
1.0000000000000001e+130
-test util-16.1.17.131 {8.4 compatible formatting of doubles} \
+test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \
{expr {1e131}} \
9.9999999999999991e+130
-test util-16.1.17.132 {8.4 compatible formatting of doubles} \
+test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \
{expr {1e132}} \
9.9999999999999999e+131
-test util-16.1.17.133 {8.4 compatible formatting of doubles} \
+test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \
{expr {1e133}} \
1e+133
-test util-16.1.17.134 {8.4 compatible formatting of doubles} \
+test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \
{expr {1e134}} \
9.9999999999999992e+133
-test util-16.1.17.135 {8.4 compatible formatting of doubles} \
+test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \
{expr {1e135}} \
9.9999999999999996e+134
-test util-16.1.17.136 {8.4 compatible formatting of doubles} \
+test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \
{expr {1e136}} \
1.0000000000000001e+136
-test util-16.1.17.137 {8.4 compatible formatting of doubles} \
+test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \
{expr {1e137}} \
1e+137
-test util-16.1.17.138 {8.4 compatible formatting of doubles} \
+test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \
{expr {1e138}} \
1e+138
-test util-16.1.17.139 {8.4 compatible formatting of doubles} \
+test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \
{expr {1e139}} \
1e+139
-test util-16.1.17.140 {8.4 compatible formatting of doubles} \
+test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \
{expr {1e140}} \
1.0000000000000001e+140
-test util-16.1.17.141 {8.4 compatible formatting of doubles} \
+test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \
{expr {1e141}} \
1e+141
-test util-16.1.17.142 {8.4 compatible formatting of doubles} \
+test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \
{expr {1e142}} \
1.0000000000000001e+142
-test util-16.1.17.143 {8.4 compatible formatting of doubles} \
+test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \
{expr {1e143}} \
1e+143
-test util-16.1.17.144 {8.4 compatible formatting of doubles} \
+test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \
{expr {1e144}} \
1e+144
-test util-16.1.17.145 {8.4 compatible formatting of doubles} \
+test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \
{expr {1e145}} \
9.9999999999999999e+144
-test util-16.1.17.146 {8.4 compatible formatting of doubles} \
+test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \
{expr {1e146}} \
9.9999999999999993e+145
-test util-16.1.17.147 {8.4 compatible formatting of doubles} \
+test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \
{expr {1e147}} \
9.9999999999999998e+146
-test util-16.1.17.148 {8.4 compatible formatting of doubles} \
+test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \
{expr {1e148}} \
1e+148
-test util-16.1.17.149 {8.4 compatible formatting of doubles} \
+test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \
{expr {1e149}} \
1e+149
-test util-16.1.17.150 {8.4 compatible formatting of doubles} \
+test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \
{expr {1e150}} \
9.9999999999999998e+149
-test util-16.1.17.151 {8.4 compatible formatting of doubles} \
+test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \
{expr {1e151}} \
1e+151
-test util-16.1.17.152 {8.4 compatible formatting of doubles} \
+test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \
{expr {1e152}} \
1e+152
-test util-16.1.17.153 {8.4 compatible formatting of doubles} \
+test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \
{expr {1e153}} \
1e+153
-test util-16.1.17.154 {8.4 compatible formatting of doubles} \
+test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \
{expr {1e154}} \
1e+154
-test util-16.1.17.155 {8.4 compatible formatting of doubles} \
+test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \
{expr {1e155}} \
1e+155
-test util-16.1.17.156 {8.4 compatible formatting of doubles} \
+test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \
{expr {1e156}} \
9.9999999999999998e+155
-test util-16.1.17.157 {8.4 compatible formatting of doubles} \
+test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \
{expr {1e157}} \
9.9999999999999998e+156
-test util-16.1.17.158 {8.4 compatible formatting of doubles} \
+test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \
{expr {1e158}} \
9.9999999999999995e+157
-test util-16.1.17.159 {8.4 compatible formatting of doubles} \
+test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \
{expr {1e159}} \
9.9999999999999993e+158
-test util-16.1.17.160 {8.4 compatible formatting of doubles} \
+test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \
{expr {1e160}} \
1e+160
-test util-16.1.17.161 {8.4 compatible formatting of doubles} \
+test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \
{expr {1e161}} \
1e+161
-test util-16.1.17.162 {8.4 compatible formatting of doubles} \
+test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \
{expr {1e162}} \
9.9999999999999994e+161
-test util-16.1.17.163 {8.4 compatible formatting of doubles} \
+test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \
{expr {1e163}} \
9.9999999999999994e+162
-test util-16.1.17.164 {8.4 compatible formatting of doubles} \
+test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \
{expr {1e164}} \
1e+164
-test util-16.1.17.165 {8.4 compatible formatting of doubles} \
+test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \
{expr {1e165}} \
9.999999999999999e+164
-test util-16.1.17.166 {8.4 compatible formatting of doubles} \
+test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \
{expr {1e166}} \
9.9999999999999994e+165
-test util-16.1.17.167 {8.4 compatible formatting of doubles} \
+test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \
{expr {1e167}} \
1e+167
-test util-16.1.17.168 {8.4 compatible formatting of doubles} \
+test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \
{expr {1e168}} \
9.9999999999999993e+167
-test util-16.1.17.169 {8.4 compatible formatting of doubles} \
+test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \
{expr {1e169}} \
9.9999999999999993e+168
-test util-16.1.17.170 {8.4 compatible formatting of doubles} \
+test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \
{expr {1e170}} \
1e+170
-test util-16.1.17.171 {8.4 compatible formatting of doubles} \
+test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \
{expr {1e171}} \
9.9999999999999995e+170
-test util-16.1.17.172 {8.4 compatible formatting of doubles} \
+test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \
{expr {1e172}} \
1.0000000000000001e+172
-test util-16.1.17.173 {8.4 compatible formatting of doubles} \
+test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \
{expr {1e173}} \
1e+173
-test util-16.1.17.174 {8.4 compatible formatting of doubles} \
+test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \
{expr {1e174}} \
1.0000000000000001e+174
-test util-16.1.17.175 {8.4 compatible formatting of doubles} \
+test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \
{expr {1e175}} \
9.9999999999999994e+174
-test util-16.1.17.176 {8.4 compatible formatting of doubles} \
+test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \
{expr {1e176}} \
1e+176
-test util-16.1.17.177 {8.4 compatible formatting of doubles} \
+test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \
{expr {1e177}} \
1e+177
-test util-16.1.17.178 {8.4 compatible formatting of doubles} \
+test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \
{expr {1e178}} \
1.0000000000000001e+178
-test util-16.1.17.179 {8.4 compatible formatting of doubles} \
+test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \
{expr {1e179}} \
9.9999999999999998e+178
-test util-16.1.17.180 {8.4 compatible formatting of doubles} \
+test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \
{expr {1e180}} \
1e+180
-test util-16.1.17.181 {8.4 compatible formatting of doubles} \
+test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \
{expr {1e181}} \
9.9999999999999992e+180
-test util-16.1.17.182 {8.4 compatible formatting of doubles} \
+test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \
{expr {1e182}} \
1.0000000000000001e+182
-test util-16.1.17.183 {8.4 compatible formatting of doubles} \
+test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \
{expr {1e183}} \
9.9999999999999995e+182
-test util-16.1.17.184 {8.4 compatible formatting of doubles} \
+test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \
{expr {1e184}} \
1e+184
-test util-16.1.17.185 {8.4 compatible formatting of doubles} \
+test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \
{expr {1e185}} \
9.9999999999999998e+184
-test util-16.1.17.186 {8.4 compatible formatting of doubles} \
+test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \
{expr {1e186}} \
9.9999999999999998e+185
-test util-16.1.17.187 {8.4 compatible formatting of doubles} \
+test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \
{expr {1e187}} \
9.9999999999999991e+186
-test util-16.1.17.188 {8.4 compatible formatting of doubles} \
+test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \
{expr {1e188}} \
1e+188
-test util-16.1.17.189 {8.4 compatible formatting of doubles} \
+test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \
{expr {1e189}} \
1e+189
-test util-16.1.17.190 {8.4 compatible formatting of doubles} \
+test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \
{expr {1e190}} \
1.0000000000000001e+190
-test util-16.1.17.191 {8.4 compatible formatting of doubles} \
+test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \
{expr {1e191}} \
1.0000000000000001e+191
-test util-16.1.17.192 {8.4 compatible formatting of doubles} \
+test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \
{expr {1e192}} \
1e+192
-test util-16.1.17.193 {8.4 compatible formatting of doubles} \
+test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \
{expr {1e193}} \
1.0000000000000001e+193
-test util-16.1.17.194 {8.4 compatible formatting of doubles} \
+test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \
{expr {1e194}} \
9.9999999999999994e+193
-test util-16.1.17.195 {8.4 compatible formatting of doubles} \
+test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \
{expr {1e195}} \
9.9999999999999998e+194
-test util-16.1.17.196 {8.4 compatible formatting of doubles} \
+test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \
{expr {1e196}} \
9.9999999999999995e+195
-test util-16.1.17.197 {8.4 compatible formatting of doubles} \
+test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \
{expr {1e197}} \
9.9999999999999995e+196
-test util-16.1.17.198 {8.4 compatible formatting of doubles} \
+test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \
{expr {1e198}} \
1e+198
-test util-16.1.17.199 {8.4 compatible formatting of doubles} \
+test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \
{expr {1e199}} \
1.0000000000000001e+199
-test util-16.1.17.200 {8.4 compatible formatting of doubles} \
+test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \
{expr {1e200}} \
9.9999999999999997e+199
-test util-16.1.17.201 {8.4 compatible formatting of doubles} \
+test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \
{expr {1e201}} \
1e+201
-test util-16.1.17.202 {8.4 compatible formatting of doubles} \
+test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \
{expr {1e202}} \
9.999999999999999e+201
-test util-16.1.17.203 {8.4 compatible formatting of doubles} \
+test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \
{expr {1e203}} \
9.9999999999999999e+202
-test util-16.1.17.204 {8.4 compatible formatting of doubles} \
+test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \
{expr {1e204}} \
9.9999999999999999e+203
-test util-16.1.17.205 {8.4 compatible formatting of doubles} \
+test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \
{expr {1e205}} \
1e+205
-test util-16.1.17.206 {8.4 compatible formatting of doubles} \
+test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \
{expr {1e206}} \
1e+206
-test util-16.1.17.207 {8.4 compatible formatting of doubles} \
+test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \
{expr {1e207}} \
1e+207
-test util-16.1.17.208 {8.4 compatible formatting of doubles} \
+test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \
{expr {1e208}} \
9.9999999999999998e+207
-test util-16.1.17.209 {8.4 compatible formatting of doubles} \
+test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \
{expr {1e209}} \
1.0000000000000001e+209
-test util-16.1.17.210 {8.4 compatible formatting of doubles} \
+test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \
{expr {1e210}} \
9.9999999999999993e+209
-test util-16.1.17.211 {8.4 compatible formatting of doubles} \
+test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \
{expr {1e211}} \
9.9999999999999996e+210
-test util-16.1.17.212 {8.4 compatible formatting of doubles} \
+test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \
{expr {1e212}} \
9.9999999999999991e+211
-test util-16.1.17.213 {8.4 compatible formatting of doubles} \
+test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \
{expr {1e213}} \
9.9999999999999998e+212
-test util-16.1.17.214 {8.4 compatible formatting of doubles} \
+test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \
{expr {1e214}} \
9.9999999999999995e+213
-test util-16.1.17.215 {8.4 compatible formatting of doubles} \
+test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \
{expr {1e215}} \
9.9999999999999991e+214
-test util-16.1.17.216 {8.4 compatible formatting of doubles} \
+test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \
{expr {1e216}} \
1e+216
-test util-16.1.17.217 {8.4 compatible formatting of doubles} \
+test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \
{expr {1e217}} \
9.9999999999999996e+216
-test util-16.1.17.218 {8.4 compatible formatting of doubles} \
+test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \
{expr {1e218}} \
1.0000000000000001e+218
-test util-16.1.17.219 {8.4 compatible formatting of doubles} \
+test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \
{expr {1e219}} \
9.9999999999999997e+218
-test util-16.1.17.220 {8.4 compatible formatting of doubles} \
+test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \
{expr {1e220}} \
1e+220
-test util-16.1.17.221 {8.4 compatible formatting of doubles} \
+test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \
{expr {1e221}} \
1e+221
-test util-16.1.17.222 {8.4 compatible formatting of doubles} \
+test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \
{expr {1e222}} \
1e+222
-test util-16.1.17.223 {8.4 compatible formatting of doubles} \
+test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \
{expr {1e223}} \
1e+223
-test util-16.1.17.224 {8.4 compatible formatting of doubles} \
+test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \
{expr {1e224}} \
9.9999999999999997e+223
-test util-16.1.17.225 {8.4 compatible formatting of doubles} \
+test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \
{expr {1e225}} \
9.9999999999999993e+224
-test util-16.1.17.226 {8.4 compatible formatting of doubles} \
+test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \
{expr {1e226}} \
9.9999999999999996e+225
-test util-16.1.17.227 {8.4 compatible formatting of doubles} \
+test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \
{expr {1e227}} \
1.0000000000000001e+227
-test util-16.1.17.228 {8.4 compatible formatting of doubles} \
+test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \
{expr {1e228}} \
9.9999999999999992e+227
-test util-16.1.17.229 {8.4 compatible formatting of doubles} \
+test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \
{expr {1e229}} \
9.9999999999999999e+228
-test util-16.1.17.230 {8.4 compatible formatting of doubles} \
+test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \
{expr {1e230}} \
1.0000000000000001e+230
-test util-16.1.17.231 {8.4 compatible formatting of doubles} \
+test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \
{expr {1e231}} \
1.0000000000000001e+231
-test util-16.1.17.232 {8.4 compatible formatting of doubles} \
+test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \
{expr {1e232}} \
1.0000000000000001e+232
-test util-16.1.17.233 {8.4 compatible formatting of doubles} \
+test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \
{expr {1e233}} \
9.9999999999999997e+232
-test util-16.1.17.234 {8.4 compatible formatting of doubles} \
+test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \
{expr {1e234}} \
1e+234
-test util-16.1.17.235 {8.4 compatible formatting of doubles} \
+test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \
{expr {1e235}} \
1.0000000000000001e+235
-test util-16.1.17.236 {8.4 compatible formatting of doubles} \
+test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \
{expr {1e236}} \
1.0000000000000001e+236
-test util-16.1.17.237 {8.4 compatible formatting of doubles} \
+test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \
{expr {1e237}} \
9.9999999999999994e+236
-test util-16.1.17.238 {8.4 compatible formatting of doubles} \
+test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \
{expr {1e238}} \
1e+238
-test util-16.1.17.239 {8.4 compatible formatting of doubles} \
+test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \
{expr {1e239}} \
9.9999999999999999e+238
-test util-16.1.17.240 {8.4 compatible formatting of doubles} \
+test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \
{expr {1e240}} \
1e+240
-test util-16.1.17.241 {8.4 compatible formatting of doubles} \
+test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \
{expr {1e241}} \
1.0000000000000001e+241
-test util-16.1.17.242 {8.4 compatible formatting of doubles} \
+test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \
{expr {1e242}} \
1.0000000000000001e+242
-test util-16.1.17.243 {8.4 compatible formatting of doubles} \
+test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \
{expr {1e243}} \
1.0000000000000001e+243
-test util-16.1.17.244 {8.4 compatible formatting of doubles} \
+test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \
{expr {1e244}} \
1.0000000000000001e+244
-test util-16.1.17.245 {8.4 compatible formatting of doubles} \
+test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \
{expr {1e245}} \
1e+245
-test util-16.1.17.246 {8.4 compatible formatting of doubles} \
+test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \
{expr {1e246}} \
1.0000000000000001e+246
-test util-16.1.17.247 {8.4 compatible formatting of doubles} \
+test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \
{expr {1e247}} \
9.9999999999999995e+246
-test util-16.1.17.248 {8.4 compatible formatting of doubles} \
+test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \
{expr {1e248}} \
1e+248
-test util-16.1.17.249 {8.4 compatible formatting of doubles} \
+test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \
{expr {1e249}} \
9.9999999999999992e+248
-test util-16.1.17.250 {8.4 compatible formatting of doubles} \
+test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \
{expr {1e250}} \
9.9999999999999992e+249
-test util-16.1.17.251 {8.4 compatible formatting of doubles} \
+test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \
{expr {1e251}} \
1e+251
-test util-16.1.17.252 {8.4 compatible formatting of doubles} \
+test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \
{expr {1e252}} \
1.0000000000000001e+252
-test util-16.1.17.253 {8.4 compatible formatting of doubles} \
+test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \
{expr {1e253}} \
9.9999999999999994e+252
-test util-16.1.17.254 {8.4 compatible formatting of doubles} \
+test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \
{expr {1e254}} \
9.9999999999999994e+253
-test util-16.1.17.255 {8.4 compatible formatting of doubles} \
+test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \
{expr {1e255}} \
9.9999999999999999e+254
-test util-16.1.17.256 {8.4 compatible formatting of doubles} \
+test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \
{expr {1e256}} \
1e+256
-test util-16.1.17.257 {8.4 compatible formatting of doubles} \
+test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \
{expr {1e257}} \
1e+257
-test util-16.1.17.258 {8.4 compatible formatting of doubles} \
+test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \
{expr {1e258}} \
1.0000000000000001e+258
-test util-16.1.17.259 {8.4 compatible formatting of doubles} \
+test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \
{expr {1e259}} \
9.9999999999999993e+258
-test util-16.1.17.260 {8.4 compatible formatting of doubles} \
+test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \
{expr {1e260}} \
1.0000000000000001e+260
-test util-16.1.17.261 {8.4 compatible formatting of doubles} \
+test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \
{expr {1e261}} \
9.9999999999999993e+260
-test util-16.1.17.262 {8.4 compatible formatting of doubles} \
+test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \
{expr {1e262}} \
1e+262
-test util-16.1.17.263 {8.4 compatible formatting of doubles} \
+test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \
{expr {1e263}} \
1e+263
-test util-16.1.17.264 {8.4 compatible formatting of doubles} \
+test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \
{expr {1e264}} \
1e+264
-test util-16.1.17.265 {8.4 compatible formatting of doubles} \
+test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \
{expr {1e265}} \
1.0000000000000001e+265
-test util-16.1.17.266 {8.4 compatible formatting of doubles} \
+test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \
{expr {1e266}} \
1e+266
-test util-16.1.17.267 {8.4 compatible formatting of doubles} \
+test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \
{expr {1e267}} \
9.9999999999999997e+266
-test util-16.1.17.268 {8.4 compatible formatting of doubles} \
+test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \
{expr {1e268}} \
9.9999999999999997e+267
-test util-16.1.17.269 {8.4 compatible formatting of doubles} \
+test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \
{expr {1e269}} \
1e+269
-test util-16.1.17.270 {8.4 compatible formatting of doubles} \
+test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \
{expr {1e270}} \
1e+270
-test util-16.1.17.271 {8.4 compatible formatting of doubles} \
+test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \
{expr {1e271}} \
9.9999999999999995e+270
-test util-16.1.17.272 {8.4 compatible formatting of doubles} \
+test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \
{expr {1e272}} \
1.0000000000000001e+272
-test util-16.1.17.273 {8.4 compatible formatting of doubles} \
+test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \
{expr {1e273}} \
9.9999999999999995e+272
-test util-16.1.17.274 {8.4 compatible formatting of doubles} \
+test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \
{expr {1e274}} \
9.9999999999999992e+273
-test util-16.1.17.275 {8.4 compatible formatting of doubles} \
+test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \
{expr {1e275}} \
9.9999999999999996e+274
-test util-16.1.17.276 {8.4 compatible formatting of doubles} \
+test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \
{expr {1e276}} \
1.0000000000000001e+276
-test util-16.1.17.277 {8.4 compatible formatting of doubles} \
+test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \
{expr {1e277}} \
1e+277
-test util-16.1.17.278 {8.4 compatible formatting of doubles} \
+test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \
{expr {1e278}} \
9.9999999999999996e+277
-test util-16.1.17.279 {8.4 compatible formatting of doubles} \
+test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \
{expr {1e279}} \
1.0000000000000001e+279
-test util-16.1.17.280 {8.4 compatible formatting of doubles} \
+test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \
{expr {1e280}} \
1e+280
-test util-16.1.17.281 {8.4 compatible formatting of doubles} \
+test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \
{expr {1e281}} \
1e+281
-test util-16.1.17.282 {8.4 compatible formatting of doubles} \
+test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \
{expr {1e282}} \
1e+282
-test util-16.1.17.283 {8.4 compatible formatting of doubles} \
+test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \
{expr {1e283}} \
9.9999999999999996e+282
-test util-16.1.17.284 {8.4 compatible formatting of doubles} \
+test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \
{expr {1e284}} \
1.0000000000000001e+284
-test util-16.1.17.285 {8.4 compatible formatting of doubles} \
+test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \
{expr {1e285}} \
9.9999999999999998e+284
-test util-16.1.17.286 {8.4 compatible formatting of doubles} \
+test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \
{expr {1e286}} \
1e+286
-test util-16.1.17.287 {8.4 compatible formatting of doubles} \
+test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \
{expr {1e287}} \
1.0000000000000001e+287
-test util-16.1.17.288 {8.4 compatible formatting of doubles} \
+test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \
{expr {1e288}} \
1e+288
-test util-16.1.17.289 {8.4 compatible formatting of doubles} \
+test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \
{expr {1e289}} \
1.0000000000000001e+289
-test util-16.1.17.290 {8.4 compatible formatting of doubles} \
+test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \
{expr {1e290}} \
1.0000000000000001e+290
-test util-16.1.17.291 {8.4 compatible formatting of doubles} \
+test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \
{expr {1e291}} \
9.9999999999999996e+290
-test util-16.1.17.292 {8.4 compatible formatting of doubles} \
+test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \
{expr {1e292}} \
1e+292
-test util-16.1.17.293 {8.4 compatible formatting of doubles} \
+test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \
{expr {1e293}} \
9.9999999999999992e+292
-test util-16.1.17.294 {8.4 compatible formatting of doubles} \
+test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \
{expr {1e294}} \
1.0000000000000001e+294
-test util-16.1.17.295 {8.4 compatible formatting of doubles} \
+test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \
{expr {1e295}} \
9.9999999999999998e+294
-test util-16.1.17.296 {8.4 compatible formatting of doubles} \
+test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \
{expr {1e296}} \
9.9999999999999998e+295
-test util-16.1.17.297 {8.4 compatible formatting of doubles} \
+test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \
{expr {1e297}} \
1e+297
-test util-16.1.17.298 {8.4 compatible formatting of doubles} \
+test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \
{expr {1e298}} \
9.9999999999999996e+297
-test util-16.1.17.299 {8.4 compatible formatting of doubles} \
+test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \
{expr {1e299}} \
1.0000000000000001e+299
-test util-16.1.17.300 {8.4 compatible formatting of doubles} \
+test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \
{expr {1e300}} \
1.0000000000000001e+300
-test util-16.1.17.301 {8.4 compatible formatting of doubles} \
+test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \
{expr {1e301}} \
1.0000000000000001e+301
-test util-16.1.17.302 {8.4 compatible formatting of doubles} \
+test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \
{expr {1e302}} \
1.0000000000000001e+302
-test util-16.1.17.303 {8.4 compatible formatting of doubles} \
+test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \
{expr {1e303}} \
1e+303
-test util-16.1.17.304 {8.4 compatible formatting of doubles} \
+test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \
{expr {1e304}} \
9.9999999999999994e+303
-test util-16.1.17.305 {8.4 compatible formatting of doubles} \
+test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \
{expr {1e305}} \
9.9999999999999994e+304
-test util-16.1.17.306 {8.4 compatible formatting of doubles} \
+test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \
{expr {1e306}} \
1e+306
-test util-16.1.17.307 {8.4 compatible formatting of doubles} \
+test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \
{expr {1e307}} \
9.9999999999999999e+306
@@ -4063,7 +4130,57 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
0x4400000000000000 0xc400000000000000
}]
-set ::tcl_precision $saved_precision
+test util-18.1 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr {2**63-1}]
+} {9223372036854775807}
+
+test util-18.2 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr {2**63-1}]
+} {9223372036854775807}
+
+test util-18.3 {Tcl_ObjPrintf} {testprint} {
+ testprint %qd [expr {2**63-1}]
+} {9223372036854775807}
+
+test util-18.4 {Tcl_ObjPrintf} {testprint} {
+ testprint %jd [expr {2**63-1}]
+} {9223372036854775807}
+
+test util-18.5 {Tcl_ObjPrintf} {testprint} {
+ testprint %lld [expr {-2**63}]
+} {-9223372036854775808}
+
+test util-18.6 {Tcl_ObjPrintf} {testprint} {
+ testprint %I64d [expr {-2**63}]
+} {-9223372036854775808}
+
+test util-18.7 {Tcl_ObjPrintf} {testprint} {
+ testprint %qd [expr {-2**63}]
+} {-9223372036854775808}
+
+test util-18.8 {Tcl_ObjPrintf} {testprint} {
+ testprint %jd [expr {-2**63}]
+} {-9223372036854775808}
+
+test util-18.9 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %I32d" [expr {-2**63+2}]
+} {-9223372036854775806 2}
+
+test util-18.10 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %p" 65535
+} {65535 0xffff}
+
+test util-18.11 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %td" 65536
+} {65536 65536}
+
+test util-18.12 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %Id" 65537
+} {65537 65537}
+
+if {[catch {set ::tcl_precision $saved_precision}]} {
+ unset ::tcl_precision
+}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/var.test b/tests/var.test
index 9ad63ac..5300adc 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -8,8 +8,8 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
@@ -41,6 +41,7 @@ if {[testConstraint memory]} {
}
}
+
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {unset xx}
@@ -202,27 +203,27 @@ test var-1.19 {TclLookupVar, right error message when parsing variable name} -bo
[format set] thisvar(doesntexist)
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
- proc p [list \u20ac \xe4] {info vars}
+ proc p [list € ä] {info vars}
} -body {
# test variable with non-ascii name is available (euro and a-uml chars here):
list \
[p 1 2] \
- [apply [list [list \u20ac \xe4] {info vars}] 1 2] \
- [apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \
+ [apply [list [list € ä] {info vars}] 1 2] \
+ [apply [list [list [list € €] [list ä ä]] {info vars}]] \
} -cleanup {
rename p {}
-} -result [lrepeat 3 [list \u20ac \xe4]]
+} -result [lrepeat 3 [list € ä]]
test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup {
- proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}
+ proc p [list [list € v€] [list ä vä]] {list [set €] [set ä]}
} -body {
# test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here):
list \
[p] \
- [apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \
- [apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \
+ [apply [list [list € ä] {list [set €] [set ä]}] v€ vä] \
+ [apply [list [list [list € v€] [list ä vä]] {list [set €] [set ä]}]] \
} -cleanup {
rename p {}
-} -result [lrepeat 3 [list v\u20ac v\xe4]]
+} -result [lrepeat 3 [list v€ vä]]
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
@@ -1016,9 +1017,6 @@ test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
} -result 1
test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
- proc getbytes {} {
- lindex [split [memory info] \n] 3 3
- }
proc doit k {
variable A
set A($k) {}
@@ -1038,13 +1036,9 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
- rename getbytes {}
rename doit {}
} -result 0
test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup {
- proc getbytes {} {
- lindex [split [memory info] \n] 3 3
- }
proc doit {} {
interp create child
child eval {
@@ -1066,15 +1060,431 @@ test var-22.1 {leak in localVarName internalrep: Bug 80304238ac} -setup {
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
- rename getbytes {}
rename doit {}
} -result 0
+test var-22.2 {leak in parsedVarName} -constraints memory -body {
+ set i 0
+ leaktest {lappend x($i)}
+} -cleanup {
+ unset -nocomplain i x
+} -result 0
+unset -nocomplain a k v
+test var-23.1 {array command, for loop, too many args} -returnCodes error -body {
+ array for {k v} c d e {}
+} -result {wrong # args: should be "array for {key value} arrayName script"}
+test var-23.2 {array command, for loop, not enough args} -returnCodes error -body {
+ array for {k v} {}
+} -result {wrong # args: should be "array for {key value} arrayName script"}
+test var-23.3 {array command, for loop, too many list args} -setup {
+ unset -nocomplain a
+} -returnCodes error -body {
+ array for {k v w} a {}
+} -result {must have two variable names}
+test var-23.4 {array command, for loop, not enough list args} -setup {
+ unset -nocomplain a
+} -returnCodes error -body {
+ array for {k} a {}
+} -result {must have two variable names}
+test var-23.5 {array command, for loop, no array} -setup {
+ unset -nocomplain a
+} -returnCodes error -body {
+ array for {k v} a {}
+} -result {"a" isn't an array}
+test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup {
+ catch {rename p ""}
+} -returnCodes error -body {
+ apply {{x} {
+ if {$x==1} {
+ return [array for {k v} a {}]
+ }
+ set a(x) 123
+ }} 1
+} -result {"a" isn't an array}
+test var-23.7 {array enumeration} -setup {
+ unset -nocomplain a
+ set reslist [list]
+} -body {
+ array set a {a 1 b 2 c 3}
+ array for {k v} a {
+ lappend reslist $k $v
+ }
+ lsort -stride 2 -index 0 $reslist
+} -cleanup {
+ unset -nocomplain a
+ unset -nocomplain reslist
+} -result {a 1 b 2 c 3}
+test var-23.9 {array enumeration, nested} -setup {
+ unset -nocomplain a
+ set reslist [list]
+} -body {
+ array set a {a 1 b 2 c 3}
+ array for {k1 v1} a {
+ lappend reslist $k1 $v1
+ set r2 {}
+ array for {k2 v2} a {
+ lappend r2 $k2 $v2
+ }
+ lappend reslist [lsort -stride 2 -index 0 $r2]
+ }
+ # there is no guarantee in which order the array contents will be
+ # returned.
+ lsort -stride 3 -index 0 $reslist
+} -cleanup {
+ unset -nocomplain a
+ unset -nocomplain reslist
+} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}}
+test var-23.10 {array enumeration, delete key} -match glob -setup {
+ unset -nocomplain a
+ set reslist [list]
+} -body {
+ set retval {}
+ try {
+ array set a {a 1 b 2 c 3 d 4}
+ array for {k v} a {
+ lappend reslist $k $v
+ if { $k eq "a" } {
+ unset a(c)
+ }
+ }
+ lsort -stride 2 -index 0 $reslist
+ } on error {err res} {
+ set retval [dict get $res -errorinfo]
+ }
+ set retval
+} -cleanup {
+ unset -nocomplain a
+ unset -nocomplain reslist
+ unset -nocomplain retval
+} -result {array changed during iteration*}
+test var-23.11 {array enumeration, insert key} -match glob -setup {
+ unset -nocomplain a
+ set reslist [list]
+} -body {
+ set retval {}
+ try {
+ array set a {a 1 b 2 c 3 d 4}
+ array for {k v} a {
+ lappend reslist $k $v
+ if { $k eq "a" } {
+ set a(e) 5
+ }
+ }
+ lsort -stride 2 -index 0 $reslist
+ } on error {err res} {
+ set retval [dict get $res -errorinfo]
+ }
+} -cleanup {
+ unset -nocomplain a
+ unset -nocomplain reslist
+} -result {array changed during iteration*}
+test var-23.12 {array enumeration, change value} -setup {
+ unset -nocomplain a
+ set reslist [list]
+} -body {
+ array set a {a 1 b 2 c 3}
+ array for {k v} a {
+ lappend reslist $k $v
+ if { $k eq "a" } {
+ set a(c) 9
+ }
+ }
+ lsort -stride 2 -index 0 $reslist
+} -cleanup {
+ unset -nocomplain a
+ unset -nocomplain reslist
+} -result {a 1 b 2 c 9}
+test var-23.13 {array enumeration, number of traces} -setup {
+ set ::countarrayfor 0
+ proc ::tracearrayfor { args } {
+ incr ::countarrayfor
+ }
+ unset -nocomplain ::a
+ set reslist [list]
+} -body {
+ array set ::a {a 1 b 2 c 3}
+ foreach {k} [array names a] {
+ trace add variable ::a($k) read ::tracearrayfor
+ }
+ array for {k v} ::a {
+ lappend reslist $k $v
+ }
+ set ::countarrayfor
+} -cleanup {
+ unset -nocomplain ::countarrayfor
+ unset -nocomplain ::a
+ unset -nocomplain reslist
+} -result 3
+test var-23.14 {array for, shared arguments} -setup {
+ set vn {k v}
+ unset -nocomplain $vn
+} -body {
+ array set $vn {a 1 b 2 c 3}
+ array for $vn $vn {}
+} -cleanup {
+ unset -nocomplain $vn vn
+} -result {}
+
+test var-24.1 {array default set and get: interpreted} -setup {
+ unset -nocomplain ary
+} -body {
+ array set ary {a 3}
+ array default set ary 7
+ list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \
+ [array default get ary]
+} -cleanup {
+ unset -nocomplain ary
+} -result {3 7 1 0 7}
+test var-24.2 {array default set and get: compiled} {
+ apply {{} {
+ array set ary {a 3}
+ array default set ary 7
+ list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \
+ [array default get ary]
+ }}
+} {3 7 1 0 7}
+test var-24.3 {array default unset: interpreted} -setup {
+ unset -nocomplain ary
+} -body {
+ array set ary {a 3}
+ array default set ary 7
+ list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}]
+} -cleanup {
+ unset -nocomplain ary
+} -result {3 7 {} 3 1}
+test var-24.4 {array default unset: compiled} {
+ apply {{} {
+ array set ary {a 3}
+ array default set ary 7
+ list $ary(a) $ary(b) [array default unset ary] $ary(a) \
+ [catch {set ary(b)}]
+ }}
+} {3 7 {} 3 1}
+test var-24.5 {array default exists: interpreted} -setup {
+ unset -nocomplain ary result
+ set result {}
+} -body {
+ array set ary {a 3}
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default set ary 7
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default unset ary
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ unset ary
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default set ary 11
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+} -cleanup {
+ unset -nocomplain ary result
+} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1}
+test var-24.6 {array default exists: compiled} {
+ apply {{} {
+ array set ary {a 3}
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default set ary 7
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default unset ary
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ unset ary
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ array default set ary 11
+ lappend result [info exists ary],[array exists ary],[array default exists ary]
+ }}
+} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1}
+test var-24.7 {array default and append: interpreted} -setup {
+ unset -nocomplain ary result
+ set result {}
+} -body {
+ array default set ary grill
+ lappend result [array size ary] [info exist ary(x)]
+ append ary(x) abc
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ append ary(x) def
+ append ary(y) ghi
+ lappend result [array size ary] $ary(x) $ary(y)
+} -cleanup {
+ unset -nocomplain ary result
+} -result {0 0 1 grillabc 2 grillabcdef ghi}
+test var-24.8 {array default and append: compiled} {
+ apply {{} {
+ array default set ary grill
+ lappend result [array size ary] [info exist ary(x)]
+ append ary(x) abc
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ append ary(x) def
+ append ary(y) ghi
+ lappend result [array size ary] $ary(x) $ary(y)
+ }}
+} {0 0 1 grillabc 2 grillabcdef ghi}
+test var-24.9 {array default and lappend: interpreted} -setup {
+ unset -nocomplain ary result
+ set result {}
+} -body {
+ array default set ary grill
+ lappend result [array size ary] [info exist ary(x)]
+ lappend ary(x) abc
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ lappend ary(x) def
+ lappend ary(y) ghi
+ lappend result [array size ary] $ary(x) $ary(y)
+} -cleanup {
+ unset -nocomplain ary result
+} -result {0 0 1 {grill abc} 2 {grill abc def} ghi}
+test var-24.10 {array default and lappend: compiled} {
+ apply {{} {
+ array default set ary grill
+ lappend result [array size ary] [info exist ary(x)]
+ lappend ary(x) abc
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ lappend ary(x) def
+ lappend ary(y) ghi
+ lappend result [array size ary] $ary(x) $ary(y)
+ }}
+} {0 0 1 {grill abc} 2 {grill abc def} ghi}
+test var-24.11 {array default and incr: interpreted} -setup {
+ unset -nocomplain ary result
+ set result {}
+} -body {
+ array default set ary 7
+ lappend result [array size ary] [info exist ary(x)]
+ incr ary(x) 11
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ incr ary(x)
+ incr ary(y)
+ lappend result [array size ary] $ary(x) $ary(y)
+} -cleanup {
+ unset -nocomplain ary result
+} -result {0 0 1 18 2 19 1}
+test var-24.12 {array default and incr: compiled} {
+ apply {{} {
+ array default set ary 7
+ lappend result [array size ary] [info exist ary(x)]
+ incr ary(x) 11
+ lappend result [array size ary] $ary(x)
+ array default unset ary
+ incr ary(x)
+ incr ary(y)
+ lappend result [array size ary] $ary(x) $ary(y)
+ }}
+} {0 0 1 18 2 19 1}
+test var-24.13 {array default and dict: interpreted} -setup {
+ unset -nocomplain ary x y z
+} -body {
+ array default set ary {x y}
+ dict lappend ary(p) x z
+ dict update ary(q) x y {
+ set y z
+ }
+ dict with ary(r) {
+ set x 123
+ }
+ lsort -stride 2 -index 0 [array get ary]
+} -cleanup {
+ unset -nocomplain ary x y z
+} -result {p {x {y z}} q {x z} r {x 123}}
+test var-24.14 {array default and dict: compiled} {
+ lsort -stride 2 -index 0 [apply {{} {
+ array default set ary {x y}
+ dict lappend ary(p) x z
+ dict update ary(q) x y {
+ set y z
+ }
+ dict with ary(r) {
+ set x 123
+ }
+ array get ary
+ }}]
+} {p {x {y z}} q {x z} r {x 123}}
+test var-24.15 {array default set and get: two-level} {
+ apply {{} {
+ array set ary {a 3}
+ array default set ary 7
+ apply {{} {
+ upvar 1 ary ary ary(c) c
+ lappend result $ary(a) $ary(b) $c
+ lappend result [info exist ary(a)] [info exist ary(b)] [info exist c]
+ lappend result [array default get ary]
+ }}
+ }}
+} {3 7 7 1 0 0 7}
+test var-24.16 {array default set: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ set ary not-an-array
+ array default set ary 7
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result {can't array default set "ary": variable isn't array}
+test var-24.17 {array default set: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ array default set ary
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result * -match glob
+test var-24.18 {array default set: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ array default set ary x y
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result * -match glob
+test var-24.19 {array default get: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ set ary not-an-array
+ array default get ary
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result {"ary" isn't an array}
+test var-24.20 {array default get: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ array default get ary x y
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result * -match glob
+test var-24.21 {array default exists: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ set ary not-an-array
+ array default exists ary
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result {"ary" isn't an array}
+test var-24.22 {array default exists: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ array default exists ary x
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result * -match glob
+test var-24.23 {array default unset: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ set ary not-an-array
+ array default unset ary
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result {"ary" isn't an array}
+test var-24.24 {array default unset: errors} -setup {
+ unset -nocomplain ary
+} -body {
+ array default unset ary x
+} -returnCodes error -cleanup {
+ unset -nocomplain ary
+} -result * -match glob
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
+catch {rename getbytes ""}
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {namespace delete test_ns_var2}
diff --git a/tests/while-old.test b/tests/while-old.test
index f5315fb..b5b69dc 100644
--- a/tests/while-old.test
+++ b/tests/while-old.test
@@ -6,9 +6,9 @@
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1991-1993 The Regents of the University of California.
+# Copyright © 1994-1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -92,7 +92,7 @@ test while-old-4.3 {errors in while loops} {
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
-} {1 {can't use non-numeric string as operand of "+"}}
+} {1 {can't use non-numeric string "a" as operand of "+"}}
test while-old-4.5 {errors in while loops} {
catch {unset x}
set x 1
diff --git a/tests/while.test b/tests/while.test
index b804aa5..2bfab2a 100644
--- a/tests/while.test
+++ b/tests/while.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -32,7 +32,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} -body {
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
while {"a"+"b"} {error "loop aborted"}
-} -returnCodes error -result {can't use non-numeric string as operand of "+"}
+} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"}
test while-1.4 {TclCompileWhileCmd: multiline test expr} -body {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
@@ -343,7 +343,7 @@ test while-4.3 {while (not compiled): error in test expression} -body {
test while-4.4 {while (not compiled): error in test expression} -body {
set z while
$z {"a"+"b"} {error "loop aborted"}
-} -returnCodes error -result {can't use non-numeric string as operand of "+"}
+} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"}
test while-4.5 {while (not compiled): multiline test expr} -body {
set value 1
set z while
diff --git a/tests/winConsole.test b/tests/winConsole.test
index 9075ff3..3f23c07 100644
--- a/tests/winConsole.test
+++ b/tests/winConsole.test
@@ -4,7 +4,7 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1999 by Scriptics Corporation.
+# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -14,34 +14,361 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+catch {package require twapi} ;# Only to bring window to foreground. Not critical
-test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} {
- set oldmode [fconfigure stdin]
+::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}]
+}
- puts stdout "Enter abcdef<return> now: " nonewline
+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} {
- set result $line
- } else {
+ 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
- set result {}
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 -profile -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, -profile, -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 -profile -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, -profile, -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, -profile, -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, -profile, 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 -profile, -translation} -returnCodes error
+
+# Multiple threads
-} "abcdef"
+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
-#cleanup
+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
diff --git a/tests/winDde.test b/tests/winDde.test
index a526d0d..8f4da11 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -4,27 +4,27 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1999 by Scriptics Corporation.
+# Copyright © 1999 Scriptics Corporation.
#
# 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
- #tcltest::configure -verbose {pass start}
namespace import -force ::tcltest::*
}
+source [file join [file dirname [info script]] tcltests.tcl]
-testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::ddever [package require dde 1.4.4]
- set ::ddelib [info loaded "" Dde]}]} {
+ set ::ddever [package require dde 1.4.5]
+ set ::ddelib [info loaded {} Dde]}]} {
testConstraint dde 1
}
}
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
# -------------------------------------------------------------------------
@@ -37,6 +37,7 @@ proc createChildProcess {ddeServerName args} {
file delete -force $::scriptName
set f [open $::scriptName w+]
+ fconfigure $f -encoding utf-8
puts $f [list set ddeServerName $ddeServerName]
puts $f [list load $::ddelib Dde]
puts $f {
@@ -96,7 +97,7 @@ proc createChildProcess {ddeServerName args} {
# run the child server script.
set f [open |[list [interpreter] $::scriptName] r]
- fconfigure $f -buffering line
+ fconfigure $f -buffering line -encoding utf-8
gets $f line
return $f
}
@@ -104,7 +105,7 @@ proc createChildProcess {ddeServerName args} {
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
-} {1.4.4}
+} {1.4.5}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
@@ -129,104 +130,104 @@ test winDde-2.4 {Checking for existence, with only the topic specified} \
# -------------------------------------------------------------------------
test winDde-3.1 {DDE execute locally} -constraints dde -body {
- set \xe1 ""
- dde execute TclEval self [list set \xe1 foo]
- set \xe1
+ set \xE1 ""
+ dde execute TclEval self [list set \xE1 foo]
+ set \xE1
} -result foo
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
- set \xe1 ""
- dde execute -async TclEval self [list set \xe1 foo]
+ set \xE1 ""
+ dde execute -async TclEval self [list set \xE1 foo]
update
- set \xe1
+ set \xE1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
- set \xe1 ""
- dde execute TclEval self [list set \xe1 foo]
- dde request TclEval self \xe1
+ set \xE1 ""
+ dde execute TclEval self [list set \xE1 foo]
+ dde request TclEval self \xE1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
- set \xe1 ""
- dde eval self set \xe1 foo
+ set \xE1 ""
+ dde eval self set \xE1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
- set \xe1 ""
- dde execute TclEval self [list set \xe1 foo]
- dde request -binary TclEval self \xe1
+ set \xE1 ""
+ dde execute TclEval self [list set \xE1 foo]
+ dde request -binary TclEval self \xE1
} -result "foo\x00"
# Set variable a to A with diaeresis (Unicode C4) by relying on the fact
# that utf-8 is sent (e.g. "c3 84" on the wire)
test winDde-3.6 {DDE request utf-8} -constraints dde -body {
- set \xe1 "not set"
- dde execute TclEval self "set \xe1 \xc4"
- scan [set \xe1] %c
+ set \xE1 "not set"
+ dde execute TclEval self "set \xE1 \xC4"
+ scan [set \xE1] %c
} -result 196
# Set variable a to A with diaeresis (Unicode C4) using binary execute
# and compose utf-8 (e.g. "c3 84" ) manually
-test winDde-3.7 {DDE request binary} -constraints dde -body {
- set \xe1 "not set"
- dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00]
- scan [set \xe1] %c
+test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body {
+ set \xE1 "not set"
+ dde execute -binary TclEval self [list set \xC3\xA1 \xC3\x84\x00]
+ scan [set \xE1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
- set \xe1 ""
- dde poke TclEval self \xe1 \xc4
- dde request TclEval self \xe1
-} -result \xc4
+ set \xE1 ""
+ dde poke TclEval self \xE1 \xC4
+ dde request TclEval self \xE1
+} -result \xC4
test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
- set \xe1 ""
- dde poke -binary TclEval self \xe1 \xc3\x84\x00
- dde request TclEval self \xe1
-} -result \xc4
+ set \xE1 ""
+ dde poke -binary TclEval self \xE1 \xC3\x84\x00
+ dde request TclEval self \xE1
+} -result \xC4
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
- set \xe1 ""
+ set \xE1 ""
set name ch\xEDld-4.1
set child [createChildProcess $name]
- dde execute TclEval $name [list set \xe1 foo]
+ dde execute TclEval $name [list set \xE1 foo]
dde execute TclEval $name {set done 1}
update
- set \xe1
+ set \xE1
} -result ""
test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
- set \xe1 ""
+ set \xE1 ""
set name ch\xEDld-4.2
set child [createChildProcess $name]
- dde execute -async TclEval $name [list set \xe1 foo]
+ dde execute -async TclEval $name [list set \xE1 foo]
update
dde execute TclEval $name {set done 1}
update
- set \xe1
+ set \xE1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
- set \xe1 ""
+ set \xE1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
- dde execute TclEval $name [list set \xe1 foo]
- set \xe1 [dde request TclEval $name \xe1]
+ dde execute TclEval $name [list set \xE1 foo]
+ set \xE1 [dde request TclEval $name \xE1]
dde execute TclEval $name {set done 1}
update
- set \xe1
+ set \xE1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
- set \xe1 ""
+ set \xE1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
- set \xe1 [dde eval $name set \xe1 foo]
+ set \xE1 [dde eval $name set \xE1 foo]
dde execute TclEval $name {set done 1}
update
- set \xe1
+ set \xE1
} -result foo
test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
- set \xe1 ""
+ set \xE1 ""
set name ch\xEDld-4.5
set child [createChildProcess $name]
- dde poke TclEval $name \xe1 foo
- set \xe1 [dde request TclEval $name \xe1]
+ dde poke TclEval $name \xE1 foo
+ set \xE1 [dde request TclEval $name \xE1]
dde execute TclEval $name {set done 1}
update
- set \xe1
+ set \xE1
} -result foo
# -------------------------------------------------------------------------
@@ -401,8 +402,8 @@ test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
- dde eval child set \xe1 1
- child eval set \xe1
+ dde eval child set \xE1 1
+ child eval set \xE1
} -cleanup {interp delete child} -result 1
test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup {
interp create -safe child
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index fe50043..ac5ae4e 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1996-1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,13 +16,10 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
# Initialise the test constraints
-testConstraint winVista 0
-testConstraint win2000orXP 0
-testConstraint winOlderThan2000 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile [llength [info commands testfile]]
testConstraint testchmod [llength [info commands testchmod]]
@@ -32,6 +29,7 @@ testConstraint longFileNames 0
# Some things fail under all Continuous Integration systems for subtle reasons
# such as CI often running with elevated privileges in a container.
testConstraint notInCIenv [expr {![info exists ::env(CI)]}]
+testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}]
proc createfile {file {string a}} {
set f [open $file w]
@@ -64,18 +62,6 @@ proc cleanup {args} {
}
}
-if {[testConstraint winOnly]} {
- if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
- if {$::tcl_platform(osVersion) >= 6.0} {
- testConstraint winVista 1
- } else {
- testConstraint win2000orXP 1
- }
- } else {
- testConstraint winOlderThan2000 1
- }
-}
-
# find a CD-ROM so we can test read-only filesystems.
proc findfile {dir} {
@@ -144,25 +130,25 @@ test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body {
} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1/td2/td3
file mkdir td2
testfile mv td2 td1/td2
} -returnCodes error -result EEXIST
test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
testfile mv / td1
} -returnCodes error -result EINVAL
test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
testfile mv td1 td1/td2
} -returnCodes error -result EINVAL
test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
createfile tf1
testfile mv tf1 td1
@@ -215,19 +201,9 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup {
} -cleanup {
catch {close $fd}
} -returnCodes error -result EACCES
-test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win win2000orXP testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EINVAL
-test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
createfile tf1
testfile mv tf1 nul
} -returnCodes error -result EEXIST
@@ -248,21 +224,9 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup {
} -constraints {win testfile} -body {
testfile mv tf1 tf2
} -returnCodes error -result ENOENT
-test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup {
- cleanup
-} -constraints {win win2000orXP testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EINVAL
-test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result EACCES
test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
cleanup
-} -constraints {win nt testfile} -body {
- # under 95, this would actually succeed and move the current dir out from
- # under the current process!
+} -constraints {win testfile} -body {
file delete /tf1
testfile mv [pwd] /tf1
} -returnCodes error -result EACCES
@@ -279,7 +243,7 @@ test winFCmd-1.22 {TclpRenameFile: long dst} -setup {
} -returnCodes error -result ENAMETOOLONG
test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
testfile mv [pwd]/td1 td1/td2
} -returnCodes error -result EINVAL
@@ -325,21 +289,21 @@ test winFCmd-1.29 {TclpRenameFile: src is dir} -setup {
} -returnCodes error -result ENOTDIR
test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
file mkdir td2/td2
testfile mv td1 td2
} -returnCodes error -result EEXIST
test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
file mkdir td2/td2
testfile mv td1 td2
} -returnCodes error -result EEXIST
test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1/td2
file mkdir td2
testfile mv td1 td2
@@ -368,7 +332,7 @@ test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup {
} -returnCodes error -result ENOTDIR
test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup {
cleanup
-} -constraints {win testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
file mkdir td1
createfile tf1
testfile mv tf1 td1
@@ -419,7 +383,7 @@ proc MakeFiles {dirname} {
test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
cleanup
-} -constraints {win winNonZeroInodes notInCIenv} -body {
+} -constraints {win winNonZeroInodes knownMsvcBug notInCIenv} -body {
file mkdir td1
lassign [MakeFiles td1] a b
file rename -force $a $b
@@ -469,16 +433,6 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup {
} -cleanup {
cleanup
} -returnCodes error -result ENOENT
-test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win win2000orXP testfile} -body {
- testfile cp nul tf1
-} -returnCodes error -result EINVAL
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win nt winOlderThan2000 testfile} -body {
- testfile cp nul tf1
-} -returnCodes error -result EACCES
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -634,7 +588,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup {
test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body {
testfile mkdir $cdrom/dummy~~.dir
-} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES
+} -constraints {win cdrom testfile} -returnCodes error -result EACCES
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -667,7 +621,7 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup {
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
-} -constraints {winVista testfile testchmod notInCIenv} -body {
+} -constraints {win testfile testchmod notInCIenv} -body {
# Parent's FILE_DELETE_CHILD setting permits deletion of subdir
# even when subdir DELETE mask is clear. So we need an intermediate
# parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
@@ -725,14 +679,14 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup {
# winFCmd-6.9 removed - was exact dup of winFCmd-6.1
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile notInCIenv} -body {
testfile rmdir /
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
-} -constraints {winVista testfile testchmod notInCIenv} -body {
+} -constraints {win testfile testchmod notInCIenv} -body {
# Parent's FILE_DELETE_CHILD setting permits deletion of subdir
# even when subdir DELETE mask is clear. So we need an intermediate
# parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
@@ -827,7 +781,7 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup {
} -result {tf1}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
testfile rmdir $cdrom/
-} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
+} -constraints {win cdrom testfile} -returnCodes error -match glob \
-result {* EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{win emptyTest} {
@@ -866,7 +820,7 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup {
} -result {tf1}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
cleanup
-} -constraints {win nt testfile} -body {
+} -constraints {win testfile} -body {
file mkdir td1
testfile cpdir td1 /
} -cleanup {
@@ -968,7 +922,7 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
} -result {}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
-} -constraints {winVista testfile testchmod notInCIenv} -body {
+} -constraints {win testfile testchmod notInCIenv} -body {
# Parent's FILE_DELETE_CHILD setting permits deletion of subdir
# even when subdir DELETE mask is clear. So we need an intermediate
# parent td0 with FILE_DELETE_CHILD turned off while allowing R/W.
@@ -1085,15 +1039,7 @@ test winFCmd-12.4 {ConvertFileNameFormat} -constraints {win} -setup {
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
list [file attributes / -longname] [file attributes \\ -longname]
} -constraints {win} -result {/ /}
-test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
- catch {file delete -force -- c:/TclTmpC.1}
-} -constraints {win win2000orXP} -body {
- createfile c:/TclTmpC.1 {}
- string tolower [file attributes c:/TclTmpC.1 -longname]
-} -cleanup {
- file delete -force -- c:/TclTmpC.1
-} -result [string tolower {c:/TclTmpC.1}]
-test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
+test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
catch {file delete -force -- $::env(TEMP)/td1}
} -constraints {win} -body {
createfile $::env(TEMP)/td1 {}
@@ -1161,7 +1107,7 @@ test winFCmd-15.2 {SetWinFileAttributes - archive} -constraints {win} -setup {
} -cleanup {
cleanup
} -result {{} 1}
-test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup {
+test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
@@ -1169,7 +1115,7 @@ test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup {
} -cleanup {
cleanup
} -result {{} 0}
-test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win} -setup {
+test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
@@ -1202,7 +1148,7 @@ test winFCmd-15.7 {SetWinFileAttributes - readonly} -setup {
} -cleanup {
cleanup
} -result {{} 0}
-test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win} -setup {
+test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win notInCIenv} -setup {
cleanup
} -body {
createfile td1 {}
@@ -1374,13 +1320,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
file normalize cOm1:
} -result COM1
-test winFCmd-19.1 {Windows extended path names} -constraints nt -body {
+test winFCmd-19.1 {Windows extended path names} -constraints win -body {
file normalize //?/c:/windows/win.ini
} -result //?/c:/windows/win.ini
-test winFCmd-19.2 {Windows extended path names} -constraints nt -body {
+test winFCmd-19.2 {Windows extended path names} -constraints win -body {
file normalize //?/c:/windows/../windows/win.ini
} -result //?/c:/windows/win.ini
-test winFCmd-19.3 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.3 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1391,7 +1337,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.4 {Windows extended path names} -constraints {win nt} -setup {
+test winFCmd-19.4 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1402,7 +1348,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints {win nt} -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
+test winFCmd-19.5 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1413,7 +1359,7 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.6 {Windows extended path names} -constraints {win nt} -setup {
+test winFCmd-19.6 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1424,7 +1370,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints {win nt} -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {}]
-test winFCmd-19.7 {Windows extended path names} -constraints {win nt} -setup {
+test winFCmd-19.7 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile [file normalize $tmpfile]
} -body {
@@ -1435,7 +1381,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints {win nt} -setup {
} -cleanup {
catch {file delete $tmpfile}
} -result [list 0 {} [list tcl[pid].tmp]]
-test winFCmd-19.8 {Windows extended path names} -constraints {win nt} -setup {
+test winFCmd-19.8 {Windows extended path names} -constraints win -setup {
set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
set tmpfile //?/[file normalize $tmpfile]
} -body {
@@ -1447,7 +1393,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints {win nt} -setup {
catch {file delete $tmpfile}
} -result [list 0 {} [list "tcl[pid].tmp "]]
-test winFCmd-19.9 {Windows devices path names} -constraints {win nt} -body {
+test winFCmd-19.9 {Windows devices path names} -constraints win -body {
file normalize //./com1
} -result //./com1
diff --git a/tests/winFile.test b/tests/winFile.test
index 3737d9f..0c13a0e 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -4,40 +4,36 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
-if {[catch {package require tcltest 2.5}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
- return
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
}
-namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint notNTFS 0
-testConstraint win2000 0
if {[testConstraint testvolumetype]} {
testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}]
}
-if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
- testConstraint win2000 1
-}
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
test winFile-1.1 {TclpGetUserHome} -constraints {win} -body {
glob ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
-test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
+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 nt nonPortable} {
+test winFile-1.4 {TclpGetUserHome} {win nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
@@ -155,7 +151,7 @@ if {[testConstraint win]} {
test winFile-4.0 {
Enhanced NTFS user/group permissions: test no acccess
} -constraints {
- win nt notNTFS win2000
+ win notNTFS notWine
} -setup {
set owner [getuser $fname]
set user $::env(USERDOMAIN)\\$::env(USERNAME)
@@ -170,7 +166,7 @@ test winFile-4.0 {
test winFile-4.1 {
Enhanced NTFS user/group permissions: test readable only
} -constraints {
- win nt notNTFS
+ win notNTFS notWine
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -181,7 +177,7 @@ test winFile-4.1 {
test winFile-4.2 {
Enhanced NTFS user/group permissions: test writable only
} -constraints {
- win nt notNTFS
+ win notNTFS notWine
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -193,7 +189,7 @@ test winFile-4.2 {
test winFile-4.3 {
Enhanced NTFS user/group permissions: test read+write
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
@@ -206,7 +202,7 @@ test winFile-4.3 {
test winFile-4.4 {
Enhanced NTFS user/group permissions: test full access
} -constraints {
- win nt notNTFS
+ win notNTFS
} -setup {
set user $::env(USERDOMAIN)\\$::env(USERNAME)
} -body {
diff --git a/tests/winNotify.test b/tests/winNotify.test
index 0433b4a..52502a2 100644
--- a/tests/winNotify.test
+++ b/tests/winNotify.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testeventloop [expr {[info commands testeventloop] != {}}]
diff --git a/tests/winPipe.test b/tests/winPipe.test
index ce786db..2827595 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -6,26 +6,31 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output (except for one message) means no errors were found.
#
-# Copyright (c) 1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996 Sun Microsystems, Inc.
+# Copyright © 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.
-package require tcltest 2.5
-namespace import -force ::tcltest::*
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
unset -nocomplain path
catch {
::tcltest::loadTestedCommands
- package require -exact Tcltest [info patchlevel]
- set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+ package require -exact tcl::test [info patchlevel]
+ set ::tcltestlib [info loaded {} Tcltest]
}
set org_pwd [pwd]
set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]
+testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}]
+
+
# several test-cases here expect current directory == [temporaryDirectory]:
cd [temporaryDirectory]
@@ -79,11 +84,11 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} {
+test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} {
exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
-test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} {
+test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} {
exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
@@ -169,14 +174,14 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
{win exec cat32} {
set f [open "|[list $cat32]" r+]
puts $f $big
- puts $f \032
+ puts $f \x1A
flush $f
set r [read $f 64]
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
+test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} {
proc readResults {f} {
global x result
if { [eof $f] } {
@@ -195,7 +200,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
-test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
+test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
@@ -203,7 +208,7 @@ test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec test
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGFPE}
-test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
+test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
@@ -211,7 +216,7 @@ test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec tes
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGSEGV}
-test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
+test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
@@ -219,7 +224,7 @@ test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec test
set status [catch {close $f}]
list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGILL}
-test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
+test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept notWine} {
set f [open "|[list [interpreter]]" w+]
set pid [pid $f]
puts $f "load $::tcltestlib Tcltest"
@@ -517,7 +522,7 @@ test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on s
} -result {}
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \
--constraints {win exec} -body {
+-constraints {win exec notWine} -body {
_testExecArgs 0 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
@@ -526,7 +531,7 @@ test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on s
} -result {}
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \
--constraints {win exec} -body {
+-constraints {win exec notWine} -body {
_testExecArgs 2 \
[list START {*}$injectList END] \
[list "START\"" {*}$injectList END] \
@@ -535,7 +540,7 @@ test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on s
} -result {}
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \
--constraints {win exec} -body {
+-constraints {win exec notWine} -body {
set lst {}
set maps {
{\&|^<>!()%}
@@ -611,6 +616,7 @@ removeFile nothing
if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl }
if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat }
if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check }
+unset -nocomplain path
::tcltest::cleanupTests
# back to original directory:
cd $org_pwd; unset org_pwd
diff --git a/tests/winTime.test b/tests/winTime.test
index ed8b625..0d7298f 100644
--- a/tests/winTime.test
+++ b/tests/winTime.test
@@ -4,8 +4,8 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1997 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} {
}
::tcltest::loadTestedCommands
-catch [list package require -exact Tcltest [info patchlevel]]
+catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
diff --git a/tests/zipfiles/LICENSE-libzip b/tests/zipfiles/LICENSE-libzip
new file mode 100644
index 0000000..fa70609
--- /dev/null
+++ b/tests/zipfiles/LICENSE-libzip
@@ -0,0 +1,31 @@
+Copyright (C) 1999-2020 Dieter Baron and Thomas Klausner
+
+The authors can be contacted at <info@libzip.org>
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in
+ the documentation and/or other materials provided with the
+ distribution.
+
+3. The names of the authors may not be used to endorse or promote
+ products derived from this software without specific prior
+ written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/tests/zipfiles/README b/tests/zipfiles/README
new file mode 100644
index 0000000..a036635
--- /dev/null
+++ b/tests/zipfiles/README
@@ -0,0 +1,7 @@
+The files in this directory are used for testing zipfs file systems.
+They fall under the following licenses:
+
+test-overlay.zip, test-password[2].zip, test-zip-in-zip.zip - Tcl's license
+
+All other files - test files from libzip (https://libzip.org) and are covered by
+the license in LICENSE-libzip. \ No newline at end of file
diff --git a/tests/zipfiles/broken.zip b/tests/zipfiles/broken.zip
new file mode 100644
index 0000000..2008c32
--- /dev/null
+++ b/tests/zipfiles/broken.zip
Binary files differ
diff --git a/tests/zipfiles/empty.zip b/tests/zipfiles/empty.zip
new file mode 100644
index 0000000..0ed493a
--- /dev/null
+++ b/tests/zipfiles/empty.zip
Binary files differ
diff --git a/tests/zipfiles/incons-cdoffset.zip b/tests/zipfiles/incons-cdoffset.zip
new file mode 100644
index 0000000..153e7a8
--- /dev/null
+++ b/tests/zipfiles/incons-cdoffset.zip
Binary files differ
diff --git a/tests/zipfiles/incons-central-crc.zip b/tests/zipfiles/incons-central-crc.zip
new file mode 100644
index 0000000..1f882ac
--- /dev/null
+++ b/tests/zipfiles/incons-central-crc.zip
Binary files differ
diff --git a/tests/zipfiles/incons-central-magic-bad.zip b/tests/zipfiles/incons-central-magic-bad.zip
new file mode 100644
index 0000000..954563b
--- /dev/null
+++ b/tests/zipfiles/incons-central-magic-bad.zip
Binary files differ
diff --git a/tests/zipfiles/incons-file-count-high.zip b/tests/zipfiles/incons-file-count-high.zip
new file mode 100644
index 0000000..876a886
--- /dev/null
+++ b/tests/zipfiles/incons-file-count-high.zip
Binary files differ
diff --git a/tests/zipfiles/incons-file-count-low.zip b/tests/zipfiles/incons-file-count-low.zip
new file mode 100644
index 0000000..4af9038
--- /dev/null
+++ b/tests/zipfiles/incons-file-count-low.zip
Binary files differ
diff --git a/tests/zipfiles/incons-local-crc.zip b/tests/zipfiles/incons-local-crc.zip
new file mode 100644
index 0000000..6f74b15
--- /dev/null
+++ b/tests/zipfiles/incons-local-crc.zip
Binary files differ
diff --git a/tests/zipfiles/incons-local-magic-bad.zip b/tests/zipfiles/incons-local-magic-bad.zip
new file mode 100644
index 0000000..9a6a061
--- /dev/null
+++ b/tests/zipfiles/incons-local-magic-bad.zip
Binary files differ
diff --git a/tests/zipfiles/junk-at-end.zip b/tests/zipfiles/junk-at-end.zip
new file mode 100644
index 0000000..30387b3
--- /dev/null
+++ b/tests/zipfiles/junk-at-end.zip
Binary files differ
diff --git a/tests/zipfiles/junk-at-start.zip b/tests/zipfiles/junk-at-start.zip
new file mode 100644
index 0000000..8c98325
--- /dev/null
+++ b/tests/zipfiles/junk-at-start.zip
Binary files differ
diff --git a/tests/zipfiles/streamed.zip b/tests/zipfiles/streamed.zip
new file mode 100644
index 0000000..737d56f
--- /dev/null
+++ b/tests/zipfiles/streamed.zip
Binary files differ
diff --git a/tests/zipfiles/test-overlay.zip b/tests/zipfiles/test-overlay.zip
new file mode 100644
index 0000000..9dc2c52
--- /dev/null
+++ b/tests/zipfiles/test-overlay.zip
Binary files differ
diff --git a/tests/zipfiles/test-password.zip b/tests/zipfiles/test-password.zip
new file mode 100644
index 0000000..bb9780a
--- /dev/null
+++ b/tests/zipfiles/test-password.zip
Binary files differ
diff --git a/tests/zipfiles/test-password2.zip b/tests/zipfiles/test-password2.zip
new file mode 100644
index 0000000..75a4d1c
--- /dev/null
+++ b/tests/zipfiles/test-password2.zip
Binary files differ
diff --git a/tests/zipfiles/test-paths.zip b/tests/zipfiles/test-paths.zip
new file mode 100644
index 0000000..539013e
--- /dev/null
+++ b/tests/zipfiles/test-paths.zip
Binary files differ
diff --git a/tests/zipfiles/test-zip-in-zip.zip b/tests/zipfiles/test-zip-in-zip.zip
new file mode 100644
index 0000000..8797c32
--- /dev/null
+++ b/tests/zipfiles/test-zip-in-zip.zip
Binary files differ
diff --git a/tests/zipfiles/test.zip b/tests/zipfiles/test.zip
new file mode 100644
index 0000000..e4efd71
--- /dev/null
+++ b/tests/zipfiles/test.zip
Binary files differ
diff --git a/tests/zipfiles/testbzip2.zip b/tests/zipfiles/testbzip2.zip
new file mode 100644
index 0000000..7c9a9e7
--- /dev/null
+++ b/tests/zipfiles/testbzip2.zip
Binary files differ
diff --git a/tests/zipfiles/testdeflated2.zip b/tests/zipfiles/testdeflated2.zip
new file mode 100644
index 0000000..b5ded7d
--- /dev/null
+++ b/tests/zipfiles/testdeflated2.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-UTF8.zip b/tests/zipfiles/testfile-UTF8.zip
new file mode 100644
index 0000000..7279615
--- /dev/null
+++ b/tests/zipfiles/testfile-UTF8.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-cp437.zip b/tests/zipfiles/testfile-cp437.zip
new file mode 100644
index 0000000..169a903
--- /dev/null
+++ b/tests/zipfiles/testfile-cp437.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-lzma.zip b/tests/zipfiles/testfile-lzma.zip
new file mode 100644
index 0000000..f855b2a
--- /dev/null
+++ b/tests/zipfiles/testfile-lzma.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-nocompression.zip b/tests/zipfiles/testfile-nocompression.zip
new file mode 100644
index 0000000..2fa5ba0
--- /dev/null
+++ b/tests/zipfiles/testfile-nocompression.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-xz.zip b/tests/zipfiles/testfile-xz.zip
new file mode 100644
index 0000000..6be8f9c
--- /dev/null
+++ b/tests/zipfiles/testfile-xz.zip
Binary files differ
diff --git a/tests/zipfiles/testfile-zstd.zip b/tests/zipfiles/testfile-zstd.zip
new file mode 100644
index 0000000..bf42d3e
--- /dev/null
+++ b/tests/zipfiles/testfile-zstd.zip
Binary files differ
diff --git a/tests/zipfiles/teststored.zip b/tests/zipfiles/teststored.zip
new file mode 100644
index 0000000..138c6ad
--- /dev/null
+++ b/tests/zipfiles/teststored.zip
Binary files differ
diff --git a/tests/zipfiles/zip64.zip b/tests/zipfiles/zip64.zip
new file mode 100644
index 0000000..c1ba76b
--- /dev/null
+++ b/tests/zipfiles/zip64.zip
Binary files differ
diff --git a/tests/zipfs.test b/tests/zipfs.test
new file mode 100644
index 0000000..d8817f8
--- /dev/null
+++ b/tests/zipfs.test
@@ -0,0 +1,1943 @@
+# The file tests the tclZlib.c file.
+#
+# This file contains a collection of tests for one or more of the Tcl built-in
+# commands. Sourcing this file into Tcl runs the tests and generates output
+# for errors. No output means no errors were found.
+#
+# Copyright © 1996-1998 Sun Microsystems, Inc.
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2023 Ashok P. Nadkarni
+#
+# 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::*
+}
+source [file join [file dirname [info script]] tcltests.tcl]
+
+testConstraint zipfs [expr {[llength [info commands zipfs]]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.8-}]}]
+
+
+set ziproot [zipfs root]
+set CWD [pwd]
+set tmpdir [file join $CWD tmp]
+file mkdir $tmpdir
+
+test zipfs-0.0 {zipfs basics} -constraints zipfs -body {
+ package require tcl::zipfs
+} -result {2.0}
+test zipfs-0.1 {zipfs basics} -constraints zipfs -body {
+ expr {${ziproot} in [file volumes]}
+} -result 1
+
+if {[string match ${ziproot}* $tcl_library]} {
+ testConstraint zipfslib 1
+ set zipLibTop [file tail [file join {*}[lrange [file split $tcl_library] 0 1]]]
+} else {
+ set zipLibTop ""
+}
+
+test zipfs-0.2 {zipfs basics} -constraints zipfslib -body {
+ string match ${ziproot}* $tcl_library
+} -result 1
+test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup {
+ set pwd [pwd]
+} -body {
+ cd $tcl_library
+ expr { [file join . http] in [glob -dir . http*] }
+} -cleanup {
+ cd $pwd
+} -result 1
+test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup {
+ set pwd [pwd]
+} -body {
+ cd $tcl_library
+ expr { [file join $tcl_library http] in [glob -dir [pwd] http*] }
+} -cleanup {
+ cd $pwd
+} -result 1
+test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body {
+ expr { [file join $tcl_library http] in [glob -dir $tcl_library http*] }
+} -result 1
+test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body {
+ expr { [file join $tcl_library http] in [glob [file join $tcl_library http*]] }
+} -result 1
+test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body {
+ expr { "http" in [glob -tails -dir $tcl_library http*] }
+} -result 1
+test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body {
+ expr { "http" in [glob -nocomplain -tails -types d -dir $tcl_library http*] }
+} -result 1
+test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body {
+ glob -nocomplain -tails -types f -dir $tcl_library http*
+} -result {}
+test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
+ file join ${ziproot} bar baz
+} -result "${ziproot}bar/baz"
+test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
+ file normalize ${ziproot}
+} -result "${ziproot}"
+test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body {
+ file normalize ${ziproot}//bar/baz//qux/../
+} -result "${ziproot}bar/baz"
+
+file mkdir tmp
+test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body {
+ zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx
+} -result {empty archive}
+###
+# The next series of tests operate within a zipfile created a temporary
+# directory.
+###
+set zipfile [file join $tmpdir abc.zip]
+if {[file exists $zipfile]} {
+ file delete $zipfile
+}
+test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body {
+ cd $tcl_library/encoding
+ zipfs mkzip $zipfile .
+ zipfs mount $zipfile ${ziproot}abc
+ zipfs list -glob ${ziproot}abc/cp850.*
+} -cleanup {
+ cd $CWD
+} -result "${ziproot}abc/cp850.enc"
+testConstraint zipfsenc [zipfs exists ${ziproot}abc/cp850.enc]
+test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body {
+ set r [zipfs info ${ziproot}abc/cp850.enc]
+ lrange $r 0 2
+} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable
+test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body {
+ set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test
+ read $zipfd
+} -result {# Encoding file: cp850, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5
+00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192
+00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB
+2591259225932502252400C100C200C000A9256325512557255D00A200A52510
+25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4
+00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580
+00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4
+00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0
+} ;# FIXME: result depends on content of encodings dir
+test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body {
+ zipfs exists ${ziproot}abc/cp850.enc
+} -result 1
+test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body {
+ zipfs unmount /abc
+} -returnCodes error -result {filesystem is busy}
+test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body {
+ close $zipfd
+ zipfs unmount /abc
+ zipfs exists /abc/cp850.enc
+} -result 0
+###
+# Repeat the tests for a buffer mounted archive
+###
+test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body {
+ cd $tcl_library/encoding
+ zipfs mkzip $zipfile .
+ set fin [open $zipfile r]
+ fconfigure $fin -translation binary
+ set dat [read $fin]
+ close $fin
+ zipfs mount_data $dat def
+ zipfs list -glob ${ziproot}def/cp850.*
+} -cleanup {
+ cd $CWD
+} -result "${ziproot}def/cp850.enc"
+testConstraint zipfsencbuf [zipfs exists ${ziproot}def/cp850.enc]
+test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body {
+ set r [zipfs info ${ziproot}def/cp850.enc]
+ lrange $r 0 2
+} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable
+test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body {
+ set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test
+ read $zipfd
+} -result {# Encoding file: cp850, single-byte
+S
+003F 0 1
+00
+0000000100020003000400050006000700080009000A000B000C000D000E000F
+0010001100120013001400150016001700180019001A001B001C001D001E001F
+0020002100220023002400250026002700280029002A002B002C002D002E002F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
+0040004100420043004400450046004700480049004A004B004C004D004E004F
+0050005100520053005400550056005700580059005A005B005C005D005E005F
+0060006100620063006400650066006700680069006A006B006C006D006E006F
+0070007100720073007400750076007700780079007A007B007C007D007E007F
+00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5
+00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192
+00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB
+2591259225932502252400C100C200C000A9256325512557255D00A200A52510
+25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4
+00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580
+00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4
+00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0
+} ;# FIXME: result depends on content of encodings dir
+test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body {
+ zipfs exists ${ziproot}def/cp850.enc
+} -result 1
+test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body {
+ zipfs unmount /def
+} -returnCodes error -result {filesystem is busy}
+test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body {
+ close $zipfd
+ zipfs unmount /def
+ zipfs exists /def/cp850.enc
+} -result 0
+
+catch {file delete -force $tmpdir}
+
+test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup {
+ set interp [interp create]
+} -body {
+ interp eval $interp {
+ zipfs ?
+ }
+} -returnCodes error -cleanup {
+ interp delete $interp
+} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount}
+test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup {
+ set interp [interp create]
+} -body {
+ interp eval $interp {
+ zipfs mkzip
+ }
+} -returnCodes error -cleanup {
+ interp delete $interp
+} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"}
+test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup {
+ set safe [interp create -safe]
+} -body {
+ interp eval $safe {
+ zipfs ?
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount}
+test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup {
+ set safe [interp create -safe]
+} -body {
+ interp eval $safe {
+ zipfs mkzip
+ }
+} -returnCodes error -cleanup {
+ interp delete $safe
+} -result {not allowed to invoke subcommand mkzip of zipfs}
+
+test zipfs-4.1 {zipfs lmkimg} -constraints zipfs -setup {
+ set baseImage [makeFile "return sourceWorking\n\x1A" base]
+ set targetImage [makeFile "" target]
+ set addFile [makeFile "return mountWorking" add.data]
+ file delete $targetImage
+} -body {
+ zipfs lmkimg $targetImage [list $addFile test/add.tcl] {} $baseImage
+ zipfs mount $targetImage ziptest
+ try {
+ list [source $targetImage] [source ${ziproot}ziptest/test/add.tcl]
+ } finally {
+ zipfs unmount ziptest
+ }
+} -cleanup {
+ removeFile $baseImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result {sourceWorking mountWorking}
+test zipfs-4.2 {zipfs lmkimg: making an image from an image} -constraints zipfs -setup {
+ set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl]
+ set midImage [makeFile "" mid_image.tcl]
+ set targetImage [makeFile "" target_image.tcl]
+ set addFile [makeFile "return mountWorking" add.data]
+ file delete $midImage $targetImage
+} -body {
+ zipfs lmkimg $midImage [list $addFile test/ko.tcl] {} $baseImage
+ zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage
+ zipfs mount $targetImage ziptest
+ try {
+ list [glob -tails -directory ${ziproot}/ziptest/test *.tcl] \
+ [if {[file size $midImage] == [file size $targetImage]} {
+ string cat equal
+ } else {
+ list mid=[file size $midImage] target=[file size $targetImage]
+ }]
+ } finally {
+ zipfs unmount ziptest
+ }
+} -cleanup {
+ removeFile $baseImage
+ removeFile $midImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result {ok.tcl equal}
+test zipfs-4.3 {zipfs lmkimg: stripping password} -constraints zipfs -setup {
+ set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl]
+ set midImage [makeFile "" mid_image.tcl]
+ set targetImage [makeFile "" target_image.tcl]
+ set addFile [makeFile "return mountWorking" add.data]
+ file delete $midImage $targetImage
+} -body {
+ set pass gorp
+ zipfs lmkimg $midImage [list $addFile test/add.tcl] $pass $baseImage
+ zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage
+ zipfs mount $targetImage ziptest
+ try {
+ glob -tails -directory ${ziproot}/ziptest/test *.tcl
+ } finally {
+ zipfs unmount ziptest
+ }
+} -cleanup {
+ removeFile $baseImage
+ removeFile $midImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result {ok.tcl}
+test zipfs-4.4 {zipfs lmkimg: final password} -constraints zipfs -setup {
+ set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl]
+ set midImage [makeFile "" mid_image.tcl]
+ set targetImage [makeFile "" target_image.tcl]
+ set addFile [makeFile "return mountWorking" add.data]
+ file delete $midImage $targetImage
+} -body {
+ set pass gorp
+ zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage
+ zipfs lmkimg $targetImage [list $addFile test/ok.tcl] $pass $midImage
+ zipfs mount $targetImage ziptest
+ try {
+ glob -tails -directory ${ziproot}/ziptest/test *.tcl
+ } finally {
+ zipfs unmount ziptest
+ }
+} -cleanup {
+ removeFile $baseImage
+ removeFile $midImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result {ok.tcl}
+test zipfs-4.5 {zipfs lmkimg: making image from mounted} -constraints zipfs -setup {
+ set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl]
+ set midImage [makeFile "" mid_image.tcl]
+ set targetImage [makeFile "" target_image.tcl]
+ set addFile [makeFile "return mountWorking" add.data]
+ file delete $midImage $targetImage
+} -body {
+ zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage
+ zipfs mount $midImage ziptest
+ set f [glob -directory ${ziproot}/ziptest/test *.tcl]
+ zipfs lmkimg $targetImage [list $f test/ok.tcl] {} $midImage
+ zipfs unmount ziptest
+ zipfs mount $targetImage ziptest
+ list $f [glob -directory ${ziproot}/ziptest/test *.tcl]
+} -cleanup {
+ zipfs unmount ziptest
+ removeFile $baseImage
+ removeFile $midImage
+ removeFile $targetImage
+ removeFile $addFile
+} -result [list ${ziproot}/ziptest/test/add.tcl ${ziproot}/ziptest/test/ok.tcl]
+
+test zipfs-5.1 {zipfs mount_data: short data} -constraints zipfs -body {
+ zipfs mount_data {} gorp
+} -returnCodes error -result {illegal file size}
+test zipfs-5.2 {zipfs mount_data: short data} -constraints zipfs -body {
+ zipfs mount_data gorpGORPgorp gorp
+} -returnCodes error -result {illegal file size}
+test zipfs-5.3 {zipfs mount_data: short data} -constraints zipfs -body {
+ set data PK\x03\x04.....................................
+ append data PK\x01\x02.....................................
+ append data PK\x05\x06.....................................
+ zipfs mount_data $data gorp
+} -returnCodes error -result {archive directory truncated}
+
+test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body {
+ binary scan [zipfs mkkey gorp] cu* x
+ return $x
+} -result {224 226 111 103 4 80 75 90 90}
+
+
+#
+# Additional tests for more coverage. Some of the ones above may be duplicated.
+
+namespace eval test_ns_zipfs {
+ namespace import ::tcltest::test
+ namespace path ::tcltests
+ variable zipTestDir [file normalize [file join [file dirname [info script]] zipfiles]]
+ variable defMountPt [file join [zipfs root] testmount]
+
+ proc readbin {path} {
+ set fd [open $path rb]
+ set data [read $fd]
+ close $fd
+ return $data
+ }
+
+ # Wrapper to ease transition if Tcl changes order of argument to zipfs mount
+ # or the zipfs prefix
+ proc mount [list zippath [list mountpoint $defMountPt]] {
+ return [zipfs mount $zippath $mountpoint]
+ }
+
+ # Make full path to zip file
+ proc zippath {zippath} {
+ variable zipTestDir
+ if {[file pathtype $zippath] eq "absolute"} {
+ return $zippath
+ } else {
+ return [file join $zipTestDir $zippath]
+ }
+ }
+
+ # list of paths -> list of paths under mount point mt
+ proc zipfspathsmt {mt args} {
+ return [lsort [lmap path $args {file join $mt $path}]]
+ }
+
+ # list of paths -> list of paths under [zipfs root]
+ proc zipfspaths {args} {
+ return [zipfspathsmt [zipfs root] {*}$args]
+ }
+
+ proc cleanup {} {
+ dict for {mount -} [zipfs mount] {
+ if {[string match //zipfs:/test* $mount]} {
+ zipfs unmount $mount
+ }
+ }
+ zipfs unmount [zipfs root]
+ }
+
+ proc mounttarget {mountpoint} {
+ return [dict getdef [zipfs mount] $mountpoint ""]
+ }
+
+ #
+ # zipfs root - only arg count check since do not want to assume
+ # what it resolves to
+ testnumargs "zipfs root" "" ""
+
+ #
+ # zipfs mount
+
+ proc testbadmount {id zippath messagePattern args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ test zipfs-mount-$id $id -body {
+ list [catch {mount $zippath} message] \
+ [string match $messagePattern $message] \
+ [mounttarget $defMountPt]
+ } -cleanup {
+ # In case mount succeeded when it should not
+ cleanup
+ } -result {1 1 {}} {*}$args
+
+ if {![file exists $zippath]} {
+ return
+ }
+ set data [readbin $zippath]
+ test zipfs-mount_data-$id $id -body {
+ list [catch {zipfs mount_data $data $defMountPt} message] \
+ [string match $messagePattern $message] \
+ [mounttarget $defMountPt]
+ } -cleanup {
+ # In case mount succeeded when it should not
+ cleanup
+ } -result {1 1 {}} {*}$args
+ }
+
+ # Generates tests for file, file on root, memory buffer cases for an archive
+ proc testmount {id zippath checkPath mountpoint args} {
+ set zippath [zippath $zippath]
+ test zipfs-mount-$id "zipfs mount $id" -body {
+ set canon [mount $zippath $mountpoint]
+ list [file exists [file join $canon $checkPath]] \
+ [zipfs mount $canon] [zipfs mount $mountpoint]
+ } -cleanup {
+ zipfs unmount $mountpoint
+ } -result [list 1 $zippath $zippath] {*}$args
+
+ # Mount memory buffer
+ test zipfs-mount_data-$id "zipfs mount_data $id" -body {
+ set canon [zipfs mount_data [readbin $zippath] $mountpoint]
+ list [file exists [file join $canon $checkPath]] \
+ [zipfs mount $canon] [zipfs mount $mountpoint]
+ } -cleanup {
+ cleanup
+ } -result [list 1 {Memory Buffer} {Memory Buffer}] {*}$args
+
+ }
+
+ testnumargs "zipfs mount" "" "?zipfile? ?mountpoint? ?password?"
+ testnumargs "zipfs mount_data" "data mountpoint" ""
+
+ # Not supported zip files
+ testbadmount non-existent-file nosuchfile.zip "couldn't open*nosuchfile.zip*no such file or directory"
+ testbadmount not-zipfile [file normalize [info script]] "archive directory end signature not found"
+ testbadmount zip64-unsupported zip64.zip "wrong header signature"
+
+ # Inconsistent metadata
+ testbadmount bad-directory-offset incons-cdoffset.zip "archive directory truncated"
+ testbadmount bad-directory-magic incons-central-magic-bad.zip "wrong header signature"
+ testbadmount bad-local-magic incons-local-magic-bad.zip "Failed to find local header"
+ testbadmount bad-file-count-high incons-file-count-high.zip "truncated directory"
+ testbadmount bad-file-count-low incons-file-count-low.zip "short file count"
+
+ test zipfs-mount-on-drive "Mount point include drive" -body {
+ zipfs mount [zippath test.zip] C:/foo
+ } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
+ test zipfs-mount_data-on-drive "Mount point include drive" -body {
+ zipfs mount_data [readbin [zippath test.zip]] C:/foo
+ } -result {Invalid mount path "C:/foo"} -returnCodes error -constraints win
+ test zipfs-mount-on-unc "Mount point is unc" -body {
+ zipfs mount [zippath test.zip] //unc/share/foo
+ } -result {Invalid mount path "//unc/share/foo"} -returnCodes error
+ test zipfs-mount_data-on-unc "Mount point include unc" -body {
+ zipfs mount_data [readbin [zippath test.zip]] //unc/share/foo
+ } -result {Invalid mount path "//unc/share/foo"} -returnCodes error
+
+ # Good mounts
+ testmount basic test.zip testdir/test2 $defMountPt
+ testmount basic-on-default test.zip testdir/test2 ""
+ testmount basic-on-root test.zip testdir/test2 [zipfs root]
+ testmount basic-on-slash test.zip testdir/test2 /
+ testmount basic-on-bslash test.zip testdir/test2 \\ -constraints win
+ testmount basic-on-relative test.zip testdir/test2 testmount
+ testmount basic-on-absolute test.zip testdir/test2 /testmount
+ testmount basic-on-absolute-bslash test.zip testdir/test2 \\testmount -constraints win
+ testmount zip-at-end junk-at-start.zip testdir/test2 $defMountPt
+ testmount zip-at-start junk-at-end.zip testdir/test2 $defMountPt
+ testmount zip-in-zip [file join [zipfs root] test2 test.zip] testdir/test2 $defMountPt -setup {
+ mount [zippath test-zip-in-zip.zip] [file join [zipfs root] test2]
+ } -cleanup {
+ zipfs unmount $mountpoint
+ zipfs unmount [file join [zipfs root] test2]
+ }
+ testmount relative-mount-point test.zip testdir/test2 ""
+
+ test zipfs-mount-busy-1 "Attempt to mount on existing mount point" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs mount [zippath testfile-cp437.zip] $defMountPt
+ } -result "[zippath test.zip] is already mounted on $defMountPt" -returnCodes error
+
+ test zipfs-mount-no-args-1 "mount - get mount list" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set mounts [zipfs mount]
+ lsearch -inline -stride 2 $mounts $defMountPt
+ } -result [list $defMountPt [zippath test.zip]]
+
+ test zipfs-mount-one-arg-1 "mount - get mount target - absolute path" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs mount $defMountPt
+ } -result [zippath test.zip]
+
+ test zipfs-mount-one-arg-2 "mount - get mount target - relative path" -setup {
+ file copy [zippath test.zip] test.zip
+ mount ./test.zip
+ } -cleanup {
+ cleanup
+ file delete ./test.zip
+ } -body {
+ zipfs mount $defMountPt
+ } -result [file normalize ./test.zip]
+
+ test zipfs-mount-password-1 "mount - verify plaintext readable without password" -body {
+ zipfs mount [zippath test-password.zip] $defMountPt
+ readbin [file join $defMountPt plain.txt]
+ } -cleanup {
+ cleanup
+ } -result plaintext
+
+ test zipfs-mount-password-2 "mount - verify uncompressed cipher unreadable without password" -body {
+ zipfs mount [zippath test-password.zip] $defMountPt
+ set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel
+ set result [list ]
+ lappend result [catch {open [file join $defMountPt cipher.bin]} message]
+ lappend result $message
+ lappend result [string equal $chans [lsort [chan names]]]
+ } -cleanup {
+ cleanup
+ } -result {1 {decryption failed - no password provided} 1}
+
+ test zipfs-mount-password-3 "mount - verify compressed cipher unreadable without password" -body {
+ zipfs mount [zippath test-password.zip] $defMountPt
+ set chans [lsort [chan names]]; # Want to ensure open does not leave dangling channel
+ set result [list ]
+ lappend result [catch {open [file join $defMountPt cipher-deflate.bin]} message]
+ lappend result $message
+ lappend result [string equal $chans [lsort [chan names]]]
+ } -cleanup {
+ cleanup
+ } -result {1 {decryption failed - no password provided} 1}
+
+ test zipfs-mount-nested-1 "mount - nested mount on non-existing path" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set newmount [file join $defMountPt newdir]
+ mount [zippath test-overlay.zip] $newmount
+ list \
+ [lsort [glob -tails -dir $defMountPt *]] \
+ [lsort [glob -tails -dir $newmount *]] \
+ [readbin [file join $newmount test2]]
+ } -result {{newdir test testdir} {test2 test3} test2-overlay}
+
+ test zipfs-mount-nested-2 "mount - nested mount on existing path" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set newmount [file join $defMountPt testdir]
+ mount [zippath test-overlay.zip] $newmount
+ # Note - file from existing mount is preserved (testdir/test2)
+ # Not clear this is desired but defined as such by the
+ # current implementation
+ list \
+ [lsort [glob -tails -dir $defMountPt *]] \
+ [lsort [glob -tails -dir $newmount *]] \
+ [readbin [file join $newmount test2]]
+ } -result [list {test testdir} {test2 test3} test\n]
+
+ #
+ # unmount - only special cases. Normal case already tested as part of other tests
+
+ testnumargs "zipfs unmount" "mountpoint" ""
+
+ test zipfs-unmount-1 "Unmount bogus mount" -body {
+ zipfs unmount [file join [zipfs root] nosuchmount]
+ } -result ""
+
+ test zipfs-unmount-2 "Unmount mount with open files" -setup {
+ mount [zippath test.zip]
+ set fd [open [file join $defMountPt test]]
+ } -cleanup {
+ close $fd
+ cleanup
+ } -body {
+ zipfs unmount $defMountPt
+ } -result {filesystem is busy} -returnCodes error
+
+ test zipfs-unmount-3 "Unmount mount with current directory" -setup {
+ set cwd [pwd]
+ mount [zippath test.zip]
+ } -cleanup {
+ cd $cwd
+ cleanup
+ } -body {
+ # Current directory does not change on unmount.
+ # This is the same behavior as when USB pen drive is unmounted
+ set cwd2 [file join $defMountPt testdir]
+ cd $cwd2
+ list [pwd] [zipfs unmount $defMountPt] [string equal [pwd] $cwd2]
+ } -result [list [file join $defMountPt testdir] {} 1]
+
+ test zipfs-unmount-nested-1 "unmount parent of nested mount on new directory should not affect nested mount" -setup {
+ mount [zippath test.zip]
+ set newmount [file join [zipfs root] test newdir]
+ mount [zippath test-overlay.zip] $newmount
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs unmount $defMountPt
+ list \
+ [zipfs mount $defMountPt] \
+ [lsort [glob -tails -dir $newmount *]] \
+ [readbin [file join $newmount test2]]
+ } -result {{} {test2 test3} test2-overlay}
+
+ test zipfs-unmount-nested-2 "unmount parent of nested mount on existing directory should not affect nested mount" -setup {
+ mount [zippath test.zip]
+ set newmount [file join [zipfs root] test testdir]
+ mount [zippath test-overlay.zip] $newmount
+ } -constraints bug-4ae42446ab -cleanup {
+ cleanup
+ } -body {
+ # KNOWN BUG. The test2 file is also present in parent mount.
+ # After the unmount, the test2 in the nested mount is not
+ # made available.
+ zipfs unmount $defMountPt
+ list \
+ [zipfs mount $defMountPt] \
+ [lsort [glob -tails -dir $newmount *]] \
+ [readbin [file join $newmount test2]]
+ } -result {{} {test2 test3} test2-overlay}
+
+ #
+ # paths inside a zip
+ # TODO - paths encoded in utf-8 vs fallback encoding
+ test zipfs-content-paths-1 "Test absolute and full paths" -setup {
+ mount [zippath test-paths.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ # Primarily verifies that drive letters are stripped and paths maintained
+ lsort [zipfs find $defMountPt]
+ } -result {//zipfs:/testmount/filename.txt //zipfs:/testmount/src //zipfs:/testmount/src/tcltk //zipfs:/testmount/src/tcltk/wip //zipfs:/testmount/src/tcltk/wip/tcl //zipfs:/testmount/src/tcltk/wip/tcl/tests //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/abspath.txt //zipfs:/testmount/src/tcltk/wip/tcl/tests/zipfiles/fullpath.txt}
+
+ #
+ # zipfs list
+ testnumargs "zipfs list" "" "?(-glob|-regexp)? ?pattern?"
+
+ # Generates zipfs list tests for file, memory buffer cases for an archive
+ proc testzipfslist {id cmdargs mounts resultpaths args} {
+ set resultpaths [lmap path $resultpaths {
+ file join [zipfs root] $path
+ }]
+ set resultpaths [lsort $resultpaths]
+ test zipfs-list-$id "zipfs list $id" -body {
+ lsort [zipfs list {*}$cmdargs]
+ } -setup {
+ foreach {zippath mountpoint} $mounts {
+ zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
+ }
+ } -cleanup {
+ cleanup
+ } -result $resultpaths {*}$args
+
+ # Mount memory buffer
+ test zipfs-list-memory-$id "zipfs list memory $id" -body {
+ lsort [zipfs list {*}$cmdargs]
+ } -setup {
+ foreach {zippath mountpoint} $mounts {
+ zipfs mount_data [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
+ }
+ } -cleanup {
+ cleanup
+ } -result $resultpaths {*}$args
+ }
+ # Some tests have !zipfslib constraint because otherwise they dump the entire Tcl library which is mounted on root
+ testzipfslist no-mounts "" {} {} -constraints !zipfslib
+ testzipfslist no-pattern "" {test.zip testmountA} {testmountA testmountA/test testmountA/testdir testmountA/testdir/test2} -constraints !zipfslib
+ testzipfslist no-pattern-mount-on-empty "" {test.zip {}} {{} test testdir testdir/test2} -constraints !zipfslib
+ testzipfslist no-pattern-mount-on-root "" [list test.zip [zipfs root]] {{} test testdir testdir/test2} -constraints !zipfslib
+ testzipfslist no-pattern-mount-on-slash "" [list test.zip /] {{} test testdir testdir/test2} -constraints !zipfslib
+ testzipfslist no-pattern-mount-on-mezzo "" [list test.zip testmt/a/b] {testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2} -constraints {!zipfslib}
+ testzipfslist no-pattern-multiple "" {test.zip testmountA test.zip testmountB/subdir} {
+ testmountA testmountA/test testmountA/testdir testmountA/testdir/test2
+ testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2
+ } -constraints !zipfslib
+ testzipfslist glob [list "*testmount*2*"] {test.zip testmountA test.zip testmountB/subdir} {
+ testmountA/testdir/test2
+ testmountB/subdir/testdir/test2
+ }
+ testzipfslist opt-glob [list -glob "*testmount*2*"] {test.zip testmountA test.zip testmountB/subdir} {
+ testmountA/testdir/test2
+ testmountB/subdir/testdir/test2
+ }
+ testzipfslist opt-regexp [list -regexp "testmount.*(A|2)"] {test.zip testmountA test.zip testmountB/subdir} {
+ testmountA testmountA/test testmountA/testdir testmountA/testdir/test2
+ testmountB/subdir/testdir/test2
+ }
+
+ #
+ # zipfs exists
+ testnumargs "zipfs exists" "filename" ""
+
+ # Generates tests for zipfs exists
+ proc testzipfsexists [list id path result [list mountpoint $defMountPt] args] {
+ test zipfs-exists-$id "zipfs exists $id" -body {
+ zipfs exists $path
+ } -setup {
+ mount [zippath test.zip] $mountpoint
+ } -cleanup {
+ zipfs unmount $mountpoint
+ cleanup
+ } -result $result {*}$args
+ }
+ testzipfsexists native-file [info nameofexecutable] 0
+ testzipfsexists enoent [file join $defMountPt nosuchfile] 0
+ testzipfsexists file [file join $defMountPt test] 1
+ testzipfsexists dir [file join $defMountPt testdir] 1
+ testzipfsexists mountpoint $defMountPt 1
+ testzipfsexists root [zipfs root] 1 $defMountPt
+ testzipfsexists mezzo [file join $defMountPt a b] 1 [file join $defMountPt a b c]
+ testzipfsexists mezzo-enoent [file join $defMountPt a c] 0 [file join $defMountPt a b c]
+
+ #
+ # zipfs find
+ testnumargs "zipfs find" "directoryName" ""
+ # Generates zipfs find tests for file, memory buffer cases for an archive
+ proc testzipfsfind {id findtarget mounts resultpaths args} {
+ set setup {
+ foreach {zippath mountpoint} $mounts {
+ zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
+ }
+ }
+ set memory_setup {
+ foreach {zippath mountpoint} $mounts {
+ zipfs mount_data [readbin [zippath $zippath]] [file join [zipfs root] $mountpoint]
+ }
+ }
+ if {[dict exists $args -setup]} {
+ append setup \n[dict get $args -setup]
+ append memory_setup \n[dict get $args -setup]
+ dict unset args -setup
+ }
+ set cleanup cleanup
+ if {[dict exists $args -cleanup]} {
+ set cleanup "[dict get $args -cleanup]\n$cleanup"
+ dict unset args -cleanup
+ }
+ set resultpaths [lsort $resultpaths]
+ test zipfs-find-$id "zipfs find $id" -body {
+ lsort [zipfs find $findtarget]
+ } -setup $setup -cleanup $cleanup -result $resultpaths {*}$args
+
+ # Mount memory buffer
+ test zipfs-find-memory-$id "zipfs find memory $id" -body {
+ lsort [zipfs find $findtarget]
+ } -setup $memory_setup -cleanup $cleanup -result $resultpaths {*}$args
+ }
+
+ testzipfsfind nonexistingmount [file join [zipfs root] nosuchmount] {
+ test.zip testmountA test.zip testmountB/subdir
+ } {}
+
+ testzipfsfind absolute-path [file join [zipfs root] testmountA] {
+ test.zip testmountA test.zip testmountB/subdir
+ } [zipfspaths testmountA/test testmountA/testdir testmountA/testdir/test2]
+
+ testzipfsfind relative-path testdir {
+ test.zip testmountA test.zip testmountB/subdir
+ } { testdir/test2 } -setup {
+ set cwd [pwd]
+ cd [file join [zipfs root] testmountA]
+ } -cleanup {
+ cd $cwd
+ }
+
+ # bug-6183f535c8
+ testzipfsfind root-path [zipfs root] {
+ test.zip {} test.zip testmountB/subdir
+ } [zipfspaths test testdir testdir/test2 testmountB testmountB/subdir testmountB/subdir/test testmountB/subdir/testdir testmountB/subdir/testdir/test2] -constraints !zipfslib
+
+ testzipfsfind mezzo [file join [zipfs root] testmt a] {
+ test.zip testmt/a/b
+ } [zipfspaths testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2]
+
+ testzipfsfind mezzo-root [zipfs root] {
+ test.zip testmt/a/b
+ } [zipfspaths testmt testmt/a testmt/a/b testmt/a/b/test testmt/a/b/testdir testmt/a/b/testdir/test2] -constraints !zipfslib
+
+ test zipfs-find-native-absolute "zipfs find on native file system" -setup {
+ set dir [makeDirectory zipfs-native-absolute]
+ set subdir [file join $dir subdir]
+ file mkdir $subdir
+ set file [file join $subdir native]
+ close [open $file w]
+ } -cleanup {
+ removeDirectory zipfs-native-absolute
+ } -body {
+ string equal [zipfs find $dir] [list $subdir $file]
+ } -result 1
+
+ test zipfs-find-native-relative "zipfs find relative on native file system" -setup {
+ set dir [makeDirectory zipfs-native-relative]
+ set subdir [file join $dir subdir]
+ file mkdir $subdir
+ set file [file join $subdir native]
+ close [open $file w]
+ set cwd [pwd]
+ } -cleanup {
+ cd $cwd
+ removeDirectory zipfs-native-relative
+ } -body {
+ cd [file dirname $dir]
+ # string equal [zipfs find [file tail $subdir]] [list subdir subdir/native]
+ zipfs find [file tail $dir]
+ } -result {zipfs-native-relative/subdir zipfs-native-relative/subdir/native}
+
+ #
+ # zipfs info
+ testnumargs "zipfs info" "filename" ""
+
+ test zipfs-info-native-nosuchfile "zipfs info on non-existent native path" -body {
+ zipfs info nosuchfile
+ } -result {path "nosuchfile" not found in any zipfs volume} -returnCodes error
+
+ test zipfs-info-native-file "zipfs info on native path" -body {
+ zipfs info [info nameofexecutable]
+ } -result "path \"[info nameofexecutable]\" not found in any zipfs volume" -returnCodes error
+
+ test zipfs-info-nosuchfile "zipfs info non-existent path in mounted archive" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs info [file join $defMountPt nosuchfile]
+ } -result "path \"[file join $defMountPt nosuchfile]\" not found in any zipfs volume" -returnCodes error
+
+ test zipfs-info-file "zipfs info file within mounted archive" -setup {
+ mount [zippath testdeflated2.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs info [file join $defMountPt abac-repeat.txt]
+ } -result [list [zippath testdeflated2.zip] 60 17 108]
+
+ test zipfs-info-dir "zipfs info dir within mounted archive" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs info [file join $defMountPt testdir]
+ } -result [list [zippath test.zip] 0 0 119]
+
+ test zipfs-info-mountpoint "zipfs info on mount point - verify correct offset of zip content" -setup {
+ # zip starts at offset 4
+ mount [zippath junk-at-start.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs info $defMountPt
+ } -result [list [zippath junk-at-start.zip] 0 0 4]
+
+ test zipfs-info-mezzo "zipfs info on mount point - verify correct offset of zip content" -setup {
+ # zip starts at offset 4
+ mount [zippath junk-at-start.zip] /testmt/a/b
+ } -cleanup {
+ cleanup
+ } -body {
+ zipfs info [file join [zipfs root] testmt a]
+ } -result {path "//zipfs:/testmt/a" not found in any zipfs volume} -returnCodes error
+
+ #
+ # zipfs canonical
+ test zipfs-canonical-minargs {zipfs canonical min args} -body {
+ zipfs canonical
+ } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"}
+ test zipfs-canonical-maxargs {zipfs canonical max args} -body {
+ zipfs canonical a b c
+ } -returnCodes error -result {wrong # args: should be "zipfs canonical ?mountpoint? filename"}
+ proc testzipfscanonical {id cmdargs result args} {
+ test zipfs-canonical-$id "zipfs canonical $id" \
+ -body [list zipfs canonical {*}$cmdargs] \
+ -result $result {*}$args
+ }
+ testzipfscanonical default-relative [list a] [file join [zipfs root] a]
+ testzipfscanonical default-absolute [list /a] [file join [zipfs root] a]
+ testzipfscanonical root-relative-1 [list [zipfs root] a] [file join [zipfs root] a]
+ testzipfscanonical root-relative-2 [list / a] [file join [zipfs root] a]
+ testzipfscanonical root-absolute-1 [list [zipfs root] /a] [file join [zipfs root] a]
+ testzipfscanonical root-absolute-2 [list / /a] [file join [zipfs root] a]
+ testzipfscanonical absolute-relative [list /MT a] [file join [zipfs root] MT a]
+ testzipfscanonical absolute-absolute [list /MT /a] [file join [zipfs root] MT a]
+ testzipfscanonical relative-relative [list MT a] [file join [zipfs root] MT a]
+ testzipfscanonical relative-absolute [list MT /a] [file join [zipfs root] MT a]
+ testzipfscanonical mountpoint-trailslash-relative [list MT/ a] [file join [zipfs root] MT a]
+ testzipfscanonical mountpoint-trailslash-absolute [list MT/ /a] [file join [zipfs root] MT a]
+ testzipfscanonical mountpoint-root-relative [list [zipfs root] a] [file join [zipfs root] a]
+ testzipfscanonical mountpoint-root-absolute [list [zipfs root] /a] [file join [zipfs root] a]
+ testzipfscanonical mountpoint-empty-relative [list {} a] [file join [zipfs root] a]
+
+ testzipfscanonical driveletter [list X:] [zipfs root] -constraints win
+ testzipfscanonical drivepath [list X:/foo/bar] [file join [zipfs root] foo bar] -constraints win
+ testzipfscanonical drivepath-1 [list MT X:/foo/bar] [file join [zipfs root] MT foo bar] -constraints win
+ testzipfscanonical backslashes [list X:\\\\foo\\\\bar] [file join [zipfs root] foo bar] -constraints win
+ testzipfscanonical backslashes-1 [list X:/foo\\\\bar] [file join [zipfs root] foo bar] -constraints win
+ testzipfscanonical zipfspath [list //zipfs:/x/y] [file join [zipfs root] x y]
+ testzipfscanonical zipfspath-1 [list MT //zipfs:/x/y] [file join [zipfs root] x y]
+
+ #
+ # Read/uncompress
+ proc testzipfsread {id zippath result {filename abac-repeat.txt} {openopts {}} args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ test zipfs-read-$id "zipfs read $id" -setup {
+ unset -nocomplain fd
+ zipfs mount $zippath $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt $filename] {*}$openopts]
+ gets $fd
+ } -result $result {*}$args
+
+ set data [readbin $zippath]
+ test zipfs-read-memory-$id "zipfs read in-memory $id" -setup {
+ unset -nocomplain fd
+ zipfs mount_data $data $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt $filename] {*}$openopts]
+ gets $fd
+ } -result $result {*}$args
+
+ }
+ testzipfsread stored test.zip test test
+ testzipfsread stored-1 teststored.zip aaaaaaaaaaaaaa
+ testzipfsread deflate testdeflated2.zip aaaaaaaaaaaaaa
+ testzipfsread bug-23dd83ce7c empty.zip {} empty.txt
+ # Test open modes - see bug [4645658689]
+ testzipfsread stored-r+ teststored.zip aaaaaaaaaaaaaa abac-repeat.txt r+
+ testzipfsread deflate-r+ testdeflated2.zip aaaaaaaaaaaaaa abac-repeat.txt r+
+ testzipfsread stored-w+ teststored.zip {} abac-repeat.txt w+
+ testzipfsread deflate-w+ testdeflated2.zip {} abac-repeat.txt w+
+ testzipfsread stored-a+ teststored.zip {} abac-repeat.txt a+
+ testzipfsread deflate-a+ testdeflated2.zip {} abac-repeat.txt a+
+
+ testzipfsread enoent test.zip "file \"//zipfs:/testmount/nosuchfile\" not found: no such file or directory" nosuchfile {} -returnCodes error
+ testzipfsread bzip2 testbzip2.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
+ testzipfsread lzma testfile-lzma.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
+ testzipfsread xz testfile-xz.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
+ testzipfsread zstd testfile-zstd.zip {unsupported compression method} abac-repeat.txt {} -returnCodes error
+ testzipfsread deflate-error broken.zip {decompression error} deflatezliberror {} -returnCodes error
+
+ test zipfs-read-unwritable "Writes not allowed on file opened for read" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ close $fd
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt test]]
+ puts $fd blah
+ } -result {channel "*" wasn't opened for writing} -match glob -returnCodes error
+
+ #
+ # Write
+ proc testzipfswrite {id zippath result filename mode args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ set path [file join $defMountPt $filename]
+ set body {
+ set fd [open $path $mode]
+ fconfigure $fd -translation binary
+ puts -nonewline $fd XYZ
+ seek $fd 0
+ puts -nonewline $fd xyz
+ close $fd
+ set fd [open $path]
+ fconfigure $fd -translation binary
+ read $fd
+ }
+ test zipfs-write-$id "zipfs write $id" -setup {
+ unset -nocomplain fd
+ zipfs mount $zippath $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body $body -result $result {*}$args
+
+ set data [readbin $zippath]
+ test zipfs-write-memory-$id "zipfs write in-memory $id" -setup {
+ unset -nocomplain fd
+ zipfs mount_data $data $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body $body -result $result {*}$args
+
+ }
+ testzipfswrite create-w test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w -returnCodes error
+ testzipfswrite create-w+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile w+ -returnCodes error
+ testzipfswrite create-a test.zip "file \"$defMountPt/newfile\" not created: operation not supported" newfile a -returnCodes error
+ testzipfswrite create-a+ test.zip "file \"//zipfs:/testmount/newfile\" not created: operation not supported" newfile a+ -returnCodes error
+ testzipfswrite store-w teststored.zip "xyz" abac-repeat.txt w
+ testzipfswrite deflate-w testdeflated2.zip "xyz" abac-repeat.txt w
+ testzipfswrite store-w+ teststored.zip "xyz" abac-repeat.txt w+
+ testzipfswrite deflate-w+ testdeflated2.zip "xyz" abac-repeat.txt w+
+ testzipfswrite stored-a teststored.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a
+ testzipfswrite deflate-a testdeflated2.zip "aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZxyz" abac-repeat.txt a
+ testzipfswrite store-a+ teststored.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+
+ testzipfswrite deflate-a+ testdeflated2.zip "xyzaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\nXYZ" abac-repeat.txt a+
+ testzipfswrite bug-23dd83ce7c-w empty.zip "xyz" empty.txt w
+
+ test zipfs-write-unreadable "Reads not allowed on file opened for write" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ close $fd
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt test] w]
+ read $fd
+ } -result {channel "*" wasn't opened for reading} -match glob -returnCodes error
+
+ test zipfs-write-persist "Writes persist ONLY while mounted" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set path [file join $defMountPt test]
+ set fd [open $path w]
+ puts -nonewline $fd newtext
+ close $fd
+ set fd [open $path]
+ set result [list [read $fd]]
+ close $fd
+ zipfs unmount $defMountPt
+ mount [zippath test.zip]
+ set fd [open $path]
+ lappend result [read $fd]
+ close $fd
+ set result
+ } -result [list newtext test\n]
+
+ test zipfs-write-size-limit-0 "Writes more than size limit with flush" -setup {
+ set origlimit $::tcl::zipfs::wrmax
+ mount [zippath test.zip]
+ } -cleanup {
+ close $fd
+ set ::tcl::zipfs::wrmax $origlimit
+ cleanup
+ } -body {
+ set ::tcl::zipfs::wrmax 10
+ set fd [open [file join $defMountPt test] w]
+ puts $fd [string repeat x 11]
+ flush $fd
+ } -result {error flushing *: file too large} -match glob -returnCodes error
+
+ test zipfs-write-size-limit-1 "Writes size limit on close" -setup {
+ set origlimit $::tcl::zipfs::wrmax
+ mount [zippath test.zip]
+ } -cleanup {
+ set ::tcl::zipfs::wrmax $origlimit
+ cleanup
+ } -body {
+ set ::tcl::zipfs::wrmax 10
+ set fd [open [file join $defMountPt test] w]
+ puts $fd [string repeat x 11]
+ close $fd
+ } -result {file too large} -match glob -returnCodes error
+
+ test zipfs-write-size-limit-2 "Writes max size" -setup {
+ set origlimit $::tcl::zipfs::wrmax
+ set ::tcl::zipfs::wrmax 10000000
+ mount [zippath test.zip]
+ } -cleanup {
+ set ::tcl::zipfs::wrmax $origlimit
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt test] w]
+ puts -nonewline $fd [string repeat x $::tcl::zipfs::wrmax]
+ close $fd
+ file size [file join $defMountPt test]
+ } -result 10000000
+
+ test zipfs-write-size-limit-3 "Writes incrementally - buffer growth" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt test] w]
+ fconfigure $fd -buffering none
+ for {set i 0} {$i < 100000} {incr i} {
+ puts -nonewline $fd 0123456789
+ }
+ close $fd
+ readbin [file join $defMountPt test]
+ } -result [string repeat 0123456789 100000]
+
+ test zipfs-write-size-limit-4 "Writes disallowed" -setup {
+ set origlimit $::tcl::zipfs::wrmax
+ mount [zippath test.zip]
+ } -cleanup {
+ set ::tcl::zipfs::wrmax $origlimit
+ cleanup
+ } -body {
+ set ::tcl::zipfs::wrmax -1
+ open [file join $defMountPt test] w
+ } -result {writes not permitted: permission denied} -returnCodes error
+
+ #
+ # read/seek/write
+ proc testzipfsrw {id zippath expected filename mode args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ set path [file join $defMountPt $filename]
+ set body {
+ set result ""
+ set fd [open $path $mode]
+ fconfigure $fd -translation binary
+ append result [gets $fd],
+ set pos [tell $fd]
+ append result $pos,
+ puts -nonewline $fd "0123456789"
+ append result [gets $fd],
+ seek $fd $pos
+ append result [gets $fd],
+ seek $fd -6 end
+ append result [read $fd]|
+ close $fd
+ # Reopen after closing - bug [f91ee30d3]
+ set fd [open $path rb]
+ append result [read $fd]
+ }
+ test zipfs-rw-$id "zipfs read/seek/write $id" -setup {
+ unset -nocomplain fd
+ zipfs mount $zippath $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body $body -result $expected {*}$args
+
+ set data [readbin $zippath]
+ test zipfs-rw-memory-$id "zipfs read/seek/write in-memory $id" -setup {
+ unset -nocomplain fd
+ zipfs mount_data $data $defMountPt
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body $body -result $expected {*}$args
+
+ }
+ testzipfsrw store-r+ teststored.zip "aaaaaaaaaaaaaa,15,bbbb,0123456789bbbb,ccccc\n|aaaaaaaaaaaaaa\n0123456789bbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n" abac-repeat.txt r+
+ testzipfsrw store-w+ teststored.zip ",0,,0123456789,456789|0123456789" abac-repeat.txt w+
+ testzipfsrw store-a+ teststored.zip ",60,,0123456789,456789|aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n0123456789" abac-repeat.txt a+
+ testzipfsrw deflate-r+ testdeflated2.zip "aaaaaaaaaaaaaa,15,bbbb,0123456789bbbb,ccccc\n|aaaaaaaaaaaaaa\n0123456789bbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n" abac-repeat.txt r+
+ testzipfsrw deflate-w+ testdeflated2.zip ",0,,0123456789,456789|0123456789" abac-repeat.txt w+
+ testzipfsrw deflate-a+ testdeflated2.zip ",60,,0123456789,456789|aaaaaaaaaaaaaa\nbbbbbbbbbbbbbb\naaaaaaaaaaaaaa\ncccccccccccccc\n0123456789" abac-repeat.txt a+
+ test zipfs-rw-bug-f91ee30d33 "Bug f91ee30d33 - truncates at last read" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ close $fd
+ cleanup
+ } -body {
+ set path [file join $defMountPt test]
+ set fd [open $path r+]
+ puts -nonewline $fd X
+ close $fd
+ set fd [open $path r]
+ read $fd
+ } -result "Xest\n"
+
+ #
+ # Password protected
+ proc testpasswordr {id zipfile filename password result args} {
+ variable defMountPt
+ set zippath [zippath $zipfile]
+ test zipfs-password-read-$id "zipfs password read $id" -setup {
+ unset -nocomplain fd
+ if {$password ne ""} {
+ zipfs mount $zippath $defMountPt $password
+ } else {
+ zipfs mount $zippath $defMountPt
+ }
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt $filename]]
+ gets $fd
+ } -result $result {*}$args -constraints bbe7c6ff9e
+ }
+ # The bug bbe7c6ff9e only manifests on macos
+ testConstraint bbe7c6ff9e [expr {$::tcl_platform(os) ne "Darwin"}]
+
+ # NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style)
+ # test-password2.zip is the CRC based encryption header validity check (pkware style)
+ testpasswordr plain test-password.zip plain.txt password plaintext
+ testpasswordr plain-nopass test-password.zip plain.txt "" plaintext
+ testpasswordr plain-badpass test-password.zip plain.txt badpassword plaintext
+ testpasswordr cipher-1 test-password.zip cipher.bin password ciphertext
+ testpasswordr cipher-2 test-password2.zip cipher.bin password ciphertext
+ testpasswordr cipher-nopass-1 test-password.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error
+ testpasswordr cipher-nopass-2 test-password2.zip cipher.bin {} "decryption failed - no password provided" -returnCodes error
+ testpasswordr cipher-badpass-1 test-password.zip cipher.bin badpassword "invalid password" -returnCodes error
+ testpasswordr cipher-badpass-2 test-password2.zip cipher.bin badpassword "invalid password" -returnCodes error
+ testpasswordr cipher-deflate test-password.zip cipher-deflate.bin password [lseq 100]
+ testpasswordr cipher-deflate-nopass test-password.zip cipher-deflate.bin {} "decryption failed - no password provided" -returnCodes error
+ testpasswordr cipher-deflate-badpass test-password.zip cipher-deflate.bin badpassword "invalid password" -returnCodes error
+
+ proc testpasswordw {id zippath filename password mode result args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ set path [file join $defMountPt $filename]
+ set body {
+ set fd [open $path $mode]
+ fconfigure $fd -translation binary
+ puts -nonewline $fd "xyz"
+ close $fd
+ set fd [open $path]
+ fconfigure $fd -translation binary
+ read $fd
+ }
+ test zipfs-password-write-$id "zipfs write $id" -setup {
+ unset -nocomplain fd
+ if {$password ne ""} {
+ zipfs mount $zippath $defMountPt $password
+ } else {
+ zipfs mount $zippath $defMountPt
+ }
+ } -cleanup {
+ # In case open succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body $body -result $result {*}$args -constraints bbe7c6ff9e
+ }
+ # NOTE: test-password.zip is the DOS time based encryption header validity check (infozip style)
+ # test-password2.zip is the CRC based encryption header validity check (pkware style)
+ testpasswordw cipher-w-1 test-password.zip cipher.bin password w xyz
+ testpasswordw cipher-w-2 test-password2.zip cipher.bin password w xyz
+ testpasswordw cipher-deflate-w test-password2.zip cipher-deflate.bin password w xyz
+ testpasswordw cipher-badpass-w-1 test-password.zip cipher.bin badpass w {invalid password} -returnCodes error
+ testpasswordw cipher-badpass-w-2 test-password2.zip cipher.bin badpass w {invalid password} -returnCodes error
+ testpasswordw cipher-badpass-deflate-w test-password2.zip cipher-deflate.bin badpass w {invalid password} -returnCodes error
+
+ testpasswordw cipher-w+ test-password.zip cipher.bin password w xyz
+ testpasswordw cipher-deflate-w+ test-password2.zip cipher-deflate.bin password w xyz
+ testpasswordw cipher-badpass-w+ test-password.zip cipher.bin badpass w {invalid password} -returnCodes error
+ testpasswordw cipher-badpass-deflate-w+ test-password2.zip cipher-deflate.bin badpass w {invalid password} -returnCodes error
+
+ testpasswordw cipher-a+ test-password.zip cipher.bin password a+ ciphertextxyz
+ testpasswordw cipher-deflate-a+ test-password2.zip cipher-deflate.bin password a+ [lseq 100]xyz
+ testpasswordw cipher-badpass-a+ test-password.zip cipher.bin badpass a+ {invalid password} -returnCodes error
+ testpasswordw cipher-badpass-deflate-a+ test-password2.zip cipher-deflate.bin badpass a+ {invalid password} -returnCodes error
+
+ #
+ # CRC errors
+ proc testcrc {id zippath filename result args} {
+ variable defMountPt
+ set zippath [zippath $zippath]
+ test zipfs-crc-$id "zipfs crc $id" -setup {
+ unset -nocomplain fd
+ zipfs mount $zippath $defMountPt
+ } -cleanup {
+ # In case mount succeeded when it should not
+ if {[info exists fd]} {
+ close $fd
+ }
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt $filename]]
+ } -result $result -returnCodes error {*}$args
+
+ # Mount memory buffer
+ test zipfs-crc-memory-$id "zipfs crc memory $id" -setup {
+ zipfs mount_data [readbin [zippath $zippath]] $defMountPt
+ } -cleanup {
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt $filename]]
+ } -result $result -returnCodes error {*}$args
+ }
+ testcrc local incons-local-crc.zip a "invalid CRC"
+ testcrc store-crc broken.zip storedcrcerror "invalid CRC"
+ testcrc deflate-crc broken.zip deflatecrcerror "invalid CRC"
+ test zipfs-crc-false-positives {
+ Verify no false positives in CRC checking
+ } -constraints zipfslib -body {
+ # Just loop ensuring no crc failures
+ foreach f [zipfs list] {
+ if {[file isfile $f]} {
+ close [open $f]
+ incr count
+ }
+ }
+ expr {$count > 0}
+ } -result 1
+
+ #
+ # file stat,lstat
+ proc fixuptime {t} {
+ # To compensate for the lack of timezone in zip, all dates
+ # expressed as strings and translated to local time
+ if {[regexp {^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d} $t]} {
+ return [clock scan $t -format "%Y-%m-%d %H:%M:%S"]
+ }
+ return $t
+ }
+ proc fixupstat {stat} {
+ foreach key {atime ctime mtime} {
+ # ZIP files have no TZ info so zipfs uses mktime which is localtime
+ dict set stat $key [fixuptime [dict get $stat $key]]
+ }
+ if {$::tcl_platform(platform) ne "windows"} {
+ dict set stat blksize 0
+ dict set stat blocks 0
+ }
+ return [lsort -stride 2 $stat]
+ }
+ # Wraps stat and lstat
+ proc testzipfsstat {id mountpoint target result args} {
+ test zipfs-file-stat-$id "file stat $id" -setup {
+ zipfs mount [zippath test.zip] $mountpoint
+ } -cleanup cleanup -body {
+ lsort -stride 2 [file stat [file join $mountpoint $target]]
+ } -result $result {*}$args
+
+ test zipfs-file-lstat-$id "file lstat $id" -setup {
+ mount [zippath test.zip]
+ } -cleanup cleanup -body {
+ lsort -stride 2 [file lstat [file join $mountpoint $target]]
+ } -result $result {*}$args
+ }
+ testzipfsstat enoent $defMountPt enoent "could not read \"[file join $defMountPt enoent]\": no such file or directory" -returnCodes error
+ testzipfsstat nosuchmount $defMountPt //zipfs:/notamount/test "could not read \"//zipfs:/notamount/test\": no such file or directory" -returnCodes error
+ testzipfsstat file $defMountPt test [fixupstat {atime {2003-10-06 15:46:42} ctime {2003-10-06 15:46:42} dev 0 gid 0 ino 0 mode 33133 mtime {2003-10-06 15:46:42} nlink 0 size 5 type file uid 0}]
+ testzipfsstat dir $defMountPt testdir [fixupstat {atime {2005-01-11 19:03:54} ctime {2005-01-11 19:03:54} dev 0 gid 0 ino 0 mode 16749 mtime {2005-01-11 19:03:54} nlink 0 size 0 type directory uid 0}]
+ testzipfsstat root-mount [zipfs root] [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
+ testzipfsstat root-subdir-mount $defMountPt [zipfs root] [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
+ testzipfsstat mezzo [file join $defMountPt mt2] $defMountPt [fixupstat {atime .* ctime .* dev 0 gid 0 ino 0 mode 16749 mtime .* nlink 0 size 0 type directory uid 0}] -match regexp
+
+ #
+ # glob of zipfs file
+ proc testzipfsglob {id mounts cmdopts result args} {
+ set setup {
+ foreach {zippath mountpoint} $mounts {
+ zipfs mount [zippath $zippath] [file join [zipfs root] $mountpoint]
+ }
+ }
+ if {[dict exists $args -setup]} {
+ append setup \n[dict get $args -setup]
+ dict unset args -setup
+ }
+ set cleanup cleanup
+ if {[dict exists $args -cleanup]} {
+ set cleanup "[dict get $args -cleanup]\n$cleanup"
+ dict unset args -cleanup
+ }
+ test zipfs-glob-$id "zipfs glob $id $cmdopts" -body {
+ lsort [glob {*}$cmdopts]
+ } -setup $setup -cleanup $cleanup -result $result {*}$args
+ }
+
+ set basicMounts [list test.zip $defMountPt]
+ testzipfsglob basic $basicMounts [list $defMountPt/*] [zipfspathsmt $defMountPt test testdir]
+ testzipfsglob basic-pat $basicMounts [list $defMountPt/t*d*] [zipfspathsmt $defMountPt testdir]
+ testzipfsglob basic-deep $basicMounts [list $defMountPt/tes*/*] [zipfspathsmt $defMountPt testdir/test2]
+ testzipfsglob basic-dir $basicMounts [list -directory $defMountPt *] [zipfspathsmt $defMountPt test testdir]
+ testzipfsglob basic-dir-tails $basicMounts [list -tails -dir $defMountPt *] [list test testdir]
+ testzipfsglob basic-type-d $basicMounts [list -type d $defMountPt/*] [zipfspathsmt $defMountPt testdir]
+ testzipfsglob basic-type-f $basicMounts [list -type f $defMountPt/*] [zipfspathsmt $defMountPt test]
+ testzipfsglob basic-path $basicMounts [list -path $defMountPt/t *d*] [zipfspathsmt $defMountPt testdir]
+ testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] "no files matched glob pattern \"$defMountPt/x*\"" -returnCodes error
+ testzipfsglob basic-enoent-ok $basicMounts [list -nocomplain $defMountPt/x*] {}
+
+ # NOTE: test root mounts separately because some bugs only showed up on these
+ set rootMounts [list test.zip /]
+ testzipfsglob root-1 $rootMounts [list [zipfs root]*] [zipfspaths $::zipLibTop test testdir] -constraints zipfslib
+ testzipfsglob root-2 $rootMounts [list [zipfs root]*] [zipfspaths test testdir] -constraints !zipfslib
+ testzipfsglob root-pat $rootMounts [list [zipfs root]t*d*] [zipfspaths testdir]
+ testzipfsglob root-deep $rootMounts [list [zipfs root]tes*/*] [zipfspaths testdir/test2]
+ testzipfsglob root-dir-1 $rootMounts [list -directory [zipfs root] *] [zipfspaths $::zipLibTop test testdir] -constraints zipfslib
+ testzipfsglob root-dir-2 $rootMounts [list -directory [zipfs root] *] [zipfspaths test testdir] -constraints !zipfslib
+ testzipfsglob root-dir-tails-1 $rootMounts [list -tails -dir [zipfs root] *] [list $::zipLibTop test testdir] -constraints zipfslib
+ testzipfsglob root-dir-tails-2 $rootMounts [list -tails -dir [zipfs root] *] [list test testdir] -constraints !zipfslib
+ testzipfsglob root-type-d-1 $rootMounts [list -type d [zipfs root]*] [zipfspaths $::zipLibTop testdir] -constraints zipfslib
+ testzipfsglob root-type-d-2 $rootMounts [list -type d [zipfs root]*] [zipfspaths testdir] -constraints !zipfslib
+ testzipfsglob root-type-f $rootMounts [list -type f [zipfs root]*] [zipfspaths test]
+ testzipfsglob root-path $rootMounts [list -path [zipfs root]t *d*] [zipfspaths testdir]
+ testzipfsglob root-enoent $rootMounts [list [zipfs root]x*] {no files matched glob pattern "//zipfs:/x*"} -returnCodes error
+ testzipfsglob root-enoent-ok $rootMounts [list -nocomplain [zipfs root]x*] {}
+
+ # glob operations on intermediate directories (mezzo) in mount
+ # paths is another source of bugs
+ set mezzoMounts [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a/c]
+ testzipfsglob mezzo-root-1 $mezzoMounts [list [zipfs root]*] [zipfspaths $::zipLibTop $defMountPt] -constraints zipfslib
+ testzipfsglob mezzo-root-2 $mezzoMounts [list [zipfs root]*] [list $defMountPt] -constraints !zipfslib
+ testzipfsglob mezzo-mountgrandparent $mezzoMounts [list $defMountPt/*] [list $defMountPt/a]
+ testzipfsglob mezzo-mountparent $mezzoMounts [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b c]
+ testzipfsglob mezzo-overlay [list test.zip $defMountPt/a/b test-overlay.zip $defMountPt/a] [list $defMountPt/a/*] [zipfspathsmt $defMountPt/a b test2 test3]
+
+ #
+ # file attributes
+ proc testzipfsfileattr [list id path result [list mountpoint $defMountPt] args] {
+ test zipfs-file-attrs-$id "zipfs file attrs $id" -setup {
+ mount [zippath test.zip] $mountpoint
+ } -cleanup cleanup -body {
+ lsort -stride 2 [file attributes $path]
+ } -result $result {*}$args
+ }
+ testzipfsfileattr noent [file join $defMountPt nosuchfile] \
+ {file not found: no such file or directory} $defMountPt -returnCodes error
+ testzipfsfileattr file [file join $defMountPt test] \
+ [list -archive [zippath test.zip] -compsize 5 -crc [expr 0x3BB935C6] -mount $defMountPt -offset 55 -permissions 0o555 -uncompsize 5]
+ testzipfsfileattr dir [file join $defMountPt testdir] \
+ [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 119 -permissions 0o555 -uncompsize 0]
+ testzipfsfileattr root [zipfs root] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0}
+ testzipfsfileattr mountpoint $defMountPt \
+ [list -archive [zippath test.zip] -compsize 0 -crc 0 -mount $defMountPt -offset 0 -permissions 0o555 -uncompsize 0]
+ testzipfsfileattr mezzo [file join $defMountPt a b] {-archive {} -compsize 0 -crc 0 -mount {} -offset 0 -permissions 0o555 -uncompsize 0} [file join $defMountPt a b c]
+
+ foreach attr {-uncompsize -compsize -offset -mount -archive -permissions -crc} {
+ test zipfs-file-attrs-set$attr "Set zipfs file attribute $attr" -setup {
+ mount [zippath test.zip]
+ } -cleanup cleanup \
+ -body "file attributes [file join $defMountPt test] $attr {}" \
+ -result "unsupported operation" -returnCodes error
+ }
+
+ #
+ # file normalize
+ proc testzipfsnormalize {id path result {dir {}}} {
+ if {$dir eq ""} {
+ test zipfs-file-normalize-$id "zipfs file normalize $id" -body {
+ file normalize $path
+ } -result $result
+ } else {
+ test zipfs-file-normalize-$id "zipfs file normalize $id" -setup {
+ set cwd [pwd]
+ mount [zippath test.zip] [zipfs root]
+ cd $dir
+ } -cleanup {
+ cd $cwd
+ cleanup
+ } -body {
+ file normalize $path
+ } -result $result
+ }
+ }
+ # The parsing requires all these cases for various code paths
+ # in particular, root, one below root and more than one below root
+ testzipfsnormalize dot-1 [zipfs root] [zipfs root]
+ testzipfsnormalize dot-2 [file join [zipfs root] .] [zipfs root]
+ testzipfsnormalize dot-3 [file join [zipfs root] . .] [zipfs root]
+ testzipfsnormalize dot-4 [file join [zipfs root] a .] [file join [zipfs root] a]
+ testzipfsnormalize dot-5 [file join [zipfs root] a . . .] [file join [zipfs root] a]
+ testzipfsnormalize dot-6 [file join [zipfs root] a b .] [file join [zipfs root] a b]
+ testzipfsnormalize dot-7 [file join [zipfs root] a b . .] [file join [zipfs root] a b]
+
+ testzipfsnormalize dotdot-1 [file join [zipfs root] ..] [zipfs root]
+ testzipfsnormalize dotdot-2 [file join [zipfs root] .. ..] [zipfs root]
+ testzipfsnormalize dotdot-3 [file join [zipfs root] a ..] [zipfs root]
+ testzipfsnormalize dotdot-4 [file join [zipfs root] a .. .. ..] [zipfs root]
+ testzipfsnormalize dotdot-5 [file join [zipfs root] a b ..] [file join [zipfs root] a]
+ testzipfsnormalize dotdot-6 [file join [zipfs root] a b ..] [file join [zipfs root] a]
+ testzipfsnormalize dotdot-7 [file join [zipfs root] a b .. ..] [zipfs root]
+ testzipfsnormalize dotdot-8 [file join [zipfs root] a b .. .. .. ..] [zipfs root]
+
+ testzipfsnormalize relative-1 a [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-2 . [zipfs root] [zipfs root]
+ testzipfsnormalize relative-3 ./ [zipfs root] [zipfs root]
+ testzipfsnormalize relative-4 ./a [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-5 ../ [file join [zipfs root]] [zipfs root]
+ testzipfsnormalize relative-6 ../a [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-7 ../a/ [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-8 ../.. [zipfs root] [zipfs root]
+ testzipfsnormalize relative-9 dir/a [file join [zipfs root] dir a] [zipfs root]
+ testzipfsnormalize relative-10 dir/dirb/.. [file join [zipfs root] dir] [zipfs root]
+ testzipfsnormalize relative-11 dir/../a [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-12 dir/../a/ [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-13 dir/../../../a [file join [zipfs root] a] [zipfs root]
+ testzipfsnormalize relative-14 a [file join [zipfs root] testdir a] [file join [zipfs root] testdir]
+
+ #
+ # file copy
+ test zipfs-file-copy-tozip-new {Copy native file to archive} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ removeFile $_
+ cleanup
+ } -body {
+ file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt X]
+ } -result "error copying \"*source.tmp\" to \"[file join $defMountPt X]\": operation not supported" \
+ -match glob -returnCodes error
+ test zipfs-file-copy-tozip-existing {Copy native file to archive} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ removeFile $_
+ cleanup
+ } -body {
+ file copy [set _ [makeFile "newtext" source.tmp]] [file join $defMountPt test]
+ } -result "error copying *: file exists" -match glob -returnCodes error
+ test zipfs-file-copy-tozip-existing-force {Copy native file to archive} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ removeFile $_
+ cleanup
+ } -body {
+ set to [file join $defMountPt test]
+ file copy -force [set _ [makeFile "newtext" source.tmp]] $to
+ readbin $to
+ } -result "newtext\n"
+ test zipfs-file-copy-tozipdir {Copy native file to archive directory} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ removeFile $_
+ cleanup
+ } -body {
+ file copy [set _ [makeFile "" source.tmp]] [file join $defMountPt testdir]
+ } -result "error copying \"*source.tmp\" to \"[file join $defMountPt testdir]/source.tmp\": operation not supported" \
+ -match glob -returnCodes error
+ test zipfs-file-copydir-tozipdir {Copy native dir to archive directory} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ file copy [temporaryDirectory] [file join $defMountPt testdir]
+ } -result "can't create directory *: operation not supported" \
+ -match glob -returnCodes error
+ test zipfs-file-copy-fromzip-new {Copy archive file to native} -setup {
+ mount [zippath test.zip]
+ set dst [file join [temporaryDirectory] dst.tmp]
+ file delete $dst
+ } -cleanup {
+ file delete $dst
+ cleanup
+ } -body {
+ file copy [file join $defMountPt test] $dst
+ readbin $dst
+ } -result "test\n"
+ test zipfs-file-copydir-fromzip-1 {Copy archive dir to native} -setup {
+ mount [zippath test.zip]
+ set dst [file join [temporaryDirectory] dstdir.tmp]
+ file delete -force $dst
+ } -cleanup {
+ file delete -force $dst
+ cleanup
+ } -body {
+ file copy [file join $defMountPt testdir] $dst
+ zipfs find $dst
+ } -result [file join [temporaryDirectory] dstdir.tmp test2]
+ test zipfs-file-copymount-fromzip-new {Copy archive mount to native} -setup {
+ mount [zippath test.zip]
+ set dst [file join [temporaryDirectory] dstdir2.tmp]
+ file delete -force $dst
+ } -cleanup {
+ file delete -force $dst
+ cleanup
+ } -body {
+ file copy $defMountPt $dst
+ list [file isfile [file join $dst test]] \
+ [file isdirectory [file join $dst testdir]] \
+ [file isfile [file join $dst testdir test2]]
+ } -result {1 1 1}
+
+ #
+ # file delete
+ test zipfs-file-delete "Delete file in zip archive" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set file [file join $defMountPt test]
+ list \
+ [file exists $file] \
+ [catch {file delete $file} msg] \
+ $msg \
+ [file exists $file]
+ } -result [list 1 1 {error deleting "//zipfs:/testmount/test": operation not supported} 1]
+
+ test zipfs-file-delete-enoent "Delete nonexisting path in zip archive" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set file [file join $defMountPt enoent]
+ list \
+ [file exists $file] \
+ [catch {file delete $file} msg] \
+ $msg \
+ [file exists $file]
+ } -result [list 0 0 {} 0]
+
+ test zipfs-file-delete-dir "Delete dir in zip archive" -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set dir [file join $defMountPt testdir]
+ list \
+ [file isdirectory $dir] \
+ [catch {file delete -force $dir} msg] \
+ $msg \
+ [file isdirectory $dir]
+ } -result [list 1 1 {error deleting unknown file: operation not supported} 1]
+
+ #
+ # file join
+ test zipfs-file-join-1 "Ensure file join recognizes zipfs path as absolute" -body {
+ file join /abc [zipfs root]a/b/c
+ } -result [zipfs root]a/b/c
+
+ #
+ # file mkdir
+ test zipfs-file-mkdir {Make a directory in zip archive} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ file mkdir [file join $defMountPt newdir]
+ } -result "can't create directory \"[file join $defMountPt newdir]\": operation not supported" -returnCodes error
+ test zipfs-file-mkdir-existing {Make a an existing directory in zip archive} -setup {
+ mount [zippath test.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set dir [file join $defMountPt testdir]
+ file mkdir $dir
+ file isdirectory $dir
+ } -result 1
+
+ # Standard paths for file command tests. Because code paths are different,
+ # we need tests for...
+ set targetMountParent $defMountPt; # Parent of mount directory
+ set targetMount [file join $targetMountParent mt] ; # Mount directory
+ set targetFile [file join $targetMount test]; # Normal file
+ set targetDir [file join $targetMount testdir]; # Directory
+ set targetEnoent [file join $targetMount enoent]; # Non-existing path
+
+ proc testzipfsfile {id cmdargs result args} {
+ variable targetMount
+ test zipfs-file-$id "file $id on zipfs" -setup {
+ zipfs mount [zippath test.zip] $targetMount
+ } -cleanup cleanup -body {
+ file {*}$cmdargs
+ } -result $result {*}$args
+ }
+ proc testzipfsenotsup {id cmdargs args} {
+ testzipfsfile $id $cmdargs "*: operation not supported" -match glob -returnCodes error
+ }
+
+ #
+ # file atime
+
+ testzipfsfile atime-get-file [list atime $targetFile] [fixuptime {2003-10-06 15:46:42}]
+ testzipfsfile atime-get-dir [list atime $targetDir] [fixuptime {2005-01-11 19:03:54}]
+ testzipfsfile atime-get-mount [list atime $targetMount] {\d+} -match regexp
+ testzipfsfile atime-get-mezzo [list atime $targetMountParent] {\d+} -match regexp
+ testzipfsfile atime-get-root [list atime [zipfs root]] {\d+} -match regexp
+ testzipfsfile atime-get-enoent [list atime $targetEnoent] \
+ "could not read \"$targetEnoent\": no such file or directory" -returnCodes error
+
+ set t [clock seconds]
+ testzipfsenotsup atime-set-file [list atime $targetFile $t]
+ testzipfsenotsup atime-set-dir [list atime $targetDir $t]
+ testzipfsenotsup atime-set-mount [list atime $targetMount $t]
+ testzipfsenotsup atime-set-mezzo [list atime $targetMountParent $t]
+ testzipfsenotsup atime-set-root [list atime [zipfs root] $t]
+ testzipfsfile atime-set-enoent [list atime $targetEnoent $t] \
+ "could not read \"$targetEnoent\": no such file or directory" -returnCodes error
+
+ #
+ # file dirname
+ testzipfsfile dirname-file [list dirname $targetFile] $targetMount
+ testzipfsfile dirname-dir [list dirname $targetDir] $targetMount
+ testzipfsfile dirname-mount [list dirname $targetMount] $targetMountParent
+ testzipfsfile dirname-mezzo [list dirname $targetMountParent] [zipfs root]
+ testzipfsfile dirname-root [list dirname [zipfs root]] [zipfs root]
+ testzipfsfile dirname-enoent [list dirname $targetEnoent] $targetMount
+
+ #
+ # file executable
+ testzipfsfile executable-file [list executable $targetFile] 0
+ testzipfsfile executable-dir [list executable $targetDir] 0
+ testzipfsfile executable-mount [list executable $targetMount] 0
+ testzipfsfile executable-mezzo [list executable $targetMountParent] 0
+ testzipfsfile executable-root [list executable [zipfs root]] 0
+ testzipfsfile executable-enoent [list executable $targetEnoent] 0
+
+ #
+ # file exists
+ testzipfsfile exists-file [list exists $targetFile] 1
+ testzipfsfile exists-dir [list exists $targetDir] 1
+ testzipfsfile exists-mount [list exists $targetMount] 1
+ testzipfsfile exists-mezzo [list exists $targetMountParent] 1
+ testzipfsfile exists-root [list exists [zipfs root]] 1
+ testzipfsfile exists-enoent [list exists $targetEnoent] 0
+
+ #
+ # file isdirectory
+ testzipfsfile isdirectory-file [list isdirectory $targetFile] 0
+ testzipfsfile isdirectory-dir [list isdirectory $targetDir] 1
+ testzipfsfile isdirectory-mount [list isdirectory $targetMount] 1
+ testzipfsfile isdirectory-mezzo [list isdirectory $targetMountParent] 1
+ testzipfsfile isdirectory-root [list isdirectory [zipfs root]] 1
+ testzipfsfile isdirectory-enoent [list isdirectory $targetEnoent] 0
+
+ #
+ # file isfile
+ testzipfsfile isfile-file [list isfile $targetFile] 1
+ testzipfsfile isfile-dir [list isfile $targetDir] 0
+ testzipfsfile isfile-mount [list isfile $targetMount] 0
+ testzipfsfile isfile-mezzo [list isfile $targetMountParent] 0
+ testzipfsfile isfile-root [list isfile [zipfs root]] 0
+ testzipfsfile isfile-enoent [list isfile $targetEnoent] 0
+
+ #
+ # file link
+ testzipfsfile link-read-enoent [list link [file join $targetDir l]] {could not read link "//zipfs:/testmount/mt/testdir/l": operation not supported} -returnCodes error
+ testzipfsfile link-read-notalink [list link $targetFile] {could not read link "//zipfs:/testmount/mt/test": operation not supported} -returnCodes error
+ testzipfsfile link-write [list link [file join $targetDir l] $targetFile] {could not create new link "//zipfs:/testmount/mt/testdir/l" pointing to "//zipfs:/testmount/mt/test": operation not supported} -returnCodes error
+
+ #
+ # file mtime
+
+ testzipfsfile mtime-get-file [list mtime $targetFile] [fixuptime {2003-10-06 15:46:42}]
+ testzipfsfile mtime-get-dir [list mtime $targetDir] [fixuptime {2005-01-11 19:03:54}]
+ testzipfsfile mtime-get-mount [list mtime $targetMount] {\d+} -match regexp
+ testzipfsfile mtime-get-mezzo [list mtime $targetMountParent] {\d+} -match regexp
+ testzipfsfile mtime-get-root [list mtime [zipfs root]] {\d+} -match regexp
+ testzipfsfile mtime-set-enoent [list mtime $targetEnoent $t] \
+ "could not read \"$targetEnoent\": no such file or directory" -returnCodes error
+
+ set t [clock seconds]
+ testzipfsenotsup mtime-set-file [list mtime $targetFile $t]
+ testzipfsenotsup mtime-set-dir [list mtime $targetDir $t]
+ testzipfsenotsup mtime-set-mount [list mtime $targetMount $t]
+ testzipfsenotsup mtime-set-mezzo [list mtime $targetMountParent $t]
+ testzipfsenotsup mtime-set-root [list mtime [zipfs root] $t]
+ testzipfsfile mtime-set-enoent-1 [list mtime $targetEnoent $t] \
+ "could not read \"$targetEnoent\": no such file or directory" -returnCodes error
+
+ #
+ # file owned
+ testzipfsfile owned-file [list owned $targetFile] 1
+ testzipfsfile owned-dir [list owned $targetDir] 1
+ testzipfsfile owned-mount [list owned $targetMount] 1
+ testzipfsfile owned-mezzo [list owned $targetMountParent] 1
+ testzipfsfile owned-root [list owned [zipfs root]] 1
+ testzipfsfile owned-enoent [list owned $targetEnoent] 0
+
+ #
+ # file pathtype
+ testzipfsfile pathtype [list pathtype $targetFile] absolute
+
+ #
+ # file readable
+ testzipfsfile readable-file [list readable $targetFile] 1
+ testzipfsfile readable-dir [list readable $targetDir] 1
+ testzipfsfile readable-mount [list readable $targetMount] 1
+ testzipfsfile readable-mezzo [list readable $targetMountParent] 1
+ testzipfsfile readable-root [list readable [zipfs root]] 1
+ testzipfsfile readable-enoent [list readable $targetEnoent] 0
+
+ #
+ # file separator
+ testzipfsfile separator [list separator $targetFile] /
+
+ #
+ # file size
+ testzipfsfile size-file [list size $targetFile] 5
+ testzipfsfile size-dir [list size $targetDir] 0
+ testzipfsfile size-mount [list size $targetMount] 0
+ testzipfsfile size-mezzo [list size $targetMountParent] 0
+ testzipfsfile size-root [list size [zipfs root]] 0
+ testzipfsfile size-enoent [list size $targetEnoent] \
+ "could not read \"$targetEnoent\": no such file or directory" -returnCodes error
+
+ #
+ # file split
+ testzipfsfile split-file [list split $targetFile] [list [zipfs root] testmount mt test]
+ testzipfsfile split-root [list split [zipfs root]] [list [zipfs root]]
+ testzipfsfile split-enoent [list split $targetEnoent] [list [zipfs root] testmount mt enoent]
+
+ #
+ # file system
+ testzipfsfile system-file [list system $targetFile] {zipfs zip}
+ testzipfsfile system-root [list system [zipfs root]] {zipfs zip}
+ testzipfsfile system-enoent [list system $targetEnoent] {zipfs zip}
+
+ #
+ # file type
+ testzipfsfile type-file [list type $targetFile] file
+ testzipfsfile type-dir [list type $targetDir] directory
+ testzipfsfile type-mount [list type $targetMount] directory
+ testzipfsfile type-mezzo [list type $targetMountParent] directory
+ testzipfsfile type-root [list type [zipfs root]] directory
+ testzipfsfile type-enoent [list type $targetEnoent] {could not read "//zipfs:/testmount/mt/enoent": no such file or directory} -returnCodes error
+
+ #
+ # file writable
+ testzipfsfile writable-file [list writable $targetFile] 1
+ testzipfsfile writable-dir [list writable $targetDir] 0
+ testzipfsfile writable-mount [list writable $targetMount] 0
+ testzipfsfile writable-mezzo [list writable $targetMountParent] 0
+ testzipfsfile writable-root [list writable [zipfs root]] 0
+ testzipfsfile writable-enoent [list writable $targetEnoent] 0
+
+ # TODO - mkkey, mkimg, mkzip, lmkimg, lmkzip
+ testnumargs "zipfs mkkey" "password" "" -constraints zipfs
+ testnumargs "zipfs mkimg" "outfile indir" "?strip? ?password? ?infile?"
+ testnumargs "zipfs lmkimg" "outfile inlist" "?password? ?infile?"
+ testnumargs "zipfs mkzip" "outfile indir" "?strip? ?password?"
+ testnumargs "zipfs lmkzip" "outfile inlist" "?password?"
+
+ #
+ # Bug regressions
+
+ test bug-6ed3447a7e "Crash opening file in streamed archive" -setup {
+ mount [zippath streamed.zip]
+ } -cleanup {
+ cleanup
+ } -body {
+ set fd [open [file join $defMountPt -]]
+ list [catch {read $fd} message] [close $fd] $message
+ close $fd
+ } -result {file size error (may be zip64)} -returnCodes error
+
+ test bug-8259d74a64 "Crash exiting with open files" -setup {
+ set path [zippath test.zip]
+ set script "zipfs mount $path /\n"
+ append script {open [zipfs root]test} \n
+ append script "exit\n"
+ } -body {
+ set fd [open |[info nameofexecutable] r+]
+ puts $fd $script
+ flush $fd
+ read $fd
+ close $fd
+ } -result ""
+
+ # Following will only show a leak with valgrind
+ test bug-9525f4c8bc "Memory leak with long mount paths" -body {
+ set mt //zipfs:[string repeat /x 240]
+ zipfs mount [zippath test.zip] $mt
+ zipfs unmount $mt
+ } -result ""
+
+ test bug-33b2486199 "zipfs unmounted on thread exit" -constraints {
+ thread
+ } -body {
+ set before [lsort [zipfs mount]]
+ thread::release [thread::create]
+ after 100; # Needed to allow the spawned thread to exit to trigger bug
+ string equal $before [lsort [zipfs mount]]
+ } -result 1
+}
+
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/zlib.test b/tests/zlib.test
index 5312d2b..7679102 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -4,8 +4,8 @@
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
-# Copyright (c) 1996-1998 by Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright © 1996-1998 Sun Microsystems, Inc.
+# Copyright © 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.
@@ -15,6 +15,8 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+source [file join [file dirname [info script]] tcltests.tcl]
+
testConstraint zlib [llength [info commands zlib]]
testConstraint recentZlib 0
catch {
@@ -34,7 +36,7 @@ test zlib-1.3 {zlib basics} -constraints zlib -body {
zlib::pkgconfig list
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
- package present zlib
+ package present tcl::zlib
} -result 2.0.1
test zlib-2.1 {zlib compress/decompress} zlib {
@@ -286,23 +288,23 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup {
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]
-} -constraints zlib -body {
+} -constraints {zlib deprecated} -body {
list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
-} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
+} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}}
test zlib-8.7 {transformation and fconfigure} -setup {
set file [makeFile {} test.gz]
set fd [open $file wb]
-} -constraints zlib -body {
+} -constraints {zlib deprecated} -body {
list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \
[chan pop $fd; fconfigure $fd]
} -cleanup {
catch {close $fd}
removeFile $file
-} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}}
+} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}}
# Input is headers from fetching SPDY draft
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
diff --git a/tools/Makefile.in b/tools/Makefile.in
deleted file mode 100644
index 5e9f88e..0000000
--- a/tools/Makefile.in
+++ /dev/null
@@ -1,67 +0,0 @@
-# This makefile is used to convert Tcl manual pages into various
-# alternate formats:
-#
-# Windows help file: 1. Build the winhelp target on Unix
-# 2. Build the helpfile target on Windows
-#
-# HTML: 1. Build the html target on Unix
-
-TCL = tcl@TCL_VERSION@
-TK = tk@TCL_VERSION@
-VER = @TCL_WIN_VERSION@
-
-TCL_BIN_DIR = @TCL_BIN_DIR@
-TCL_SOURCE = @TCL_SRC_DIR@
-TK_SOURCE = $(TCL_SOURCE)/../$(TK)
-PRO_SOURCE = $(TCL_SOURCE)/../pro
-ITCL_SOURCE = $(TCL_SOURCE)/../itcl3.1.0
-
-TCL_DOCS = $(TCL_SOURCE)/doc/*.[13n]
-
-TK_DOCS = $(TK_SOURCE)/doc/*.[13n]
-
-PRO_DOCS = \
- $(PRO_SOURCE)/doc/man/procheck.1 \
- $(PRO_SOURCE)/doc/man/prodebug.1 \
- $(PRO_SOURCE)/doc/man/prodebug.n \
- $(PRO_SOURCE)/doc/man/prolicense.1
-
-ITCL_DOCS = \
- $(ITCL_SOURCE)/itcl/doc/*.[13n] \
- $(ITCL_SOURCE)/itk/doc/*.[13n]
-
-# $(ITCL_SOURCE)/iwidgets3.0.0/doc/*.[13n]
-
-COREDOCS = $(TCL_DOCS) $(TK_DOCS)
-#PRODOCS = $(COREDOCS) $(PRO_DOCS) $(ITCL_DOCS)
-PRODOCS = $(COREDOCS) $(PRO_DOCS)
-TCLSH = $(TCL_BIN_DIR)/tclsh
-CC = @CC@
-
-#
-# Targets
-#
-
-all: core
-
-pro:
- $(MAKE) DOCS="$(PRODOCS)" VER="" rtf
-
-core:
- $(MAKE) DOCS="$(COREDOCS)" rtf
-
-rtf: $(TCL_SOURCE)/tools/man2help.tcl man2tcl $(DOCS)
- LD_LIBRARY_PATH=$(TCL_BIN_DIR) \
- TCL_LIBRARY=$(TCL_SOURCE)/library \
- $(TCLSH) $(TCL_SOURCE)/tools/man2help.tcl tcl "$(VER)" $(DOCS)
-
-winhelp: tcl.rtf
-
-man2tcl: $(TCL_SOURCE)/tools/man2tcl.c
- $(CC) $(CFLAGS) -o man2tcl $(TCL_SOURCE)/tools/man2tcl.c
-
-clean:
- -rm -f man2tcl *.o *.cnt *.rtf
-
-helpfile:
- hcw /c /e tcl.hpj
diff --git a/tools/addVerToFile.tcl b/tools/addVerToFile.tcl
new file mode 100755
index 0000000..bfc39e2
--- /dev/null
+++ b/tools/addVerToFile.tcl
@@ -0,0 +1,9 @@
+#!/usr/bin/env tclsh
+if {$argc < 1} {
+ error "need a filename argument"
+}
+lassign $argv filename
+set f [open $filename a]
+puts $f "TCL_VERSION=[info tclversion]"
+puts $f "TCL_PATCHLEVEL=[info patchlevel]"
+close $f
diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl
index a3aa309..36d82b2 100644
--- a/tools/checkLibraryDoc.tcl
+++ b/tools/checkLibraryDoc.tcl
@@ -3,7 +3,7 @@
# This script attempts to determine what APIs exist in the source base that
# have not been documented. By grepping through all of the doc/*.3 man
# pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list
-# against the list of Pkg_ APIs found in the source (e.g., tcl8.6/*/*.[ch])
+# against the list of Pkg_ APIs found in the source (e.g., tcl8.7/*/*.[ch])
# we create six lists:
# 1) APIs in Source not in Docs.
# 2) APIs in Docs not in Source.
@@ -16,7 +16,7 @@
# non-standard code, this script will produce erroneous results. Each
# list should be carefully checked for accuracy.
#
-# Copyright (c) 1998-1999 Scriptics Corporation.
+# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
diff --git a/tools/configure b/tools/configure
deleted file mode 100755
index 29a4c1c..0000000
--- a/tools/configure
+++ /dev/null
@@ -1,2172 +0,0 @@
-#! /bin/sh
-# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.59.
-#
-# Copyright (C) 2003 Free Software Foundation, Inc.
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-## --------------------- ##
-## M4sh Initialization. ##
-## --------------------- ##
-
-# Be Bourne compatible
-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
- emulate sh
- NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
- # is contrary to our usage. Disable this feature.
- alias -g '${1+"$@"}'='"$@"'
-elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
- set -o posix
-fi
-DUALCASE=1; export DUALCASE # for MKS sh
-
-# Support unset when possible.
-if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
- as_unset=unset
-else
- as_unset=false
-fi
-
-
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
-PS1='$ '
-PS2='> '
-PS4='+ '
-
-# NLS nuisances.
-for as_var in \
- LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
- LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
- LC_TELEPHONE LC_TIME
-do
- if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
- eval $as_var=C; export $as_var
- else
- $as_unset $as_var
- fi
-done
-
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
-
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
- as_basename=basename
-else
- as_basename=false
-fi
-
-
-# Name of the executable.
-as_me=`$as_basename "$0" ||
-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
- X"$0" : 'X\(//\)$' \| \
- X"$0" : 'X\(/\)$' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X/"$0" |
- sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; }
- /^X\/\(\/\/\)$/{ s//\1/; q; }
- /^X\/\(\/\).*/{ s//\1/; q; }
- s/.*/./; q'`
-
-
-# PATH needs CR, and LINENO needs CR and PATH.
-# Avoid depending upon Character Ranges.
-as_cr_letters='abcdefghijklmnopqrstuvwxyz'
-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
-as_cr_Letters=$as_cr_letters$as_cr_LETTERS
-as_cr_digits='0123456789'
-as_cr_alnum=$as_cr_Letters$as_cr_digits
-
-# The user is always right.
-if test "${PATH_SEPARATOR+set}" != set; then
- echo "#! /bin/sh" >conf$$.sh
- echo "exit 0" >>conf$$.sh
- chmod +x conf$$.sh
- if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
- PATH_SEPARATOR=';'
- else
- PATH_SEPARATOR=:
- fi
- rm -f conf$$.sh
-fi
-
-
- as_lineno_1=$LINENO
- as_lineno_2=$LINENO
- as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
- test "x$as_lineno_1" != "x$as_lineno_2" &&
- test "x$as_lineno_3" = "x$as_lineno_2" || {
- # Find who we are. Look in the path if we contain no path at all
- # relative or not.
- case $0 in
- *[\\/]* ) as_myself=$0 ;;
- *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
-done
-
- ;;
- esac
- # We did not find ourselves, most probably we were run as `sh COMMAND'
- # in which case we are not to be found in the path.
- if test "x$as_myself" = x; then
- as_myself=$0
- fi
- if test ! -f "$as_myself"; then
- { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2
- { (exit 1); exit 1; }; }
- fi
- case $CONFIG_SHELL in
- '')
- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for as_base in sh bash ksh sh5; do
- case $as_dir in
- /*)
- if ("$as_dir/$as_base" -c '
- as_lineno_1=$LINENO
- as_lineno_2=$LINENO
- as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
- test "x$as_lineno_1" != "x$as_lineno_2" &&
- test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then
- $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; }
- $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; }
- CONFIG_SHELL=$as_dir/$as_base
- export CONFIG_SHELL
- exec "$CONFIG_SHELL" "$0" ${1+"$@"}
- fi;;
- esac
- done
-done
-;;
- esac
-
- # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
- # uniformly replaced by the line number. The first 'sed' inserts a
- # line-number line before each line; the second 'sed' does the real
- # work. The second script uses 'N' to pair each line-number line
- # with the numbered line, and appends trailing '-' during
- # substitution so that $LINENO is not a special case at line end.
- # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
- # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-)
- sed '=' <$as_myself |
- sed '
- N
- s,$,-,
- : loop
- s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
- t loop
- s,-$,,
- s,^['$as_cr_digits']*\n,,
- ' >$as_me.lineno &&
- chmod +x $as_me.lineno ||
- { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
- { (exit 1); exit 1; }; }
-
- # Don't try to exec as it changes $[0], causing all sort of problems
- # (the dirname of $[0] is not the place where we might find the
- # original and so on. Autoconf is especially sensible to this).
- . ./$as_me.lineno
- # Exit status is that of the last command.
- exit
-}
-
-
-case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in
- *c*,-n*) ECHO_N= ECHO_C='
-' ECHO_T=' ' ;;
- *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;;
- *) ECHO_N= ECHO_C='\c' ECHO_T= ;;
-esac
-
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
-
-rm -f conf$$ conf$$.exe conf$$.file
-echo >conf$$.file
-if ln -s conf$$.file conf$$ 2>/dev/null; then
- # We could just check for DJGPP; but this test a) works b) is more generic
- # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04).
- if test -f conf$$.exe; then
- # Don't use ln at all; we don't have any links
- as_ln_s='cp -p'
- else
- as_ln_s='ln -s'
- fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
-else
- as_ln_s='cp -p'
-fi
-rm -f conf$$ conf$$.exe conf$$.file
-
-if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
-else
- test -d ./-p && rmdir ./-p
- as_mkdir_p=false
-fi
-
-as_executable_p="test -f"
-
-# Sed expression to map a string onto a valid CPP name.
-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
-
-# Sed expression to map a string onto a valid variable name.
-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
-
-
-# IFS
-# We need space, tab and new line, in precisely that order.
-as_nl='
-'
-IFS=" $as_nl"
-
-# CDPATH.
-$as_unset CDPATH
-
-
-# Name of the host.
-# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
-# so uname gets run too.
-ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
-
-exec 6>&1
-
-#
-# Initializations.
-#
-ac_default_prefix=/usr/local
-ac_config_libobj_dir=.
-cross_compiling=no
-subdirs=
-MFLAGS=
-MAKEFLAGS=
-SHELL=${CONFIG_SHELL-/bin/sh}
-
-# Maximum number of lines to put in a shell here document.
-# This variable seems obsolete. It should probably be removed, and
-# only ac_max_sed_lines should be used.
-: ${ac_max_here_lines=38}
-
-# Identity of this package.
-PACKAGE_NAME=
-PACKAGE_TARNAME=
-PACKAGE_VERSION=
-PACKAGE_STRING=
-PACKAGE_BUGREPORT=
-
-ac_unique_file="man2tcl.c"
-ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS TCL_WIN_VERSION CC TCL_VERSION TCL_PATCH_LEVEL TCL_SRC_DIR TCL_BIN_DIR LIBOBJS LTLIBOBJS'
-ac_subst_files=''
-
-# Initialize some variables set by options.
-ac_init_help=
-ac_init_version=false
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-cache_file=/dev/null
-exec_prefix=NONE
-no_create=
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-verbose=
-x_includes=NONE
-x_libraries=NONE
-
-# Installation directory options.
-# These are left unexpanded so users can "make install exec_prefix=/foo"
-# and all the variables that are supposed to be based on exec_prefix
-# by default will actually change.
-# Use braces instead of parens because sh, perl, etc. also accept them.
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
-
-ac_prev=
-for ac_option
-do
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
- ac_prev=
- continue
- fi
-
- ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'`
-
- # Accept the important Cygnus configure options, so we can diagnose typos.
-
- case $ac_option in
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir=$ac_optarg ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build_alias ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build_alias=$ac_optarg ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file=$ac_optarg ;;
-
- --config-cache | -C)
- cache_file=config.cache ;;
-
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
- datadir=$ac_optarg ;;
-
- -disable-* | --disable-*)
- ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null &&
- { echo "$as_me: error: invalid feature name: $ac_feature" >&2
- { (exit 1); exit 1; }; }
- ac_feature=`echo $ac_feature | sed 's/-/_/g'`
- eval "enable_$ac_feature=no" ;;
-
- -enable-* | --enable-*)
- ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null &&
- { echo "$as_me: error: invalid feature name: $ac_feature" >&2
- { (exit 1); exit 1; }; }
- ac_feature=`echo $ac_feature | sed 's/-/_/g'`
- case $ac_option in
- *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;;
- *) ac_optarg=yes ;;
- esac
- eval "enable_$ac_feature='$ac_optarg'" ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix=$ac_optarg ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he | -h)
- ac_init_help=long ;;
- -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
- ac_init_help=recursive ;;
- -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
- ac_init_help=short ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host_alias ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host_alias=$ac_optarg ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir=$ac_optarg ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir=$ac_optarg ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir=$ac_optarg ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir=$ac_optarg ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
- localstatedir=$ac_optarg ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir=$ac_optarg ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c | -n)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir=$ac_optarg ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix=$ac_optarg ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix=$ac_optarg ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix=$ac_optarg ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name=$ac_optarg ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir=$ac_optarg ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir=$ac_optarg ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site=$ac_optarg ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir=$ac_optarg ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir=$ac_optarg ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target_alias ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target_alias=$ac_optarg ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers | -V)
- ac_init_version=: ;;
-
- -with-* | --with-*)
- ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null &&
- { echo "$as_me: error: invalid package name: $ac_package" >&2
- { (exit 1); exit 1; }; }
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- case $ac_option in
- *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;;
- *) ac_optarg=yes ;;
- esac
- eval "with_$ac_package='$ac_optarg'" ;;
-
- -without-* | --without-*)
- ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null &&
- { echo "$as_me: error: invalid package name: $ac_package" >&2
- { (exit 1); exit 1; }; }
- ac_package=`echo $ac_package | sed 's/-/_/g'`
- eval "with_$ac_package=no" ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes=$ac_optarg ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries=$ac_optarg ;;
-
- -*) { echo "$as_me: error: unrecognized option: $ac_option
-Try \`$0 --help' for more information." >&2
- { (exit 1); exit 1; }; }
- ;;
-
- *=*)
- ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
- # Reject names that are not valid shell variable names.
- expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&
- { echo "$as_me: error: invalid variable name: $ac_envvar" >&2
- { (exit 1); exit 1; }; }
- ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`
- eval "$ac_envvar='$ac_optarg'"
- export $ac_envvar ;;
-
- *)
- # FIXME: should be removed in autoconf 3.0.
- echo "$as_me: WARNING: you should use --build, --host, --target" >&2
- expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
- echo "$as_me: WARNING: invalid host type: $ac_option" >&2
- : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- ac_option=--`echo $ac_prev | sed 's/_/-/g'`
- { echo "$as_me: error: missing argument to $ac_option" >&2
- { (exit 1); exit 1; }; }
-fi
-
-# Be sure to have absolute paths.
-for ac_var in exec_prefix prefix
-do
- eval ac_val=$`echo $ac_var`
- case $ac_val in
- [\\/$]* | ?:[\\/]* | NONE | '' ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
- esac
-done
-
-# Be sure to have absolute paths.
-for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
- localstatedir libdir includedir oldincludedir infodir mandir
-do
- eval ac_val=$`echo $ac_var`
- case $ac_val in
- [\\/$]* | ?:[\\/]* ) ;;
- *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
- { (exit 1); exit 1; }; };;
- esac
-done
-
-# There might be people who depend on the old broken behavior: `$host'
-# used to hold the argument of --host etc.
-# FIXME: To remove some day.
-build=$build_alias
-host=$host_alias
-target=$target_alias
-
-# FIXME: To remove some day.
-if test "x$host_alias" != x; then
- if test "x$build_alias" = x; then
- cross_compiling=maybe
- echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.
- If a cross compiler is detected then cross compile mode will be used." >&2
- elif test "x$build_alias" != "x$host_alias"; then
- cross_compiling=yes
- fi
-fi
-
-ac_tool_prefix=
-test -n "$host_alias" && ac_tool_prefix=$host_alias-
-
-test "$silent" = yes && exec 6>/dev/null
-
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then its parent.
- ac_confdir=`(dirname "$0") 2>/dev/null ||
-$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$0" : 'X\(//\)[^/]' \| \
- X"$0" : 'X\(//\)$' \| \
- X"$0" : 'X\(/\)' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X"$0" |
- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
- /^X\(\/\/\)[^/].*/{ s//\1/; q; }
- /^X\(\/\/\)$/{ s//\1/; q; }
- /^X\(\/\).*/{ s//\1/; q; }
- s/.*/./; q'`
- srcdir=$ac_confdir
- if test ! -r $srcdir/$ac_unique_file; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r $srcdir/$ac_unique_file; then
- if test "$ac_srcdir_defaulted" = yes; then
- { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2
- { (exit 1); exit 1; }; }
- else
- { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
- { (exit 1); exit 1; }; }
- fi
-fi
-(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null ||
- { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2
- { (exit 1); exit 1; }; }
-srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'`
-ac_env_build_alias_set=${build_alias+set}
-ac_env_build_alias_value=$build_alias
-ac_cv_env_build_alias_set=${build_alias+set}
-ac_cv_env_build_alias_value=$build_alias
-ac_env_host_alias_set=${host_alias+set}
-ac_env_host_alias_value=$host_alias
-ac_cv_env_host_alias_set=${host_alias+set}
-ac_cv_env_host_alias_value=$host_alias
-ac_env_target_alias_set=${target_alias+set}
-ac_env_target_alias_value=$target_alias
-ac_cv_env_target_alias_set=${target_alias+set}
-ac_cv_env_target_alias_value=$target_alias
-
-#
-# Report the --help message.
-#
-if test "$ac_init_help" = "long"; then
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat <<_ACEOF
-\`configure' configures this package to adapt to many kinds of systems.
-
-Usage: $0 [OPTION]... [VAR=VALUE]...
-
-To assign environment variables (e.g., CC, CFLAGS...), specify them as
-VAR=VALUE. See below for descriptions of some of the useful variables.
-
-Defaults for the options are specified in brackets.
-
-Configuration:
- -h, --help display this help and exit
- --help=short display options specific to this package
- --help=recursive display the short help of all the included packages
- -V, --version display version information and exit
- -q, --quiet, --silent do not print \`checking...' messages
- --cache-file=FILE cache test results in FILE [disabled]
- -C, --config-cache alias for \`--cache-file=config.cache'
- -n, --no-create do not create output files
- --srcdir=DIR find the sources in DIR [configure dir or \`..']
-
-_ACEOF
-
- cat <<_ACEOF
-Installation directories:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [PREFIX]
-
-By default, \`make install' will install all the files in
-\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
-an installation prefix other than \`$ac_default_prefix' using \`--prefix',
-for instance \`--prefix=\$HOME'.
-
-For better control, use the options below.
-
-Fine tuning of the installation directories:
- --bindir=DIR user executables [EPREFIX/bin]
- --sbindir=DIR system admin executables [EPREFIX/sbin]
- --libexecdir=DIR program executables [EPREFIX/libexec]
- --datadir=DIR read-only architecture-independent data [PREFIX/share]
- --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data [PREFIX/var]
- --libdir=DIR object code libraries [EPREFIX/lib]
- --includedir=DIR C header files [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc [/usr/include]
- --infodir=DIR info documentation [PREFIX/info]
- --mandir=DIR man documentation [PREFIX/man]
-_ACEOF
-
- cat <<\_ACEOF
-_ACEOF
-fi
-
-if test -n "$ac_init_help"; then
-
- cat <<\_ACEOF
-
-Optional Packages:
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --with-tcl=DIR use Tcl $DEF_VER binaries from DIR
-
-_ACEOF
-fi
-
-if test "$ac_init_help" = "recursive"; then
- # If there are subdirs, report their specific --help.
- ac_popdir=`pwd`
- for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
- test -d $ac_dir || continue
- ac_builddir=.
-
-if test "$ac_dir" != .; then
- ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
- # A "../" for each directory in $ac_dir_suffix.
- ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'`
-else
- ac_dir_suffix= ac_top_builddir=
-fi
-
-case $srcdir in
- .) # No --srcdir option. We are building in place.
- ac_srcdir=.
- if test -z "$ac_top_builddir"; then
- ac_top_srcdir=.
- else
- ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'`
- fi ;;
- [\\/]* | ?:[\\/]* ) # Absolute path.
- ac_srcdir=$srcdir$ac_dir_suffix;
- ac_top_srcdir=$srcdir ;;
- *) # Relative path.
- ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
- ac_top_srcdir=$ac_top_builddir$srcdir ;;
-esac
-
-# Do not use `cd foo && pwd` to compute absolute paths, because
-# the directories may not exist.
-case `pwd` in
-.) ac_abs_builddir="$ac_dir";;
-*)
- case "$ac_dir" in
- .) ac_abs_builddir=`pwd`;;
- [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
- *) ac_abs_builddir=`pwd`/"$ac_dir";;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_top_builddir=${ac_top_builddir}.;;
-*)
- case ${ac_top_builddir}. in
- .) ac_abs_top_builddir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
- *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_srcdir=$ac_srcdir;;
-*)
- case $ac_srcdir in
- .) ac_abs_srcdir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
- *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_top_srcdir=$ac_top_srcdir;;
-*)
- case $ac_top_srcdir in
- .) ac_abs_top_srcdir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
- *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
- esac;;
-esac
-
- cd $ac_dir
- # Check for guested configure; otherwise get Cygnus style configure.
- if test -f $ac_srcdir/configure.gnu; then
- echo
- $SHELL $ac_srcdir/configure.gnu --help=recursive
- elif test -f $ac_srcdir/configure; then
- echo
- $SHELL $ac_srcdir/configure --help=recursive
- elif test -f $ac_srcdir/configure.ac ||
- test -f $ac_srcdir/configure.in; then
- echo
- $ac_configure --help
- else
- echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi
- cd $ac_popdir
- done
-fi
-
-test -n "$ac_init_help" && exit 0
-if $ac_init_version; then
- cat <<\_ACEOF
-
-Copyright (C) 2003 Free Software Foundation, Inc.
-This configure script is free software; the Free Software Foundation
-gives unlimited permission to copy, distribute and modify it.
-_ACEOF
- exit 0
-fi
-exec 5>config.log
-cat >&5 <<_ACEOF
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-
-It was created by $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
-
- $ $0 $@
-
-_ACEOF
-{
-cat <<_ASUNAME
-## --------- ##
-## Platform. ##
-## --------- ##
-
-hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
-uname -m = `(uname -m) 2>/dev/null || echo unknown`
-uname -r = `(uname -r) 2>/dev/null || echo unknown`
-uname -s = `(uname -s) 2>/dev/null || echo unknown`
-uname -v = `(uname -v) 2>/dev/null || echo unknown`
-
-/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
-/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
-
-/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
-/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
-hostinfo = `(hostinfo) 2>/dev/null || echo unknown`
-/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
-/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
-/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
-
-_ASUNAME
-
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- echo "PATH: $as_dir"
-done
-
-} >&5
-
-cat >&5 <<_ACEOF
-
-
-## ----------- ##
-## Core tests. ##
-## ----------- ##
-
-_ACEOF
-
-
-# Keep a trace of the command line.
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Strip out --silent because we don't want to record it for future runs.
-# Also quote any args containing shell meta-characters.
-# Make two passes to allow for proper duplicate-argument suppression.
-ac_configure_args=
-ac_configure_args0=
-ac_configure_args1=
-ac_sep=
-ac_must_keep_next=false
-for ac_pass in 1 2
-do
- for ac_arg
- do
- case $ac_arg in
- -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- continue ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
- ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
- esac
- case $ac_pass in
- 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
- 2)
- ac_configure_args1="$ac_configure_args1 '$ac_arg'"
- if test $ac_must_keep_next = true; then
- ac_must_keep_next=false # Got value, back to normal.
- else
- case $ac_arg in
- *=* | --config-cache | -C | -disable-* | --disable-* \
- | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
- | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
- | -with-* | --with-* | -without-* | --without-* | --x)
- case "$ac_configure_args0 " in
- "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
- esac
- ;;
- -* ) ac_must_keep_next=true ;;
- esac
- fi
- ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
- # Get rid of the leading space.
- ac_sep=" "
- ;;
- esac
- done
-done
-$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }
-$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }
-
-# When interrupted or exit'd, cleanup temporary files, and complete
-# config.log. We remove comments because anyway the quotes in there
-# would cause problems or look ugly.
-# WARNING: Be sure not to use single quotes in there, as some shells,
-# such as our DU 5.0 friend, will then `close' the trap.
-trap 'exit_status=$?
- # Save into config.log some information that might help in debugging.
- {
- echo
-
- cat <<\_ASBOX
-## ---------------- ##
-## Cache variables. ##
-## ---------------- ##
-_ASBOX
- echo
- # The following way of writing the cache mishandles newlines in values,
-{
- (set) 2>&1 |
- case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
- *ac_space=\ *)
- sed -n \
- "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
- ;;
- *)
- sed -n \
- "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
- ;;
- esac;
-}
- echo
-
- cat <<\_ASBOX
-## ----------------- ##
-## Output variables. ##
-## ----------------- ##
-_ASBOX
- echo
- for ac_var in $ac_subst_vars
- do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
- done | sort
- echo
-
- if test -n "$ac_subst_files"; then
- cat <<\_ASBOX
-## ------------- ##
-## Output files. ##
-## ------------- ##
-_ASBOX
- echo
- for ac_var in $ac_subst_files
- do
- eval ac_val=$`echo $ac_var`
- echo "$ac_var='"'"'$ac_val'"'"'"
- done | sort
- echo
- fi
-
- if test -s confdefs.h; then
- cat <<\_ASBOX
-## ----------- ##
-## confdefs.h. ##
-## ----------- ##
-_ASBOX
- echo
- sed "/^$/d" confdefs.h | sort
- echo
- fi
- test "$ac_signal" != 0 &&
- echo "$as_me: caught signal $ac_signal"
- echo "$as_me: exit $exit_status"
- } >&5
- rm -f core *.core &&
- rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
- exit $exit_status
- ' 0
-for ac_signal in 1 2 13 15; do
- trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
-done
-ac_signal=0
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -rf conftest* confdefs.h
-# AIX cpp loses on an empty file, so make sure it contains at least a newline.
-echo >confdefs.h
-
-# Predefined preprocessor variables.
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_NAME "$PACKAGE_NAME"
-_ACEOF
-
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
-_ACEOF
-
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_VERSION "$PACKAGE_VERSION"
-_ACEOF
-
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_STRING "$PACKAGE_STRING"
-_ACEOF
-
-
-cat >>confdefs.h <<_ACEOF
-#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
-_ACEOF
-
-
-# Let the site file select an alternate cache file if it wants to.
-# Prefer explicitly selected file to automatically selected ones.
-if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
-fi
-for ac_site_file in $CONFIG_SITE; do
- if test -r "$ac_site_file"; then
- { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
-echo "$as_me: loading site script $ac_site_file" >&6;}
- sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file"
- fi
-done
-
-if test -r "$cache_file"; then
- # Some versions of bash will fail to source /dev/null (special
- # files actually), so we avoid doing that.
- if test -f "$cache_file"; then
- { echo "$as_me:$LINENO: loading cache $cache_file" >&5
-echo "$as_me: loading cache $cache_file" >&6;}
- case $cache_file in
- [\\/]* | ?:[\\/]* ) . $cache_file;;
- *) . ./$cache_file;;
- esac
- fi
-else
- { echo "$as_me:$LINENO: creating cache $cache_file" >&5
-echo "$as_me: creating cache $cache_file" >&6;}
- >$cache_file
-fi
-
-# Check that the precious variables saved in the cache have kept the same
-# value.
-ac_cache_corrupted=false
-for ac_var in `(set) 2>&1 |
- sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
- eval ac_old_set=\$ac_cv_env_${ac_var}_set
- eval ac_new_set=\$ac_env_${ac_var}_set
- eval ac_old_val="\$ac_cv_env_${ac_var}_value"
- eval ac_new_val="\$ac_env_${ac_var}_value"
- case $ac_old_set,$ac_new_set in
- set,)
- { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
-echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
- ac_cache_corrupted=: ;;
- ,set)
- { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
-echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
- ac_cache_corrupted=: ;;
- ,);;
- *)
- if test "x$ac_old_val" != "x$ac_new_val"; then
- { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
-echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
- { echo "$as_me:$LINENO: former value: $ac_old_val" >&5
-echo "$as_me: former value: $ac_old_val" >&2;}
- { echo "$as_me:$LINENO: current value: $ac_new_val" >&5
-echo "$as_me: current value: $ac_new_val" >&2;}
- ac_cache_corrupted=:
- fi;;
- esac
- # Pass precious variables to config.status.
- if test "$ac_new_set" = set; then
- case $ac_new_val in
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
- ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
- *) ac_arg=$ac_var=$ac_new_val ;;
- esac
- case " $ac_configure_args " in
- *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
- *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
- esac
- fi
-done
-if $ac_cache_corrupted; then
- { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
-echo "$as_me: error: changes in the environment can compromise the build" >&2;}
- { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
-echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
- { (exit 1); exit 1; }; }
-fi
-
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Recover information that Tcl computed with its configure script.
-
-#--------------------------------------------------------------------
-# See if there was a command-line option for where Tcl is; if
-# not, assume that its top-level directory is a sibling of ours.
-#--------------------------------------------------------------------
-
-DEF_VER=8.6
-
-
-# Check whether --with-tcl or --without-tcl was given.
-if test "${with_tcl+set}" = set; then
- withval="$with_tcl"
- TCL_BIN_DIR=$withval
-else
- TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`
-fi;
-if test ! -d $TCL_BIN_DIR; then
- { { echo "$as_me:$LINENO: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&5
-echo "$as_me: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&2;}
- { (exit 1); exit 1; }; }
-fi
-if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
- { { echo "$as_me:$LINENO: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&5
-echo "$as_me: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&2;}
- { (exit 1); exit 1; }; }
-fi
-
-. $TCL_BIN_DIR/tclConfig.sh
-
-TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-
-CC=$TCL_CC
-
-
-
-
-
-
- ac_config_files="$ac_config_files Makefile tcl.hpj"
-
-cat >confcache <<\_ACEOF
-# This file is a shell script that caches the results of configure
-# tests run on this system so they can be shared between configure
-# scripts and configure runs, see configure's option --config-cache.
-# It is not useful on other systems. If it contains results you don't
-# want to keep, you may remove or edit it.
-#
-# config.status only pays attention to the cache file if you give it
-# the --recheck option to rerun configure.
-#
-# `ac_cv_env_foo' variables (set or unset) will be overridden when
-# loading this file, other *unset* `ac_cv_foo' will be assigned the
-# following values.
-
-_ACEOF
-
-# The following way of writing the cache mishandles newlines in values,
-# but we know of no workaround that is simple, portable, and efficient.
-# So, don't put newlines in cache variables' values.
-# Ultrix sh set writes to stderr and can't be redirected directly,
-# and sets the high bit in the cache file unless we assign to the vars.
-{
- (set) 2>&1 |
- case `(ac_space=' '; set | grep ac_space) 2>&1` in
- *ac_space=\ *)
- # `set' does not quote correctly, so add quotes (double-quote
- # substitution turns \\\\ into \\, and sed turns \\ into \).
- sed -n \
- "s/'/'\\\\''/g;
- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
- ;;
- *)
- # `set' quotes correctly as required by POSIX, so do not add quotes.
- sed -n \
- "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
- ;;
- esac;
-} |
- sed '
- t clear
- : clear
- s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
- t end
- /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
- : end' >>confcache
-if diff $cache_file confcache >/dev/null 2>&1; then :; else
- if test -w $cache_file; then
- test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file"
- cat confcache >$cache_file
- else
- echo "not updating unwritable cache $cache_file"
- fi
-fi
-rm -f confcache
-
-test "x$prefix" = xNONE && prefix=$ac_default_prefix
-# Let make expand exec_prefix.
-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
-
-# VPATH may cause trouble with some makes, so we remove $(srcdir),
-# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
-# trailing colons and then remove the whole line if VPATH becomes empty
-# (actually we leave an empty line to preserve line numbers).
-if test "x$srcdir" = x.; then
- ac_vpsub='/^[ ]*VPATH[ ]*=/{
-s/:*\$(srcdir):*/:/;
-s/:*\${srcdir}:*/:/;
-s/:*@srcdir@:*/:/;
-s/^\([^=]*=[ ]*\):*/\1/;
-s/:*$//;
-s/^[^=]*=[ ]*$//;
-}'
-fi
-
-# Transform confdefs.h into DEFS.
-# Protect against shell expansion while executing Makefile rules.
-# Protect against Makefile macro expansion.
-#
-# If the first sed substitution is executed (which looks for macros that
-# take arguments), then we branch to the quote section. Otherwise,
-# look for a macro that doesn't take arguments.
-cat >confdef2opt.sed <<\_ACEOF
-t clear
-: clear
-s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
-t quote
-s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
-t quote
-d
-: quote
-s,[ `~#$^&*(){}\\|;'"<>?],\\&,g
-s,\[,\\&,g
-s,\],\\&,g
-s,\$,$$,g
-p
-_ACEOF
-# We use echo to avoid assuming a particular line-breaking character.
-# The extra dot is to prevent the shell from consuming trailing
-# line-breaks from the sub-command output. A line-break within
-# single-quotes doesn't work because, if this script is created in a
-# platform that uses two characters for line-breaks (e.g., DOS), tr
-# would break.
-ac_LF_and_DOT=`echo; echo .`
-DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
-rm -f confdef2opt.sed
-
-
-ac_libobjs=
-ac_ltlibobjs=
-for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
- # 1. Remove the extension, and $U if already installed.
- ac_i=`echo "$ac_i" |
- sed 's/\$U\././;s/\.o$//;s/\.obj$//'`
- # 2. Add them.
- ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext"
- ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo'
-done
-LIBOBJS=$ac_libobjs
-
-LTLIBOBJS=$ac_ltlibobjs
-
-
-
-: ${CONFIG_STATUS=./config.status}
-ac_clean_files_save=$ac_clean_files
-ac_clean_files="$ac_clean_files $CONFIG_STATUS"
-{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
-echo "$as_me: creating $CONFIG_STATUS" >&6;}
-cat >$CONFIG_STATUS <<_ACEOF
-#! $SHELL
-# Generated by $as_me.
-# Run this file to recreate the current configuration.
-# Compiler output produced by configure, useful for debugging
-# configure, is in config.log if it exists.
-
-debug=false
-ac_cs_recheck=false
-ac_cs_silent=false
-SHELL=\${CONFIG_SHELL-$SHELL}
-_ACEOF
-
-cat >>$CONFIG_STATUS <<\_ACEOF
-## --------------------- ##
-## M4sh Initialization. ##
-## --------------------- ##
-
-# Be Bourne compatible
-if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
- emulate sh
- NULLCMD=:
- # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
- # is contrary to our usage. Disable this feature.
- alias -g '${1+"$@"}'='"$@"'
-elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
- set -o posix
-fi
-DUALCASE=1; export DUALCASE # for MKS sh
-
-# Support unset when possible.
-if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
- as_unset=unset
-else
- as_unset=false
-fi
-
-
-# Work around bugs in pre-3.0 UWIN ksh.
-$as_unset ENV MAIL MAILPATH
-PS1='$ '
-PS2='> '
-PS4='+ '
-
-# NLS nuisances.
-for as_var in \
- LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
- LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
- LC_TELEPHONE LC_TIME
-do
- if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
- eval $as_var=C; export $as_var
- else
- $as_unset $as_var
- fi
-done
-
-# Required to use basename.
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
-
-if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
- as_basename=basename
-else
- as_basename=false
-fi
-
-
-# Name of the executable.
-as_me=`$as_basename "$0" ||
-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
- X"$0" : 'X\(//\)$' \| \
- X"$0" : 'X\(/\)$' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X/"$0" |
- sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; }
- /^X\/\(\/\/\)$/{ s//\1/; q; }
- /^X\/\(\/\).*/{ s//\1/; q; }
- s/.*/./; q'`
-
-
-# PATH needs CR, and LINENO needs CR and PATH.
-# Avoid depending upon Character Ranges.
-as_cr_letters='abcdefghijklmnopqrstuvwxyz'
-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
-as_cr_Letters=$as_cr_letters$as_cr_LETTERS
-as_cr_digits='0123456789'
-as_cr_alnum=$as_cr_Letters$as_cr_digits
-
-# The user is always right.
-if test "${PATH_SEPARATOR+set}" != set; then
- echo "#! /bin/sh" >conf$$.sh
- echo "exit 0" >>conf$$.sh
- chmod +x conf$$.sh
- if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
- PATH_SEPARATOR=';'
- else
- PATH_SEPARATOR=:
- fi
- rm -f conf$$.sh
-fi
-
-
- as_lineno_1=$LINENO
- as_lineno_2=$LINENO
- as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
- test "x$as_lineno_1" != "x$as_lineno_2" &&
- test "x$as_lineno_3" = "x$as_lineno_2" || {
- # Find who we are. Look in the path if we contain no path at all
- # relative or not.
- case $0 in
- *[\\/]* ) as_myself=$0 ;;
- *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
-done
-
- ;;
- esac
- # We did not find ourselves, most probably we were run as `sh COMMAND'
- # in which case we are not to be found in the path.
- if test "x$as_myself" = x; then
- as_myself=$0
- fi
- if test ! -f "$as_myself"; then
- { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5
-echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;}
- { (exit 1); exit 1; }; }
- fi
- case $CONFIG_SHELL in
- '')
- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
-do
- IFS=$as_save_IFS
- test -z "$as_dir" && as_dir=.
- for as_base in sh bash ksh sh5; do
- case $as_dir in
- /*)
- if ("$as_dir/$as_base" -c '
- as_lineno_1=$LINENO
- as_lineno_2=$LINENO
- as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
- test "x$as_lineno_1" != "x$as_lineno_2" &&
- test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then
- $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; }
- $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; }
- CONFIG_SHELL=$as_dir/$as_base
- export CONFIG_SHELL
- exec "$CONFIG_SHELL" "$0" ${1+"$@"}
- fi;;
- esac
- done
-done
-;;
- esac
-
- # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
- # uniformly replaced by the line number. The first 'sed' inserts a
- # line-number line before each line; the second 'sed' does the real
- # work. The second script uses 'N' to pair each line-number line
- # with the numbered line, and appends trailing '-' during
- # substitution so that $LINENO is not a special case at line end.
- # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
- # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-)
- sed '=' <$as_myself |
- sed '
- N
- s,$,-,
- : loop
- s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
- t loop
- s,-$,,
- s,^['$as_cr_digits']*\n,,
- ' >$as_me.lineno &&
- chmod +x $as_me.lineno ||
- { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5
-echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;}
- { (exit 1); exit 1; }; }
-
- # Don't try to exec as it changes $[0], causing all sort of problems
- # (the dirname of $[0] is not the place where we might find the
- # original and so on. Autoconf is especially sensible to this).
- . ./$as_me.lineno
- # Exit status is that of the last command.
- exit
-}
-
-
-case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in
- *c*,-n*) ECHO_N= ECHO_C='
-' ECHO_T=' ' ;;
- *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;;
- *) ECHO_N= ECHO_C='\c' ECHO_T= ;;
-esac
-
-if expr a : '\(a\)' >/dev/null 2>&1; then
- as_expr=expr
-else
- as_expr=false
-fi
-
-rm -f conf$$ conf$$.exe conf$$.file
-echo >conf$$.file
-if ln -s conf$$.file conf$$ 2>/dev/null; then
- # We could just check for DJGPP; but this test a) works b) is more generic
- # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04).
- if test -f conf$$.exe; then
- # Don't use ln at all; we don't have any links
- as_ln_s='cp -p'
- else
- as_ln_s='ln -s'
- fi
-elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
-else
- as_ln_s='cp -p'
-fi
-rm -f conf$$ conf$$.exe conf$$.file
-
-if mkdir -p . 2>/dev/null; then
- as_mkdir_p=:
-else
- test -d ./-p && rmdir ./-p
- as_mkdir_p=false
-fi
-
-as_executable_p="test -f"
-
-# Sed expression to map a string onto a valid CPP name.
-as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
-
-# Sed expression to map a string onto a valid variable name.
-as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
-
-
-# IFS
-# We need space, tab and new line, in precisely that order.
-as_nl='
-'
-IFS=" $as_nl"
-
-# CDPATH.
-$as_unset CDPATH
-
-exec 6>&1
-
-# Open the log real soon, to keep \$[0] and so on meaningful, and to
-# report actual input values of CONFIG_FILES etc. instead of their
-# values after options handling. Logging --version etc. is OK.
-exec 5>>config.log
-{
- echo
- sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
-## Running $as_me. ##
-_ASBOX
-} >&5
-cat >&5 <<_CSEOF
-
-This file was extended by $as_me, which was
-generated by GNU Autoconf 2.59. Invocation command line was
-
- CONFIG_FILES = $CONFIG_FILES
- CONFIG_HEADERS = $CONFIG_HEADERS
- CONFIG_LINKS = $CONFIG_LINKS
- CONFIG_COMMANDS = $CONFIG_COMMANDS
- $ $0 $@
-
-_CSEOF
-echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5
-echo >&5
-_ACEOF
-
-# Files that config.status was made for.
-if test -n "$ac_config_files"; then
- echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS
-fi
-
-if test -n "$ac_config_headers"; then
- echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS
-fi
-
-if test -n "$ac_config_links"; then
- echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS
-fi
-
-if test -n "$ac_config_commands"; then
- echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS
-fi
-
-cat >>$CONFIG_STATUS <<\_ACEOF
-
-ac_cs_usage="\
-\`$as_me' instantiates files from templates according to the
-current configuration.
-
-Usage: $0 [OPTIONS] [FILE]...
-
- -h, --help print this help, then exit
- -V, --version print version number, then exit
- -q, --quiet do not print progress messages
- -d, --debug don't remove temporary files
- --recheck update $as_me by reconfiguring in the same conditions
- --file=FILE[:TEMPLATE]
- instantiate the configuration file FILE
-
-Configuration files:
-$config_files
-
-Report bugs to <bug-autoconf@gnu.org>."
-_ACEOF
-
-cat >>$CONFIG_STATUS <<_ACEOF
-ac_cs_version="\\
-config.status
-configured by $0, generated by GNU Autoconf 2.59,
- with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
-
-Copyright (C) 2003 Free Software Foundation, Inc.
-This config.status script is free software; the Free Software Foundation
-gives unlimited permission to copy, distribute and modify it."
-srcdir=$srcdir
-_ACEOF
-
-cat >>$CONFIG_STATUS <<\_ACEOF
-# If no file are specified by the user, then we need to provide default
-# value. By we need to know if files were specified by the user.
-ac_need_defaults=:
-while test $# != 0
-do
- case $1 in
- --*=*)
- ac_option=`expr "x$1" : 'x\([^=]*\)='`
- ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'`
- ac_shift=:
- ;;
- -*)
- ac_option=$1
- ac_optarg=$2
- ac_shift=shift
- ;;
- *) # This is not an option, so the user has probably given explicit
- # arguments.
- ac_option=$1
- ac_need_defaults=false;;
- esac
-
- case $ac_option in
- # Handling of the options.
-_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
- ac_cs_recheck=: ;;
- --version | --vers* | -V )
- echo "$ac_cs_version"; exit 0 ;;
- --he | --h)
- # Conflict between --help and --header
- { { echo "$as_me:$LINENO: error: ambiguous option: $1
-Try \`$0 --help' for more information." >&5
-echo "$as_me: error: ambiguous option: $1
-Try \`$0 --help' for more information." >&2;}
- { (exit 1); exit 1; }; };;
- --help | --hel | -h )
- echo "$ac_cs_usage"; exit 0 ;;
- --debug | --d* | -d )
- debug=: ;;
- --file | --fil | --fi | --f )
- $ac_shift
- CONFIG_FILES="$CONFIG_FILES $ac_optarg"
- ac_need_defaults=false;;
- --header | --heade | --head | --hea )
- $ac_shift
- CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg"
- ac_need_defaults=false;;
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil | --si | --s)
- ac_cs_silent=: ;;
-
- # This is an error.
- -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1
-Try \`$0 --help' for more information." >&5
-echo "$as_me: error: unrecognized option: $1
-Try \`$0 --help' for more information." >&2;}
- { (exit 1); exit 1; }; } ;;
-
- *) ac_config_targets="$ac_config_targets $1" ;;
-
- esac
- shift
-done
-
-ac_configure_extra_args=
-
-if $ac_cs_silent; then
- exec 6>/dev/null
- ac_configure_extra_args="$ac_configure_extra_args --silent"
-fi
-
-_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
-if \$ac_cs_recheck; then
- echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
- exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
-fi
-
-_ACEOF
-
-
-
-
-
-cat >>$CONFIG_STATUS <<\_ACEOF
-for ac_config_target in $ac_config_targets
-do
- case "$ac_config_target" in
- # Handling of arguments.
- "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
- "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;;
- *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
-echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
- { (exit 1); exit 1; }; };;
- esac
-done
-
-# If the user did not use the arguments to specify the items to instantiate,
-# then the envvar interface is used. Set only those that are not.
-# We use the long form for the default assignment because of an extremely
-# bizarre bug on SunOS 4.1.3.
-if $ac_need_defaults; then
- test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
-fi
-
-# Have a temporary directory for convenience. Make it in the build tree
-# simply because there is no reason to put it here, and in addition,
-# creating and moving files from /tmp can sometimes cause problems.
-# Create a temporary directory, and hook for its removal unless debugging.
-$debug ||
-{
- trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0
- trap '{ (exit 1); exit 1; }' 1 2 13 15
-}
-
-# Create a (secure) tmp directory for tmp files.
-
-{
- tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` &&
- test -n "$tmp" && test -d "$tmp"
-} ||
-{
- tmp=./confstat$$-$RANDOM
- (umask 077 && mkdir $tmp)
-} ||
-{
- echo "$me: cannot create a temporary directory in ." >&2
- { (exit 1); exit 1; }
-}
-
-_ACEOF
-
-cat >>$CONFIG_STATUS <<_ACEOF
-
-#
-# CONFIG_FILES section.
-#
-
-# No need to generate the scripts if there are no CONFIG_FILES.
-# This happens for instance when ./config.status config.h
-if test -n "\$CONFIG_FILES"; then
- # Protect against being on the right side of a sed subst in config.status.
- sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g;
- s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF
-s,@SHELL@,$SHELL,;t t
-s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t
-s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t
-s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t
-s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t
-s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t
-s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t
-s,@exec_prefix@,$exec_prefix,;t t
-s,@prefix@,$prefix,;t t
-s,@program_transform_name@,$program_transform_name,;t t
-s,@bindir@,$bindir,;t t
-s,@sbindir@,$sbindir,;t t
-s,@libexecdir@,$libexecdir,;t t
-s,@datadir@,$datadir,;t t
-s,@sysconfdir@,$sysconfdir,;t t
-s,@sharedstatedir@,$sharedstatedir,;t t
-s,@localstatedir@,$localstatedir,;t t
-s,@libdir@,$libdir,;t t
-s,@includedir@,$includedir,;t t
-s,@oldincludedir@,$oldincludedir,;t t
-s,@infodir@,$infodir,;t t
-s,@mandir@,$mandir,;t t
-s,@build_alias@,$build_alias,;t t
-s,@host_alias@,$host_alias,;t t
-s,@target_alias@,$target_alias,;t t
-s,@DEFS@,$DEFS,;t t
-s,@ECHO_C@,$ECHO_C,;t t
-s,@ECHO_N@,$ECHO_N,;t t
-s,@ECHO_T@,$ECHO_T,;t t
-s,@LIBS@,$LIBS,;t t
-s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t
-s,@CC@,$CC,;t t
-s,@TCL_VERSION@,$TCL_VERSION,;t t
-s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
-s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t
-s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t
-s,@LIBOBJS@,$LIBOBJS,;t t
-s,@LTLIBOBJS@,$LTLIBOBJS,;t t
-CEOF
-
-_ACEOF
-
- cat >>$CONFIG_STATUS <<\_ACEOF
- # Split the substitutions into bite-sized pieces for seds with
- # small command number limits, like on Digital OSF/1 and HP-UX.
- ac_max_sed_lines=48
- ac_sed_frag=1 # Number of current file.
- ac_beg=1 # First line for current file.
- ac_end=$ac_max_sed_lines # Line after last line for current file.
- ac_more_lines=:
- ac_sed_cmds=
- while $ac_more_lines; do
- if test $ac_beg -gt 1; then
- sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag
- else
- sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag
- fi
- if test ! -s $tmp/subs.frag; then
- ac_more_lines=false
- else
- # The purpose of the label and of the branching condition is to
- # speed up the sed processing (if there are no `@' at all, there
- # is no need to browse any of the substitutions).
- # These are the two extra sed commands mentioned above.
- (echo ':t
- /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
- else
- ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
- fi
- ac_sed_frag=`expr $ac_sed_frag + 1`
- ac_beg=$ac_end
- ac_end=`expr $ac_end + $ac_max_sed_lines`
- fi
- done
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds=cat
- fi
-fi # test -n "$CONFIG_FILES"
-
-_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
-for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
- # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
- case $ac_file in
- - | *:- | *:-:* ) # input from stdin
- cat >$tmp/stdin
- ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
- ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
- *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
- ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
- * ) ac_file_in=$ac_file.in ;;
- esac
-
- # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
- ac_dir=`(dirname "$ac_file") 2>/dev/null ||
-$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$ac_file" : 'X\(//\)[^/]' \| \
- X"$ac_file" : 'X\(//\)$' \| \
- X"$ac_file" : 'X\(/\)' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X"$ac_file" |
- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
- /^X\(\/\/\)[^/].*/{ s//\1/; q; }
- /^X\(\/\/\)$/{ s//\1/; q; }
- /^X\(\/\).*/{ s//\1/; q; }
- s/.*/./; q'`
- { if $as_mkdir_p; then
- mkdir -p "$ac_dir"
- else
- as_dir="$ac_dir"
- as_dirs=
- while test ! -d "$as_dir"; do
- as_dirs="$as_dir $as_dirs"
- as_dir=`(dirname "$as_dir") 2>/dev/null ||
-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$as_dir" : 'X\(//\)[^/]' \| \
- X"$as_dir" : 'X\(//\)$' \| \
- X"$as_dir" : 'X\(/\)' \| \
- . : '\(.\)' 2>/dev/null ||
-echo X"$as_dir" |
- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
- /^X\(\/\/\)[^/].*/{ s//\1/; q; }
- /^X\(\/\/\)$/{ s//\1/; q; }
- /^X\(\/\).*/{ s//\1/; q; }
- s/.*/./; q'`
- done
- test ! -n "$as_dirs" || mkdir $as_dirs
- fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5
-echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;}
- { (exit 1); exit 1; }; }; }
-
- ac_builddir=.
-
-if test "$ac_dir" != .; then
- ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
- # A "../" for each directory in $ac_dir_suffix.
- ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'`
-else
- ac_dir_suffix= ac_top_builddir=
-fi
-
-case $srcdir in
- .) # No --srcdir option. We are building in place.
- ac_srcdir=.
- if test -z "$ac_top_builddir"; then
- ac_top_srcdir=.
- else
- ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'`
- fi ;;
- [\\/]* | ?:[\\/]* ) # Absolute path.
- ac_srcdir=$srcdir$ac_dir_suffix;
- ac_top_srcdir=$srcdir ;;
- *) # Relative path.
- ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
- ac_top_srcdir=$ac_top_builddir$srcdir ;;
-esac
-
-# Do not use `cd foo && pwd` to compute absolute paths, because
-# the directories may not exist.
-case `pwd` in
-.) ac_abs_builddir="$ac_dir";;
-*)
- case "$ac_dir" in
- .) ac_abs_builddir=`pwd`;;
- [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
- *) ac_abs_builddir=`pwd`/"$ac_dir";;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_top_builddir=${ac_top_builddir}.;;
-*)
- case ${ac_top_builddir}. in
- .) ac_abs_top_builddir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
- *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_srcdir=$ac_srcdir;;
-*)
- case $ac_srcdir in
- .) ac_abs_srcdir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
- *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
- esac;;
-esac
-case $ac_abs_builddir in
-.) ac_abs_top_srcdir=$ac_top_srcdir;;
-*)
- case $ac_top_srcdir in
- .) ac_abs_top_srcdir=$ac_abs_builddir;;
- [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
- *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
- esac;;
-esac
-
-
-
- if test x"$ac_file" != x-; then
- { echo "$as_me:$LINENO: creating $ac_file" >&5
-echo "$as_me: creating $ac_file" >&6;}
- rm -f "$ac_file"
- fi
- # Let's still pretend it is `configure' which instantiates (i.e., don't
- # use $as_me), people would be surprised to read:
- # /* config.h. Generated by config.status. */
- if test x"$ac_file" = x-; then
- configure_input=
- else
- configure_input="$ac_file. "
- fi
- configure_input=$configure_input"Generated from `echo $ac_file_in |
- sed 's,.*/,,'` by configure."
-
- # First look for the input files in the build tree, otherwise in the
- # src tree.
- ac_file_inputs=`IFS=:
- for f in $ac_file_in; do
- case $f in
- -) echo $tmp/stdin ;;
- [\\/$]*)
- # Absolute (can't be DOS-style, as IFS=:)
- test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
-echo "$as_me: error: cannot find input file: $f" >&2;}
- { (exit 1); exit 1; }; }
- echo "$f";;
- *) # Relative
- if test -f "$f"; then
- # Build tree
- echo "$f"
- elif test -f "$srcdir/$f"; then
- # Source tree
- echo "$srcdir/$f"
- else
- # /dev/null tree
- { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
-echo "$as_me: error: cannot find input file: $f" >&2;}
- { (exit 1); exit 1; }; }
- fi;;
- esac
- done` || { (exit 1); exit 1; }
-_ACEOF
-cat >>$CONFIG_STATUS <<_ACEOF
- sed "$ac_vpsub
-$extrasub
-_ACEOF
-cat >>$CONFIG_STATUS <<\_ACEOF
-:t
-/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
-s,@configure_input@,$configure_input,;t t
-s,@srcdir@,$ac_srcdir,;t t
-s,@abs_srcdir@,$ac_abs_srcdir,;t t
-s,@top_srcdir@,$ac_top_srcdir,;t t
-s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t
-s,@builddir@,$ac_builddir,;t t
-s,@abs_builddir@,$ac_abs_builddir,;t t
-s,@top_builddir@,$ac_top_builddir,;t t
-s,@abs_top_builddir@,$ac_abs_top_builddir,;t t
-" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out
- rm -f $tmp/stdin
- if test x"$ac_file" != x-; then
- mv $tmp/out $ac_file
- else
- cat $tmp/out
- rm -f $tmp/out
- fi
-
-done
-_ACEOF
-
-cat >>$CONFIG_STATUS <<\_ACEOF
-
-{ (exit 0); exit 0; }
-_ACEOF
-chmod +x $CONFIG_STATUS
-ac_clean_files=$ac_clean_files_save
-
-
-# configure is writing to config.log, and then calls config.status.
-# config.status does its own redirection, appending to config.log.
-# Unfortunately, on DOS this fails, as config.log is still kept open
-# by configure, so config.status won't be able to write to it; its
-# output is simply discarded. So we exec the FD to /dev/null,
-# effectively closing config.log, so it can be properly (re)opened and
-# appended to by config.status. When coming back to configure, we
-# need to make the FD available again.
-if test "$no_create" != yes; then
- ac_cs_success=:
- ac_config_status_args=
- test "$silent" = yes &&
- ac_config_status_args="$ac_config_status_args --quiet"
- exec 5>/dev/null
- $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
- exec 5>>config.log
- # Use ||, not &&, to avoid exiting from the if with $? = 1, which
- # would make configure fail if this is the last instruction.
- $ac_cs_success || { (exit 1); exit 1; }
-fi
-
diff --git a/tools/configure.in b/tools/configure.in
deleted file mode 100644
index 86e1f62..0000000
--- a/tools/configure.in
+++ /dev/null
@@ -1,37 +0,0 @@
-dnl This file is an input file used by the GNU "autoconf" program to
-dnl generate the file "configure", which is run to configure the
-dnl Makefile in this directory.
-AC_INIT
-AC_CONFIG_SRCDIR([man2tcl.c])
-AC_PREREQ([2.59])
-
-# Recover information that Tcl computed with its configure script.
-
-#--------------------------------------------------------------------
-# See if there was a command-line option for where Tcl is; if
-# not, assume that its top-level directory is a sibling of ours.
-#--------------------------------------------------------------------
-
-DEF_VER=8.6
-
-AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`)
-if test ! -d $TCL_BIN_DIR; then
- AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist)
-fi
-if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
- AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
-fi
-
-. $TCL_BIN_DIR/tclConfig.sh
-
-TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-AC_SUBST(TCL_WIN_VERSION)
-CC=$TCL_CC
-AC_SUBST(CC)
-AC_SUBST(TCL_VERSION)
-AC_SUBST(TCL_PATCH_LEVEL)
-AC_SUBST(TCL_SRC_DIR)
-AC_SUBST(TCL_BIN_DIR)
-
-AC_CONFIG_FILES([Makefile tcl.hpj])
-AC_OUTPUT
diff --git a/tools/encoding/Makefile b/tools/encoding/Makefile
index 361239e..ff19492 100644
--- a/tools/encoding/Makefile
+++ b/tools/encoding/Makefile